From 28e8e3e751a6d5d81b640fb779304329f3edb82d Mon Sep 17 00:00:00 2001 From: Ryan Mulhall <35538242+rem1776@users.noreply.github.com> Date: Thu, 24 Feb 2022 09:07:08 -0500 Subject: [PATCH] fix: clean up unused/uninitialized variables and other warnings (#859) Remove unused variables throughout and changes/removals for other warnings such as uninitialized values and implicit casts --- amip_interp/amip_interp.F90 | 12 +-- astronomy/astronomy.F90 | 6 +- axis_utils/axis_utils.F90 | 11 +-- axis_utils/axis_utils2.F90 | 10 +- column_diagnostics/column_diagnostics.F90 | 2 +- constants/constants.F90 | 2 - coupler/coupler_types.F90 | 16 +--- coupler/ensemble_manager.F90 | 2 +- data_override/data_override.F90 | 6 +- data_override/get_grid_version.F90 | 1 - diag_integral/diag_integral.F90 | 4 +- diag_manager/diag_axis.F90 | 5 +- diag_manager/diag_manager.F90 | 8 +- diag_manager/diag_output.F90 | 11 +-- diag_manager/diag_util.F90 | 8 +- drifters/drifters.F90 | 1 - exchange/stock_constants.F90 | 1 - exchange/xgrid.F90 | 92 +++++++++---------- field_manager/field_manager.F90 | 48 +++------- fms/fms.F90 | 3 +- fms2_io/fms_io_utils.F90 | 5 +- fms2_io/fms_netcdf_domain_io.F90 | 4 - fms2_io/fms_netcdf_unstructured_domain_io.F90 | 1 - fms2_io/include/domain_write.inc | 16 ++-- fms2_io/include/get_variable_attribute.inc | 1 - fms2_io/netcdf_io.F90 | 3 +- horiz_interp/horiz_interp_bicubic.F90 | 4 - horiz_interp/horiz_interp_bilinear.F90 | 2 +- horiz_interp/horiz_interp_spherical.F90 | 8 +- horiz_interp/horiz_interp_type.F90 | 6 +- interpolator/interpolator.F90 | 3 +- monin_obukhov/monin_obukhov.F90 | 2 +- mosaic/grid.F90 | 8 +- mosaic/mosaic.F90 | 16 ++-- mosaic2/grid2.F90 | 14 +-- mosaic2/mosaic2.F90 | 15 ++- mpp/include/mpp_chksum_int.h | 2 +- mpp/include/mpp_comm_mpi.inc | 20 +++- mpp/include/mpp_comm_nocomm.inc | 8 ++ mpp/include/mpp_define_nest_domains.inc | 35 ++----- mpp/include/mpp_do_get_boundary_ad.h | 3 +- mpp/include/mpp_do_global_field.h | 2 +- mpp/include/mpp_do_update.h | 1 - mpp/include/mpp_do_updateV_ad.h | 4 - mpp/include/mpp_do_updateV_nonblock.h | 4 +- mpp/include/mpp_do_update_ad.h | 4 - mpp/include/mpp_do_update_nest.h | 1 - mpp/include/mpp_do_update_nonblock.h | 9 +- mpp/include/mpp_domains_define.inc | 22 ++--- mpp/include/mpp_domains_misc.inc | 68 +------------- mpp/include/mpp_domains_reduce.inc | 24 +++++ mpp/include/mpp_domains_util.inc | 5 +- mpp/include/mpp_gather.h | 2 +- mpp/include/mpp_get_boundary.h | 9 +- mpp/include/mpp_get_boundary_ad.h | 9 +- mpp/include/mpp_global_field.h | 4 + mpp/include/mpp_global_field_ad.h | 3 + mpp/include/mpp_global_field_ug.h | 7 +- mpp/include/mpp_group_update.h | 8 +- mpp/include/mpp_transmit.inc | 12 +++ mpp/include/mpp_transmit_mpi.h | 1 - mpp/include/mpp_unstruct_domain.inc | 5 +- mpp/include/mpp_update_domains2D.h | 4 + mpp/include/mpp_util.inc | 35 ++----- mpp/include/mpp_util_mpi.inc | 10 +- mpp/include/system_clock.h | 6 +- mpp/mpp.F90 | 5 +- mpp/mpp_domains.F90 | 13 +-- mpp/mpp_efp.F90 | 6 +- mpp/mpp_parameter.F90 | 10 +- mpp/mpp_pset.F90 | 2 +- mpp/mpp_utilities.F90 | 6 +- random_numbers/random_numbers.F90 | 4 +- time_interp/time_interp.F90 | 18 ++-- time_interp/time_interp_external.F90 | 3 +- time_interp/time_interp_external2.F90 | 11 +-- time_manager/get_cal_time.F90 | 17 ++-- time_manager/time_manager.F90 | 31 +++---- topography/gaussian_topog.F90 | 1 - topography/topography.F90 | 1 - tracer_manager/tracer_manager.F90 | 9 +- 81 files changed, 309 insertions(+), 512 deletions(-) diff --git a/amip_interp/amip_interp.F90 b/amip_interp/amip_interp.F90 index 219c7d16a2..c7ac913d25 100644 --- a/amip_interp/amip_interp.F90 +++ b/amip_interp/amip_interp.F90 @@ -388,7 +388,6 @@ subroutine get_amip_sst (Time, Interp, sst, err_msg, lon_model, lat_model) type (time_type) :: Udate character(len=4) :: yyyy integer :: nrecords, ierr, k, yr, mo, dy - integer :: siz(4) integer, dimension(:), allocatable :: ryr, rmo, rdy character(len=30) :: time_unit real, dimension(:), allocatable :: timeval @@ -893,7 +892,7 @@ subroutine amip_interp_init() tice_crit_k = tice_crit if ( tice_crit_k < 200. ) tice_crit_k = tice_crit_k + TFREEZE - ice_crit = nint((tice_crit_k-TFREEZE)*100.) + ice_crit = nint((tice_crit_k-TFREEZE)*100., I2_KIND) ! ---- set up file dependent variable ---- ! ---- global file name ---- @@ -1283,7 +1282,6 @@ subroutine read_record (type, Date, Adate, dat) integer(I2_KIND) :: idat(mobs,nobs) integer :: nrecords, yr, mo, dy, ierr, k integer, dimension(:), allocatable :: ryr, rmo, rdy - character(len=38) :: mesg character(len=maxc) :: ncfilename, ncfieldname type(FmsNetcdfFile_t), pointer :: fileobj @@ -1359,7 +1357,7 @@ subroutine read_record (type, Date, Adate, dat) else call fms2_io_read_data(fileobj, ncfieldname, dat, unlim_dim_level=k) endif - idat = nint(dat) ! reconstruct packed data for reproducibility + idat = nint(dat, I2_KIND) ! reconstruct packed data for reproducibility !---- unpacking of data ---- @@ -1381,14 +1379,8 @@ subroutine read_record (type, Date, Adate, dat) endif endif - return -10 write (mesg, 20) unit - call error_mesg ('read_record in amip_interp_mod', mesg, FATAL) - -20 format ('end of file reading unit ',i2,' (sst data)') - end subroutine read_record !####################################################################### diff --git a/astronomy/astronomy.F90 b/astronomy/astronomy.F90 index e8366c3729..f0c40c6145 100644 --- a/astronomy/astronomy.F90 +++ b/astronomy/astronomy.F90 @@ -466,7 +466,7 @@ subroutine astronomy_init (latb, lonb) if (period == 0) then period_time_type = length_of_year() call get_time (period_time_type, seconds, days) - period = seconds_per_day*days + seconds + period = int(seconds_per_day*days + seconds) else period_time_type = set_time(period,0) endif @@ -533,7 +533,7 @@ subroutine get_period_integer (period_out) ! define length of year in seconds. !-------------------------------------------------------------------- call get_time (period_time_type, seconds, days) - period_out = seconds_per_day*days + seconds + period_out = int(seconds_per_day*days + seconds) end subroutine get_period_integer @@ -1753,7 +1753,7 @@ subroutine annual_mean_solar_2d (js, je, lat, cosz, solar, fracday, & !-------------------------------------------------------------------- real, dimension(size(lat,1),size(lat,2)) :: s,z real :: t - integer :: n, i + integer :: n !-------------------------------------------------------------------- ! if the calculation has not yet been done, do it here. diff --git a/axis_utils/axis_utils.F90 b/axis_utils/axis_utils.F90 index 0e5a2394d3..8f5a01022e 100644 --- a/axis_utils/axis_utils.F90 +++ b/axis_utils/axis_utils.F90 @@ -83,7 +83,7 @@ subroutine get_axis_cart(axis, cart) character(len=8) , dimension(4) :: z_units character(len=3) , dimension(6) :: t_units character(len=32) :: name - integer :: i,j + integer :: i lon_names = (/'lon','x '/) lat_names = (/'lat','y '/) @@ -533,7 +533,7 @@ subroutine interp_1d_linear(grid1,grid2,data1,data2) real, dimension(:), intent(in) :: grid1, data1, grid2 real, dimension(:), intent(inout) :: data2 - integer :: n1, n2, i, n, ext + integer :: n1, n2, i, n real :: w n1 = size(grid1(:)) @@ -690,8 +690,7 @@ subroutine interp_1d_2d(grid1,grid2,data1,data2) real, dimension(:,:), intent(in) :: grid1, data1, grid2 real, dimension(:,:), intent(inout) :: data2 - integer :: n1, n2, i, n, k2, ks, ke - real :: w + integer :: n1, n2, n, k2, ks, ke n1 = size(grid1,1) n2 = size(grid2,1) @@ -717,8 +716,8 @@ subroutine interp_1d_3d(grid1,grid2,data1,data2, method, yp1, yp2) character(len=*), optional, intent(in) :: method real, optional, intent(in) :: yp1, yp2 - integer :: n1, n2, m1, m2, k2, i, n, m - real :: w, y1, y2 + integer :: n1, n2, m1, m2, k2, n, m + real :: y1, y2 character(len=32) :: interp_method integer :: ks, ke n1 = size(grid1,1) diff --git a/axis_utils/axis_utils2.F90 b/axis_utils/axis_utils2.F90 index da6f3c9d2c..7ca2f26720 100644 --- a/axis_utils/axis_utils2.F90 +++ b/axis_utils/axis_utils2.F90 @@ -29,7 +29,6 @@ !> @addtogroup axis_utils2_mod !> @{ module axis_utils2_mod - use, intrinsic :: iso_fortran_env use mpp_mod, only: mpp_error, FATAL, stdout use fms_mod, only: lowercase, uppercase, string_array_index, fms_error_handler use fms2_io_mod, only: FmsNetcdfDomainFile_t, variable_att_exists, FmsNetcdfFile_t, & @@ -554,7 +553,7 @@ subroutine interp_1d_linear(grid1,grid2,data1,data2) real, dimension(:), intent(in) :: grid1, data1, grid2 real, dimension(:), intent(inout) :: data2 - integer :: n1, n2, i, n, ext + integer :: n1, n2, i, n real :: w n1 = size(grid1(:)) @@ -711,8 +710,7 @@ subroutine interp_1d_2d(grid1,grid2,data1,data2) real, dimension(:,:), intent(in) :: grid1, data1, grid2 real, dimension(:,:), intent(inout) :: data2 - integer :: n1, n2, i, n, k2, ks, ke - real :: w + integer :: n1, n2, n, k2, ks, ke n1 = size(grid1,1) n2 = size(grid2,1) @@ -738,8 +736,8 @@ subroutine interp_1d_3d(grid1,grid2,data1,data2, method, yp1, yp2) character(len=*), optional, intent(in) :: method real, optional, intent(in) :: yp1, yp2 - integer :: n1, n2, m1, m2, k2, i, n, m - real :: w, y1, y2 + integer :: n1, n2, m1, m2, k2, n, m + real :: y1, y2 character(len=32) :: interp_method integer :: ks, ke n1 = size(grid1,1) diff --git a/column_diagnostics/column_diagnostics.F90 b/column_diagnostics/column_diagnostics.F90 index b27ef724bf..fd4ced5ade 100644 --- a/column_diagnostics/column_diagnostics.F90 +++ b/column_diagnostics/column_diagnostics.F90 @@ -491,7 +491,7 @@ subroutine column_diagnostics_header & integer :: hour !< integers defining the current time integer :: minute !< integers defining the current time integer :: second !< integers defining the current time - character(len=8) :: mon !< character string for the current month + character(len=9) :: mon !< character string for the current month character(len=64) :: header !< title for the output !-------------------------------------------------------------------- diff --git a/constants/constants.F90 b/constants/constants.F90 index 008321a619..9cb6fa7dc8 100644 --- a/constants/constants.F90 +++ b/constants/constants.F90 @@ -61,8 +61,6 @@ module constants_mod ! by fms_init public :: version -real :: realnumber !< dummy variable to use in HUGE initializations - !! The small_fac parameter is used to alter the radius of the earth to allow one to !! examine non-hydrostatic effects without the need to run full-earth high-resolution !! simulations (<13km) that will tax hardware resources. diff --git a/coupler/coupler_types.F90 b/coupler/coupler_types.F90 index 6c1e878820..4ad50d1805 100644 --- a/coupler/coupler_types.F90 +++ b/coupler/coupler_types.F90 @@ -386,8 +386,6 @@ subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je,& character(len=*), parameter :: error_header =& & '==>Error from coupler_types_mod (coupler_type_copy_1d_2d):' - character(len=400) :: error_msg - integer :: m, n if (var_out%num_bcs > 0) then ! It is an error if the number of output fields exceeds zero, because it means this @@ -422,8 +420,6 @@ subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd,& character(len=*), parameter :: error_header =& & '==>Error from coupler_types_mod (coupler_type_copy_1d_3d):' - character(len=400) :: error_msg - integer :: m, n if (var_out%num_bcs > 0) then ! It is an error if the number of output fields exceeds zero, because it means this @@ -456,8 +452,6 @@ subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je,& character(len=*), parameter :: error_header =& & '==>Error from coupler_types_mod (coupler_type_copy_2d_2d):' - character(len=400) :: error_msg - integer :: m, n if (var_out%num_bcs > 0) then ! It is an error if the number of output fields exceeds zero, because it means this @@ -491,8 +485,6 @@ subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd,& character(len=*), parameter :: error_header =& & '==>Error from coupler_types_mod (coupler_type_copy_2d_3d):' - character(len=400) :: error_msg - integer :: m, n if (var_out%num_bcs > 0) then ! It is an error if the number of output fields exceeds zero, because it means this @@ -525,8 +517,6 @@ subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je,& character(len=*), parameter :: error_header =& & '==>Error from coupler_types_mod (coupler_type_copy_3d_2d):' - character(len=400) :: error_msg - integer :: m, n if (var_out%num_bcs > 0) then ! It is an error if the number of output fields exceeds zero, because it means this @@ -560,8 +550,6 @@ subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd,& character(len=*), parameter :: error_header =& & '==>Error from coupler_types_mod (coupler_type_copy_3d_3d):' - character(len=400) :: error_msg - integer :: m, n if (var_out%num_bcs > 0) then ! It is an error if the number of output fields exceeds zero, because it means this @@ -2376,7 +2364,7 @@ subroutine CT_extract_data_3d_2d(var_in, bc_index, field_index, k_in, array_out, character(len=400) :: error_msg real :: scale - integer :: i, j, k, halo, i_off, j_off + integer :: i, j, halo, i_off, j_off if (bc_index <= 0) then array_out(:,:) = 0.0 @@ -3543,7 +3531,7 @@ subroutine mpp_io_CT_register_restarts_3d(var, bc_rest_files, num_rest_files, mp character(len=80), dimension(max(1,var%num_bcs)) :: rest_file_names character(len=80) :: file_nm logical :: ocn_rest - integer :: f, n, m, id_restart + integer :: f, n, m ocn_rest = .true. if (present(ocean_restart)) ocn_rest = ocean_restart diff --git a/coupler/ensemble_manager.F90 b/coupler/ensemble_manager.F90 index 8f2a122600..7fc83f9a6d 100644 --- a/coupler/ensemble_manager.F90 +++ b/coupler/ensemble_manager.F90 @@ -77,7 +77,7 @@ module ensemble_manager_mod subroutine ensemble_manager_init() - integer :: i, io_status, ioun, npes, ierr + integer :: i, io_status, npes, ierr namelist /ensemble_nml/ ensemble_size diff --git a/data_override/data_override.F90 b/data_override/data_override.F90 index e6f9dcd575..436f474bff 100644 --- a/data_override/data_override.F90 +++ b/data_override/data_override.F90 @@ -230,7 +230,7 @@ subroutine data_override_init(Atm_domain_in, Ocean_domain_in, Ice_domain_in, Lan call write_version_number("DATA_OVERRIDE_MOD", version) ! Initialize user-provided data table - default_table%gridname = 'none' + default_table%gridname = 'non' default_table%fieldname_code = 'none' default_table%fieldname_file = 'none' default_table%file_name = 'none' @@ -686,8 +686,8 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde integer :: nxd, nyd, nxc, nyc, nwindows integer :: nwindows_x, ipos, jpos, window_size(2) integer :: istart, iend, jstart, jend - integer :: isw, iew, jsw, jew, n - integer :: omp_get_num_threads, omp_get_thread_num, thread_id, window_id + integer :: isw, iew, jsw, jew + integer :: omp_get_num_threads, window_id logical :: need_compute real :: lat_min, lat_max integer :: is_src, ie_src, js_src, je_src diff --git a/data_override/get_grid_version.F90 b/data_override/get_grid_version.F90 index 6c2dd6e93e..d9bf6edfc4 100644 --- a/data_override/get_grid_version.F90 +++ b/data_override/get_grid_version.F90 @@ -225,7 +225,6 @@ subroutine get_grid_version_2(fileobj, mod_name, domain, isc, iec, jsc, jec, lon integer :: isc2, iec2, jsc2, jec2 character(len=256) :: solo_mosaic_file, grid_file real, allocatable :: tmpx(:,:), tmpy(:,:) - type(domain2d) :: domain2 logical :: open_solo_mosaic type(FmsNetcdfFile_t) :: mosaicfileobj, tilefileobj integer :: start(2), nread(2) diff --git a/diag_integral/diag_integral.F90 b/diag_integral/diag_integral.F90 index 12a45e0a26..d8bc427cc2 100644 --- a/diag_integral/diag_integral.F90 +++ b/diag_integral/diag_integral.F90 @@ -1140,7 +1140,7 @@ subroutine write_field_averages (Time) rcount = real(field_count(i)) call mpp_sum (rcount) call mpp_sum (field_sum(i)) - icount = rcount + icount = int(rcount, i8_kind) !------------------------------------------------------------------------------- ! verify that all the data expected for an integral has been @@ -1150,7 +1150,7 @@ subroutine write_field_averages (Time) ('diag_integral_mod', & 'field_count equals zero for field_name ' // & field_name(i)(1:len_trim(field_name(i))), FATAL ) - kount = icount/field_size + kount = int(icount/field_size) if ((field_size)*kount /= icount) then print*,"name,pe,kount,field_size,icount,rcount=",trim(field_name(i)),mpp_pe(),kount,field_size,icount,rcount call error_mesg & diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90 index faf1c4909a..15d8f62801 100644 --- a/diag_manager/diag_axis.F90 +++ b/diag_manager/diag_axis.F90 @@ -869,7 +869,7 @@ SUBROUTINE diag_axis_attribute_init(diag_axis_id, name, type, cval, ival, rval) INTEGER, DIMENSION(:), INTENT(in), OPTIONAL :: ival !< Integer attribute value(s) REAL, DIMENSION(:), INTENT(in), OPTIONAL :: rval !< Real attribute value(s) - INTEGER :: istat, length, i, j, this_attribute, out_field + INTEGER :: istat, length, i, this_attribute CHARACTER(len=1024) :: err_msg IF ( .NOT.first_send_data_call ) THEN @@ -1051,9 +1051,6 @@ SUBROUTINE diag_axis_add_attribute_r1d(diag_axis_id, att_name, att_value) CHARACTER(len=*), INTENT(in) :: att_name REAL, DIMENSION(:), INTENT(in) :: att_value - INTEGER :: num_attributes, len - CHARACTER(len=512) :: err_msg - CALL diag_axis_attribute_init(diag_axis_id, att_name, NF90_FLOAT, rval=att_value) END SUBROUTINE diag_axis_add_attribute_r1d diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 08933eaa10..6cc20dbc48 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -418,11 +418,9 @@ INTEGER FUNCTION register_diag_field_array(module_name, field_name, axes, init_t CHARACTER(len=*), OPTIONAL, INTENT(in):: realm !< String to set as the value to the modeling_realm attribute INTEGER :: field, j, ind, file_num, freq - INTEGER :: i, cm_ind, cm_file_num INTEGER :: output_units INTEGER :: stdout_unit LOGICAL :: mask_variant1, verbose1 - LOGICAL :: cm_found CHARACTER(len=128) :: msg ! get stdout unit number @@ -3468,7 +3466,7 @@ SUBROUTINE closing_file(file, time) INTEGER, INTENT(in) :: file TYPE(time_type), INTENT(in) :: time - INTEGER :: j, i, input_num, freq, status, loop1, loop2 + INTEGER :: j, i, input_num, freq, status INTEGER :: stdout_unit LOGICAL :: reduced_k_range, need_compute, local_output CHARACTER(len=128) :: message @@ -3814,7 +3812,6 @@ SUBROUTINE diag_field_attribute_init(diag_field_id, name, type, cval, ival, rval REAL, DIMENSION(:), INTENT(in), OPTIONAL :: rval !< Real attribute value(s) INTEGER :: istat, length, i, j, this_attribute, out_field - CHARACTER(len=1024) :: err_msg IF ( .NOT.first_send_data_call ) THEN ! Call error due to unable to add attribute after send_data called @@ -3998,9 +3995,6 @@ SUBROUTINE diag_field_add_attribute_r1d(diag_field_id, att_name, att_value) CHARACTER(len=*), INTENT(in) :: att_name !< new attribute name REAL, DIMENSION(:), INTENT(in) :: att_value !< new attribute value - INTEGER :: num_attributes, len - CHARACTER(len=512) :: err_msg - CALL diag_field_attribute_init(diag_field_id, att_name, NF90_FLOAT, rval=att_value) END SUBROUTINE diag_field_add_attribute_r1d diff --git a/diag_manager/diag_output.F90 b/diag_manager/diag_output.F90 index afcfb5d46b..f7d9dd54ac 100644 --- a/diag_manager/diag_output.F90 +++ b/diag_manager/diag_output.F90 @@ -218,7 +218,7 @@ SUBROUTINE write_axis_meta_data(file_unit, axes, fileob, time_ops, time_axis_reg CHARACTER(len=1) :: axis_cart_name INTEGER :: axis_direction, axis_edges REAL, ALLOCATABLE :: axis_data(:) -integer :: domain_size, axis_length, axis_pos + integer :: axis_pos INTEGER :: num_attributes TYPE(diag_atttype), DIMENSION(:), ALLOCATABLE :: attributes INTEGER :: calendar, id_axis, id_time_axis @@ -231,8 +231,6 @@ SUBROUTINE write_axis_meta_data(file_unit, axes, fileob, time_ops, time_axis_reg integer :: istart, iend integer :: gstart, cstart, cend !< Start and end of global and compute domains integer :: clength !< Length of compute domain - integer :: data_size - integer, allocatable, dimension(:) :: all_indicies character(len=32) :: type_str !< Str indicating the type of the axis data ! Make sure err_msg is initialized @@ -477,16 +475,15 @@ FUNCTION write_field_meta_data ( file_unit, name, axes, units, long_name, range, logical :: is_time_bounds !< Flag indicating if the variable is time_bounds CHARACTER(len=256) :: standard_name2 - CHARACTER(len=1280) :: att_str TYPE(diag_fieldtype) :: Field LOGICAL :: coord_present - CHARACTER(len=40) :: aux_axes(SIZE(axes)) + CHARACTER(len=128) :: aux_axes(SIZE(axes)) CHARACTER(len=160) :: coord_att CHARACTER(len=1024) :: err_msg character(len=128),dimension(size(axes)) :: axis_names REAL :: scale, add - INTEGER :: i, indexx, num, ipack, np, att_len + INTEGER :: i, indexx, num, ipack, np LOGICAL :: use_range INTEGER :: axis_indices(SIZE(axes)) logical :: use_UGdomain_local @@ -770,8 +767,6 @@ END SUBROUTINE write_attribute_meta SUBROUTINE done_meta_data(file_unit) INTEGER, INTENT(in) :: file_unit !< Output file unit number - INTEGER :: i - !---- write data for all non-time axes ---- num_axis_in_file = 0 END SUBROUTINE done_meta_data diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 618702c30e..9b7f6f0f99 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -64,7 +64,6 @@ MODULE diag_util_mod USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, mpp_pe, mpp_root_pe, lowercase, fms_error_handler,& & write_version_number, do_cf_compliance USE fms_io_mod, ONLY: get_tile_string, return_domain, string - USE fms2_io_mod, ONLY: fms2_io_get_instance_filename => get_instance_filename USE mpp_domains_mod,ONLY: domain1d, domain2d, mpp_get_compute_domain, null_domain1d, null_domain2d,& & OPERATOR(.NE.), OPERATOR(.EQ.), mpp_modify_domain, mpp_get_domain_components,& & mpp_get_ntile_count, mpp_get_current_ntile, mpp_get_tile_id, mpp_mosaic_defined, mpp_get_tile_npes,& @@ -75,7 +74,7 @@ MODULE diag_util_mod USE mpp_mod, ONLY: mpp_npes USE fms_io_mod, ONLY: get_mosaic_tile_file_ug USE constants_mod, ONLY: SECONDS_PER_DAY, SECONDS_PER_HOUR, SECONDS_PER_MINUTE -use fms2_io_mod + USE fms2_io_mod, fms2_io_get_instance_filename => get_instance_filename #ifdef use_netCDF USE netcdf, ONLY: NF90_CHAR #endif @@ -1534,9 +1533,7 @@ SUBROUTINE opening_file(file, time, filename_time) INTEGER :: field_num1 INTEGER :: position INTEGER :: dir, edges - INTEGER :: ntileMe INTEGER :: year, month, day, hour, minute, second - INTEGER, ALLOCATABLE :: tile_id(:) INTEGER, DIMENSION(1) :: time_axis_id, time_bounds_id ! size of this axes array must be at least max num. of ! axes per field + 2; the last two elements are for time @@ -1544,7 +1541,6 @@ SUBROUTINE opening_file(file, time, filename_time) INTEGER, DIMENSION(6) :: axes INTEGER, ALLOCATABLE :: axesc(:) ! indices if compressed axes associated with the field LOGICAL :: time_ops, aux_present, match_aux_name, req_present, match_req_fields - CHARACTER(len=7) :: prefix CHARACTER(len=7) :: avg_name = 'average' CHARACTER(len=128) :: time_units, timeb_units, avg, error_string, filename, aux_name, req_fields, fieldname CHARACTER(len=128) :: suffix, base_name @@ -1555,7 +1551,6 @@ SUBROUTINE opening_file(file, time, filename_time) TYPE(domain2d) :: domain2 TYPE(domainUG) :: domainU INTEGER :: is, ie, last, ind - character(len=2) :: fnum_domain class(FmsNetcdfFile_t), pointer :: fileob integer :: actual_num_axes !< The actual number of axes to write including time @@ -2155,7 +2150,6 @@ SUBROUTINE diag_data_out(file, field, dat, time, final_call_in, static_write_in, type(time_type), intent(in), optional :: filename_time !< Time used in setting the filename when writting periodic files LOGICAL :: final_call, do_write, static_write - INTEGER :: i, num REAL :: dif, time_data(2, 1, 1, 1), dt_time(1, 1, 1, 1), start_dif, end_dif REAL :: time_in_file !< Time in file at the beginning of this call diff --git a/drifters/drifters.F90 b/drifters/drifters.F90 index 9051f71fa6..0ae40f6c82 100644 --- a/drifters/drifters.F90 +++ b/drifters/drifters.F90 @@ -108,7 +108,6 @@ module drifters_mod integer, parameter, private :: MAX_STR_LEN = 128 ! Include variable "version" to be written to log file. #include - real :: DRFT_EMPTY_ARRAY(0) !> @} !> @brief Holds all data needed for drifters communication, io, and input. diff --git a/exchange/stock_constants.F90 b/exchange/stock_constants.F90 index 31114c01ce..b9b9537402 100644 --- a/exchange/stock_constants.F90 +++ b/exchange/stock_constants.F90 @@ -172,7 +172,6 @@ end subroutine stocks_report_init subroutine stocks_report(Time) type(time_type) , intent(in) :: Time !< Model time - type(time_type) :: timeSinceStart type(stock_type) :: stck real, dimension(NCOMPS) :: f_value, f_ice_grid, f_ocn_grid, f_ocn_btf, q_start, q_now,c_value character(len=80) :: formatString diff --git a/exchange/xgrid.F90 b/exchange/xgrid.F90 index a3f96e5c85..685f9d2c97 100644 --- a/exchange/xgrid.F90 +++ b/exchange/xgrid.F90 @@ -140,8 +140,6 @@ module xgrid_mod public xmap_type, setup_xmap, set_frac_area, put_to_xgrid, get_from_xgrid, & xgrid_count, some, conservation_check, xgrid_init, & -! AREA_ATM_SPHERE, AREA_LND_SPHERE, AREA_OCN_SPHERE, & -! AREA_ATM_MODEL, AREA_LND_MODEL, AREA_OCN_MODEL, & AREA_ATM_SPHERE, AREA_OCN_SPHERE, & AREA_ATM_MODEL, AREA_OCN_MODEL, & get_ocean_model_area_elements, grid_box_type, & @@ -158,7 +156,6 @@ module xgrid_mod logical :: make_exchange_reproduce = .false. !< Set to .true. to make xgrid_mod reproduce answers on different !! numbers of PEs. This option has a considerable performance impact. !< exactly same on different # PEs -logical :: xgrid_log = .false. character(len=64) :: interp_method = 'first_order' !< Exchange grid interpolation method. !! It has two options: "first_order", "second_order". logical :: debug_stocks = .false. @@ -180,7 +177,6 @@ module xgrid_mod monotonic_exchange, nsubset, do_alltoall, do_alltoallv, & use_mpp_io -logical :: init = .true. integer :: remapping_method !> Area elements used inside each model @@ -464,8 +460,8 @@ module xgrid_mod ! Include variable "version" to be written to log file. #include - real(r8_kind), parameter :: EPS = 1.0d-10 - real(r8_kind), parameter :: LARGE_NUMBER = 1.d20 + real(r8_kind), parameter :: EPS = 1.0e-10_r8_kind + real(r8_kind), parameter :: LARGE_NUMBER = 1.e20_r8_kind logical :: module_is_initialized = .FALSE. integer :: id_put_1_to_xgrid_order_1 = 0 integer :: id_put_1_to_xgrid_order_2 = 0 @@ -622,7 +618,7 @@ subroutine load_xgrid (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, u real(r8_kind), allocatable, dimension(:,:) :: tmp real(r8_kind), allocatable, dimension(:) :: send_buffer, recv_buffer type (grid_type), pointer, save :: grid1 =>NULL() - integer :: l, ll, ll_repro, p, siz(4), nxgrid, size_prev + integer :: l, ll, ll_repro, p, nxgrid, size_prev type(xcell_type), allocatable :: x_local(:) integer :: size_repro, out_unit logical :: scale_exist = .false. @@ -631,7 +627,7 @@ subroutine load_xgrid (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, u real(r8_kind) :: garea integer :: npes, isc, iec, nxgrid_local, pe, nxgrid_local_orig integer :: nxgrid1, nxgrid2, nset1, nset2, ndivs, cur_ind - integer :: pos, nsend, nrecv, l1, l2, n, mypos, m + integer :: pos, nsend, nrecv, l1, l2, n, mypos integer :: start(4), nread(4) logical :: found character(len=128) :: attvalue @@ -741,13 +737,13 @@ subroutine load_xgrid (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, u start(1) = isc; nread(1) = nxgrid_local allocate(tmp(nxgrid_local,1)) call read_data(fileobj, 'I_'//grid1_id//'_'//grid1_id//'x'//grid_id, tmp, corner=start, edge_lengths=nread) - i1_tmp = tmp(:,1) + i1_tmp = int(tmp(:,1)) call read_data(fileobj, 'J_'//grid1_id//'_'//grid1_id//'x'//grid_id, tmp, corner=start, edge_lengths=nread) - j1_tmp = tmp(:,1) + j1_tmp = int(tmp(:,1)) call read_data(fileobj, 'I_'//grid_id//'_'//grid1_id//'x'//grid_id, tmp, corner=start, edge_lengths=nread) - i2_tmp = tmp(:,1) + i2_tmp = int(tmp(:,1)) call read_data(fileobj, 'J_'//grid_id//'_'//grid1_id//'x'//grid_id, tmp, corner=start, edge_lengths=nread) - j2_tmp = tmp(:,1) + j2_tmp = int(tmp(:,1)) call read_data(fileobj, 'AREA_'//grid1_id//'x'//grid_id, tmp, corner=start, edge_lengths=nread) area_tmp = tmp(:,1) if(use_higher_order) then @@ -761,11 +757,11 @@ subroutine load_xgrid (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, u nread(1) = 2; start(2) = isc; nread(2) = nxgrid_local allocate(tmp(2, isc:iec)) call read_data(fileobj, "tile1_cell", tmp, corner=start, edge_lengths=nread) - i1_tmp(isc:iec) = tmp(1, isc:iec) - j1_tmp(isc:iec) = tmp(2, isc:iec) + i1_tmp(isc:iec) = int(tmp(1, isc:iec)) + j1_tmp(isc:iec) = int(tmp(2, isc:iec)) call read_data(fileobj, "tile2_cell", tmp, corner=start, edge_lengths=nread) - i2_tmp(isc:iec) = tmp(1, isc:iec) - j2_tmp(isc:iec) = tmp(2, isc:iec) + i2_tmp(isc:iec) = int(tmp(1, isc:iec)) + j2_tmp(isc:iec) = int(tmp(2, isc:iec)) if(use_higher_order) then call read_data(fileobj, "tile1_distance", tmp, corner=start, edge_lengths=nread) di_tmp(isc:iec) = tmp(1, isc:iec) @@ -1012,10 +1008,10 @@ subroutine load_xgrid (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, u do p = 0,npes-1 do n = 1, nrecv2(p) l2 = l2+1 - i1(l2) = recv_buffer(pos+1) - j1(l2) = recv_buffer(pos+2) - i2(l2) = recv_buffer(pos+3) - j2(l2) = recv_buffer(pos+4) + i1(l2) = int(recv_buffer(pos+1)) + j1(l2) = int(recv_buffer(pos+2)) + i2(l2) = int(recv_buffer(pos+3)) + j2(l2) = int(recv_buffer(pos+4)) area(l2) = recv_buffer(pos+5) if(use_higher_order) then di(l2) = recv_buffer(pos+6) @@ -1026,10 +1022,10 @@ subroutine load_xgrid (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, u enddo do n = 1, nrecv1(p) l1 = l1+1 - i1_side1(l1) = recv_buffer(pos+1) - j1_side1(l1) = recv_buffer(pos+2) - i2_side1(l1) = recv_buffer(pos+3) - j2_side1(l1) = recv_buffer(pos+4) + i1_side1(l1) = int(recv_buffer(pos+1)) + j1_side1(l1) = int(recv_buffer(pos+2)) + i2_side1(l1) = int(recv_buffer(pos+3)) + j2_side1(l1) = int(recv_buffer(pos+4)) area_side1(l1) = recv_buffer(pos+5) if(use_higher_order) then di_side1(l1) = recv_buffer(pos+6) @@ -1313,10 +1309,8 @@ subroutine get_grid_version1(grid, grid_id, grid_file) real(r8_kind), dimension(grid%im) :: lonb real(r8_kind), dimension(grid%jm) :: latb - real(r8_kind), allocatable :: tmpx(:,:), tmpy(:,:) real(r8_kind) :: d2r - integer :: is, ie, js, je, nlon, nlat, i, j - integer :: start(4), nread(4), isc2, iec2, jsc2, jec2 + integer :: is, ie, js, je type(FmsNetcdfDomainFile_t) :: fileobj d2r = PI/180.0 @@ -1380,14 +1374,11 @@ subroutine get_grid_version2(grid, grid_id, grid_file) character(len=3), intent(in) :: grid_id character(len=*), intent(in) :: grid_file - real(r8_kind), dimension(grid%im) :: lonb - real(r8_kind), dimension(grid%jm) :: latb real(r8_kind), allocatable :: tmpx(:,:), tmpy(:,:) real(r8_kind) :: d2r integer :: is, ie, js, je, nlon, nlat, i, j integer :: start(4), nread(4), isc2, iec2, jsc2, jec2 type(FmsNetcdfFile_t) :: fileobj - real(r8_kind), allocatable, target :: geolon(:,:), geolat(:,:) if(.not. open_file(fileobj, grid_file, 'read') ) then call error_mesg('xgrid_mod(get_grid_version2)', 'Error in opening file '//trim(grid_file), FATAL) @@ -1527,7 +1518,7 @@ subroutine setup_xmap(xmap, grid_ids, grid_domains, grid_file, atm_grid, lnd_ug_ type(domainUG), optional, intent(in ) :: lnd_ug_domain integer :: g, p, i - integer :: unit, nxgrid_file, i1, i2, i3, tile1, tile2, j + integer :: nxgrid_file, i1, i2, i3, tile1, tile2, j integer :: nxc, nyc, out_unit type (grid_type), pointer, save :: grid =>NULL(), grid1 =>NULL() real(r8_kind), dimension(3) :: xxx @@ -2163,7 +2154,7 @@ end function get_nest_contact_fms2_io subroutine set_comm_get1_repro(xmap) type (xmap_type), intent(inout) :: xmap integer, dimension(xmap%npes) :: pe_ind, cnt - integer, dimension(0:xmap%npes-1) :: send_ind, recv_ind, pl + integer, dimension(0:xmap%npes-1) :: send_ind, pl integer :: npes, nsend, nrecv, mypos integer :: m, p, pos, n, g, l, im, i, j type(comm_type), pointer, save :: comm => NULL() @@ -2510,11 +2501,11 @@ subroutine set_comm_get1(xmap) endif if(grid1%is_ug) then do n = 1, recv_size(p) - i = recv_buf(buffer_pos+1) - j = recv_buf(buffer_pos+2) + i = int(recv_buf(buffer_pos+1)) + j = int(recv_buf(buffer_pos+2)) comm%recv(pos)%i(n) = grid1%l_index((j-1)*grid1%im+i) comm%recv(pos)%j(n) = 1 - comm%recv(pos)%tile(n) = recv_buf(buffer_pos+3) + comm%recv(pos)%tile(n) = int(recv_buf(buffer_pos+3)) if(monotonic_exchange) then comm%recv(pos)%di(n) = recv_buf(buffer_pos+4) comm%recv(pos)%dj(n) = recv_buf(buffer_pos+5) @@ -2523,9 +2514,9 @@ subroutine set_comm_get1(xmap) enddo else do n = 1, recv_size(p) - comm%recv(pos)%i(n) = recv_buf(buffer_pos+1) - grid1%is_me + 1 - comm%recv(pos)%j(n) = recv_buf(buffer_pos+2) - grid1%js_me + 1 - comm%recv(pos)%tile(n) = recv_buf(buffer_pos+3) + comm%recv(pos)%i(n) = int(recv_buf(buffer_pos+1) )- grid1%is_me + 1 + comm%recv(pos)%j(n) = int(recv_buf(buffer_pos+2) )- grid1%js_me + 1 + comm%recv(pos)%tile(n) = int(recv_buf(buffer_pos+3)) if(monotonic_exchange) then comm%recv(pos)%di(n) = recv_buf(buffer_pos+4) comm%recv(pos)%dj(n) = recv_buf(buffer_pos+5) @@ -2577,7 +2568,6 @@ subroutine set_comm_put1(xmap) real(r8_kind), allocatable :: diarray(:), djarray(:) integer, allocatable :: iarray(:), jarray(:), tarray(:) integer, allocatable :: pos_x(:), pelist(:), size_pe(:), pe_put1(:) - integer :: root_pe, recvsize, sendsize integer :: recv_buffer_pos(0:xmap%npes) type(comm_type), pointer, save :: comm => NULL() @@ -2827,9 +2817,9 @@ subroutine set_comm_put1(xmap) allocate(comm%send(pos)%dj(recv_size(p))) endif do n = 1, recv_size(p) - comm%send(pos)%i(n) = recv_buf(buffer_pos+1) - grid1%is_me + 1 - comm%send(pos)%j(n) = recv_buf(buffer_pos+2) - grid1%js_me + 1 - comm%send(pos)%tile(n) = recv_buf(buffer_pos+3) + comm%send(pos)%i(n) = int(recv_buf(buffer_pos+1) )- grid1%is_me + 1 + comm%send(pos)%j(n) = int(recv_buf(buffer_pos+2) )- grid1%js_me + 1 + comm%send(pos)%tile(n) = int(recv_buf(buffer_pos+3)) if(monotonic_exchange) then comm%send(pos)%di(n) = recv_buf(buffer_pos+4) comm%send(pos)%dj(n) = recv_buf(buffer_pos+5) @@ -3272,6 +3262,7 @@ subroutine get_side1_from_xgrid(d, grid_id, x, xmap, complete) integer(i8_kind), dimension(MAX_FIELDS), save :: d_addrs=-9999 integer(i8_kind), dimension(MAX_FIELDS), save :: x_addrs=-9999 + d = 0. if (grid_id==xmap%grids(1)%id) then is_complete = .true. if(present(complete)) is_complete=complete @@ -3538,8 +3529,8 @@ subroutine put_1_to_xgrid_order_2(d_addrs, x_addrs, xmap, isize, jsize, xsize, l real(r8_kind), dimension(isize, jsize, lsize) :: d_bar_max, d_bar_min real(r8_kind), dimension(isize, jsize, lsize) :: d_max, d_min real(r8_kind) :: d_bar - integer :: i, is, ie, im, j, js, je, jm, ii, jj - integer :: p, l, ioff, joff, isd, jsd + integer :: i, is, ie, j, js, je, ii, jj + integer :: p, l, isd, jsd type (grid_type), pointer, save :: grid1 =>NULL() type (comm_type), pointer, save :: comm =>NULL() integer :: buffer_pos, msgsize, from_pe, to_pe, pos, n @@ -3780,7 +3771,6 @@ subroutine get_1_from_xgrid(d_addrs, x_addrs, xmap, isize, jsize, xsize, lsize) type(overlap_type), pointer, save :: recv => NULL() real(r8_kind) :: recv_buffer(xmap%get1%recvsize*lsize*3) real(r8_kind) :: send_buffer(xmap%get1%sendsize*lsize*3) - real(r8_kind) :: unpack_buffer(xmap%get1%recvsize*3) real(r8_kind) :: d(isize,jsize) real(r8_kind), dimension(xsize) :: x pointer(ptr_d, d) @@ -3902,7 +3892,7 @@ subroutine get_1_from_xgrid_repro(d_addrs, x_addrs, xmap, xsize, lsize) type (xmap_type), intent(inout) :: xmap integer, intent(in) :: xsize, lsize - integer :: g, i, j, k, p, l, n, l2, m, l3 + integer :: g, i, j, k, p, l, n, l2, l3 integer :: msgsize, buffer_pos, pos type (grid_type), pointer, save :: grid =>NULL() type(comm_type), pointer, save :: comm => NULL() @@ -4664,13 +4654,13 @@ subroutine stock_print(stck, Time, comp_name, index, ref_value, radius, pelist) DiagID=f_valueDiagID(index,compInd) diagField = f_value - if (DiagID > 0) used = send_data(DiagID, diagField, Time) + if (DiagID > 0) used = send_data(DiagID, diagField, Time = Time) DiagID=c_valueDiagID(index,compInd) diagField = c_value if (DiagID > 0) used = send_data(DiagID, diagField, Time) DiagID=fmc_valueDiagID(index,compInd) diagField = f_value-c_value - if (DiagID > 0) used = send_data(DiagID, diagField, Time) + if (DiagID > 0) used = send_data(DiagID, diagField, Time=Time) call get_time(Time, isec, iday) @@ -4752,6 +4742,7 @@ subroutine get_side1_from_xgrid_ug(d, grid_id, x, xmap, complete) integer(i8_kind), dimension(MAX_FIELDS), save :: d_addrs=-9999 integer(i8_kind), dimension(MAX_FIELDS), save :: x_addrs=-9999 + d = 0. if (grid_id==xmap%grids(1)%id) then is_complete = .true. if(present(complete)) is_complete=complete @@ -4954,7 +4945,7 @@ subroutine put_1_to_xgrid_ug_order_1(d_addrs, x_addrs, xmap, dsize, xsize, lsize type (xmap_type), intent(inout) :: xmap integer, intent(in) :: dsize, xsize, lsize - integer :: i, j, p, buffer_pos, msgsize + integer :: i, p, buffer_pos, msgsize integer :: from_pe, to_pe, pos, n, l, count integer :: ibegin, istart, iend, start_pos type (comm_type), pointer, save :: comm =>NULL() @@ -5070,7 +5061,6 @@ subroutine get_1_from_xgrid_ug(d_addrs, x_addrs, xmap, isize, xsize, lsize) type(overlap_type), pointer, save :: recv => NULL() real(r8_kind) :: recv_buffer(xmap%get1%recvsize*lsize*3) real(r8_kind) :: send_buffer(xmap%get1%sendsize*lsize*3) - real(r8_kind) :: unpack_buffer(xmap%get1%recvsize*3) real(r8_kind) :: d(isize) real(r8_kind), dimension(xsize) :: x pointer(ptr_d, d) @@ -5190,7 +5180,7 @@ subroutine get_1_from_xgrid_ug_repro(d_addrs, x_addrs, xmap, xsize, lsize) type (xmap_type), intent(inout) :: xmap integer, intent(in) :: xsize, lsize - integer :: g, i, j, k, p, l, n, l2, m, l3 + integer :: g, i, j, k, p, l, n, l2, l3 integer :: msgsize, buffer_pos, pos type (grid_type), pointer, save :: grid =>NULL() type(comm_type), pointer, save :: comm => NULL() diff --git a/field_manager/field_manager.F90 b/field_manager/field_manager.F90 index 141d85cd8f..d3c847356e 100644 --- a/field_manager/field_manager.F90 +++ b/field_manager/field_manager.F90 @@ -603,12 +603,12 @@ subroutine field_manager_init(nfields, table_name) ! local variables !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ character(len=1024) :: record -character(len=fm_path_name_len) :: control_str +character(len=fm_string_len) :: control_str character(len=fm_path_name_len) :: list_name -character(len=fm_path_name_len) :: method_name -character(len=fm_path_name_len) :: name_str -character(len=fm_path_name_len) :: type_str -character(len=fm_path_name_len) :: val_name +character(len=fm_string_len) :: method_name +character(len=fm_string_len) :: name_str +character(len=fm_string_len) :: type_str +character(len=fm_string_len) :: val_name character(len=fm_string_len) :: tbl_name integer :: control_array(MAX_FIELDS,3) integer :: endcont @@ -1076,7 +1076,6 @@ subroutine new_name ( list_name, method_name_in , val_name_in) ! local variables !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ character(len=fm_string_len) :: method_name -character(len=fm_string_len) :: val_list character(len=fm_string_len) :: val_name integer, dimension(MAX_FIELDS) :: end_val integer, dimension(MAX_FIELDS) :: start_val @@ -1378,11 +1377,6 @@ function find_field_index_new(field_name) character(len=*), intent(in) :: field_name !< The path to the name of the field that an index is !! being requested for. -!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -! local parameters -!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -integer :: i - find_field_index_new = NO_FIELD find_field_index_new = fm_get_index(field_name) @@ -1482,13 +1476,6 @@ subroutine get_field_methods(n,methods) character(len=17), parameter :: sub_name = 'get_field_methods' character(len=64), parameter :: error_header = '==>Error from ' // trim(module_name) // & '(' // trim(sub_name) // '): ' - -!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -! local variables -!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -character(len=fm_path_name_len), dimension(size(methods(:))) :: control -character(len=fm_path_name_len), dimension(size(methods(:))) :: method -logical :: found_methods ! ! The field index is invalid because it is less than 1 or greater than the ! number of fields. @@ -1618,7 +1605,6 @@ function create_field(parent_p, name) & '(' // trim(sub_name) // '): ' character(len=64), parameter :: warn_header = '==>Warning from ' // trim(module_name) // & '(' // trim(sub_name) // '): ' -integer :: ier !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ ! local variables !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ @@ -3195,7 +3181,7 @@ function fm_intersection(lists, dim) & integer :: count integer :: error integer :: index -integer :: n, ier +integer :: n integer :: shortest logical :: found type (field_def), pointer, save :: temp_p @@ -3363,8 +3349,7 @@ function fm_loop_over_list_old(list, name, field_type, index) & !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ ! local variables !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -type (field_def), pointer, save :: temp_list_p - integer :: out_unit +integer :: out_unit out_unit = stdout() ! @@ -3627,7 +3612,7 @@ function fm_new_value_integer(name, value, create, index, append) & ! local variables !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ logical :: create_t -integer :: i, ier +integer :: i integer :: index_t integer, pointer, dimension(:) :: temp_i_value character(len=fm_path_name_len) :: path @@ -3864,7 +3849,7 @@ function fm_new_value_logical(name, value, create, index, append) & !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ character(len=fm_path_name_len) :: path character(len=fm_field_name_len) :: base -integer :: i, ier +integer :: i integer :: index_t logical :: create_t logical, dimension(:), pointer :: temp_l_value @@ -4100,7 +4085,7 @@ function fm_new_value_real(name, value, create, index, append) & !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ logical :: create_t -integer :: i, ier +integer :: i integer :: index_t real, pointer, dimension(:) :: temp_r_value character(len=fm_path_name_len) :: path @@ -4337,7 +4322,7 @@ function fm_new_value_string(name, value, create, index, append) & character(len=fm_string_len), dimension(:), pointer :: temp_s_value character(len=fm_path_name_len) :: path character(len=fm_field_name_len) :: base -integer :: i, ier +integer :: i integer :: index_t logical :: create_t type (field_def), save, pointer :: temp_list_p @@ -4709,13 +4694,6 @@ end function fm_modify_name !} !! all fields and reset the field tree to only the root field. subroutine initialize !{ ! -! arguments -! -!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -! local variables -!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -integer :: ier -! ! Initialize the root field ! if (.not. module_is_initialized) then !{ @@ -4782,7 +4760,6 @@ function make_list(this_list_p, name) & !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ ! local variables !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ -integer :: ier type (field_def), pointer, save :: dummy_p integer :: out_unit @@ -5265,10 +5242,7 @@ recursive function find_method(list_p, recursive, num_meth, method, control) & ! local variables !+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ character(len=fm_path_name_len) :: scratch -integer :: depthp1 -integer :: first integer :: i -integer :: last integer :: n type (field_def), pointer, save :: this_field_p integer :: out_unit diff --git a/fms/fms.F90 b/fms/fms.F90 index 98e3379ae0..b9e245d525 100644 --- a/fms/fms.F90 +++ b/fms/fms.F90 @@ -358,7 +358,7 @@ subroutine fms_init (localcomm, alt_input_nml_path) integer, intent(in), optional :: localcomm character(len=*), intent(in), optional :: alt_input_nml_path - integer :: unit, ierr, io + integer :: ierr, io integer :: logunitnum integer :: stdout_unit !< Unit number for the stdout file @@ -840,7 +840,6 @@ function cpointer_fortran_conversion (cstring) result(fstring) character(len=:), allocatable :: fstring !< The fortran string returned character(len=:,kind=c_char), pointer :: string_buffer !< A temporary pointer to between C and Fortran integer(c_size_t) :: length !< The string length - integer :: i length = c_strlen(cstring) allocate (character(len=length, kind=c_char) :: string_buffer) diff --git a/fms2_io/fms_io_utils.F90 b/fms2_io/fms_io_utils.F90 index 5d8898c3af..db664ccb44 100644 --- a/fms2_io/fms_io_utils.F90 +++ b/fms2_io/fms_io_utils.F90 @@ -600,7 +600,7 @@ subroutine parse_mask_table_2d(mask_table, maskmap, modelname) maskmap(mask_list(n,1),mask_list(n,2)) = .false. enddo - deallocate(mask_list) + deallocate(mask_list, mask_table_contents) end subroutine parse_mask_table_2d @@ -703,8 +703,7 @@ subroutine parse_mask_table_3d(mask_table, maskmap, modelname) do n = 1, nmask maskmap(mask_list(n,1),mask_list(n,2),mask_list(n,3)) = .false. enddo - - deallocate(mask_list) + deallocate(mask_list, mask_table_contents) end subroutine parse_mask_table_3d !> @brief Determine tile_file for structured grid based on filename and current diff --git a/fms2_io/fms_netcdf_domain_io.F90 b/fms2_io/fms_netcdf_domain_io.F90 index b15abbd5eb..2ddf347aa8 100644 --- a/fms2_io/fms_netcdf_domain_io.F90 +++ b/fms2_io/fms_netcdf_domain_io.F90 @@ -26,7 +26,6 @@ !> @addtogroup fms_netcdf_domain_io_mod !> @{ module fms_netcdf_domain_io_mod -use, intrinsic :: iso_fortran_env use netcdf use mpp_mod use mpp_domains_mod @@ -309,10 +308,7 @@ function is_dimension_registered(fileobj, dimension_name) & ! local logical :: is_registered - integer :: dpos - integer :: ndims - character(len=nf90_max_name), dimension(:), allocatable :: dim_names dpos = 0 is_registered = .false. diff --git a/fms2_io/fms_netcdf_unstructured_domain_io.F90 b/fms2_io/fms_netcdf_unstructured_domain_io.F90 index fe52b3c953..fc6d766e81 100644 --- a/fms2_io/fms_netcdf_unstructured_domain_io.F90 +++ b/fms2_io/fms_netcdf_unstructured_domain_io.F90 @@ -26,7 +26,6 @@ !> @brief File for @ref fms_netcdf_unstructured_domain_io_mod module fms_netcdf_unstructured_domain_io_mod -use,intrinsic :: iso_fortran_env use netcdf use mpp_domains_mod use fms_io_utils_mod diff --git a/fms2_io/include/domain_write.inc b/fms2_io/include/domain_write.inc index 72be263ab4..731794286f 100644 --- a/fms2_io/include/domain_write.inc +++ b/fms2_io/include/domain_write.inc @@ -125,8 +125,8 @@ subroutine domain_write_2d(fileobj, variable_name, vdata, unlim_dim_level, & integer :: ydim_index integer :: ypos integer :: yc_size - real(kind=i4_kind) :: fill_i4_kind !< Fill value of a i4_kind variable - real(kind=i8_kind) :: fill_i8_kind !< Fill value of a i8_kind variable + integer(kind=i4_kind) :: fill_i4_kind !< Fill value of a i4_kind variable + integer(kind=i8_kind) :: fill_i8_kind !< Fill value of a i8_kind variable real(kind=r4_kind) :: fill_r4_kind !< Fill value of a r4_kind variable real(kind=r8_kind) :: fill_r8_kind !< Fill value of a r8_kind variable integer :: xgmax !< Ending x index of the global io domain @@ -419,8 +419,8 @@ subroutine domain_write_3d(fileobj, variable_name, vdata, unlim_dim_level, & integer :: ydim_index integer :: ypos integer :: yc_size - real(kind=i4_kind) :: fill_i4_kind !< Fill value of a i4_kind variable - real(kind=i8_kind) :: fill_i8_kind !< Fill value of a i8_kind variable + integer(kind=i4_kind) :: fill_i4_kind !< Fill value of a i4_kind variable + integer(kind=i8_kind) :: fill_i8_kind !< Fill value of a i8_kind variable real(kind=r4_kind) :: fill_r4_kind !< Fill value of a r4_kind variable real(kind=r8_kind) :: fill_r8_kind !< Fill value of a r8_kind variable integer :: xgmax !< Ending x index of the global io domain @@ -713,8 +713,8 @@ subroutine domain_write_4d(fileobj, variable_name, vdata, unlim_dim_level, & integer :: ydim_index integer :: ypos integer :: yc_size - real(kind=i4_kind) :: fill_i4_kind !< Fill value of a i4_kind variable - real(kind=i8_kind) :: fill_i8_kind !< Fill value of a i8_kind variable + integer(kind=i4_kind) :: fill_i4_kind !< Fill value of a i4_kind variable + integer(kind=i8_kind) :: fill_i8_kind !< Fill value of a i8_kind variable real(kind=r4_kind) :: fill_r4_kind !< Fill value of a r4_kind variable real(kind=r8_kind) :: fill_r8_kind !< Fill value of a r8_kind variable integer :: xgmax !< Ending x index of the global io domain @@ -1007,8 +1007,8 @@ subroutine domain_write_5d(fileobj, variable_name, vdata, unlim_dim_level, & integer :: ydim_index integer :: ypos integer :: yc_size - real(kind=i4_kind) :: fill_i4_kind !< Fill value of a i4_kind variable - real(kind=i8_kind) :: fill_i8_kind !< Fill value of a i8_kind variable + integer(kind=i4_kind) :: fill_i4_kind !< Fill value of a i4_kind variable + integer(kind=i8_kind) :: fill_i8_kind !< Fill value of a i8_kind variable real(kind=r4_kind) :: fill_r4_kind !< Fill value of a r4_kind variable real(kind=r8_kind) :: fill_r8_kind !< Fill value of a r8_kind variable integer :: xgmax !< Ending x index of the global io domain diff --git a/fms2_io/include/get_variable_attribute.inc b/fms2_io/include/get_variable_attribute.inc index c1fc5a2e47..5f5af0c150 100644 --- a/fms2_io/include/get_variable_attribute.inc +++ b/fms2_io/include/get_variable_attribute.inc @@ -40,7 +40,6 @@ subroutine get_variable_attribute_0d(fileobj, variable_name, attribute_name, & integer :: varid integer :: err character(len=200) :: append_error_msg !< Msg to be appended to FATAL error message - integer :: j character(len=1024), dimension(1) :: charbuf !< 1D Character buffer logical :: reproduce_null_char_bug !< Local flag indicating to reproduce the mpp_io bug where !! the null characters were not removed after reading a string attribute diff --git a/fms2_io/netcdf_io.F90 b/fms2_io/netcdf_io.F90 index 5a33f151d9..15bcfeeb5b 100644 --- a/fms2_io/netcdf_io.F90 +++ b/fms2_io/netcdf_io.F90 @@ -28,7 +28,6 @@ !> @addtogroup netcdf_io_mod !> @{ module netcdf_io_mod -use, intrinsic :: iso_fortran_env use netcdf use mpp_mod use fms_io_utils_mod @@ -2193,11 +2192,13 @@ subroutine read_restart_bc(fileobj, unlim_dim_level, ignore_checksum) call scatter_data_bc (fileobj, fileobj%restart_vars(i)%varname, & fileobj%restart_vars(i)%data2d, & fileobj%restart_vars(i)%bc_info, & + unlim_dim_level = unlim_dim_level, & ignore_checksum=ignore_checksum) else if (associated(fileobj%restart_vars(i)%data3d)) then call scatter_data_bc (fileobj, fileobj%restart_vars(i)%varname, & fileobj%restart_vars(i)%data3d, & fileobj%restart_vars(i)%bc_info, & + unlim_dim_level = unlim_dim_level, & ignore_checksum=ignore_checksum) endif end do diff --git a/horiz_interp/horiz_interp_bicubic.F90 b/horiz_interp/horiz_interp_bicubic.F90 index 8df62ddeab..4c68c2baea 100644 --- a/horiz_interp/horiz_interp_bicubic.F90 +++ b/horiz_interp/horiz_interp_bicubic.F90 @@ -90,10 +90,6 @@ module horiz_interp_bicubic_mod ! dff_xy : x-y-derivative of fc at the fine grid - logical :: initialized_bicubic = .false. - - - real, save :: missing = -1e33 real :: tpi interface fill_xy diff --git a/horiz_interp/horiz_interp_bilinear.F90 b/horiz_interp/horiz_interp_bilinear.F90 index 520753b85d..734dc84ed0 100644 --- a/horiz_interp/horiz_interp_bilinear.F90 +++ b/horiz_interp/horiz_interp_bilinear.F90 @@ -1275,7 +1275,7 @@ function indp (value, array) ' when searching for nearest element to value=',value write (unit,*) ' array(i) < array(i-1) for i=',i write (unit,*) ' array(i) for i=1..ia follows:' - call abort() + call mpp_error() endif enddo if (value .lt. array(1) .or. value .gt. array(ia)) then diff --git a/horiz_interp/horiz_interp_spherical.F90 b/horiz_interp/horiz_interp_spherical.F90 index fe16e58715..29fb519f1d 100644 --- a/horiz_interp/horiz_interp_spherical.F90 +++ b/horiz_interp/horiz_interp_spherical.F90 @@ -82,7 +82,7 @@ module horiz_interp_spherical_mod !> Initializes module and writes version number to logfile.out subroutine horiz_interp_spherical_init - integer :: unit, ierr, io + integer :: ierr, io if(module_is_initialized) return @@ -425,8 +425,8 @@ subroutine horiz_interp_spherical_wght( Interp, wt, verbose, mask_in, mask_out, real, dimension(Interp%nlon_src, Interp%nlat_src) :: mask_src real, dimension(Interp%nlon_dst, Interp%nlat_dst) :: mask_dst integer :: nlon_in, nlat_in, nlon_out, nlat_out, num_found - integer :: m, n, i, j, k, miss_in, miss_out, i1, i2, j1, j2, iverbose - real :: min_in, max_in, avg_in, min_out, max_out, avg_out, sum + integer :: m, n, k, i1, i2, j1, j2, iverbose + real :: sum !----------------------------------------------------------------- iverbose = 0; if (present(verbose)) iverbose = verbose @@ -543,7 +543,7 @@ subroutine radial_search(theta_src,phi_src,theta_dst,phi_dst, map_src_xsize, map do i=1,map_dst_xsize continue_search=.true. step = 1 - step_size = sqrt(real(map_src_size) ) + step_size = int( sqrt(real(map_src_size) )) do while (continue_search .and. step_size > 0) do while (step <= map_src_size .and. continue_search) ! count land points as nearest neighbors diff --git a/horiz_interp/horiz_interp_type.F90 b/horiz_interp/horiz_interp_type.F90 index dab8ee2b27..da1ed1a602 100644 --- a/horiz_interp/horiz_interp_type.F90 +++ b/horiz_interp/horiz_interp_type.F90 @@ -117,8 +117,8 @@ subroutine stats ( dat, low, high, avg, miss, missing_value, mask ) real, intent(in), optional :: missing_value real, intent(in), optional :: mask(:,:) - real :: dsum, npts, buffer_real(3) - integer :: pe, root_pe, npes, p, buffer_int(2) + real :: dsum, buffer_real(3) + integer :: pe, root_pe, npes, p, buffer_int(2), npts pe = mpp_pe() root_pe = mpp_root_pe() @@ -157,7 +157,7 @@ subroutine stats ( dat, low, high, avg, miss, missing_value, mask ) miss = miss + buffer_int(1) npts = npts + buffer_int(2) enddo - if(npts == 0.) then + if(npts == 0) then print*, 'Warning: no points is valid' else avg = dsum/real(npts) diff --git a/interpolator/interpolator.F90 b/interpolator/interpolator.F90 index 7fd704a554..57587231fc 100644 --- a/interpolator/interpolator.F90 +++ b/interpolator/interpolator.F90 @@ -264,7 +264,7 @@ module interpolator_mod ! pletzer real, allocatable :: time_in(:) ! sjs real, allocatable :: climdata(:,:,:), climdata2(:,:,:) -character(len=64) :: name, units !< No description +character(len=64) :: units !< No description integer :: sense !< No description integer, parameter :: max_diag_fields = 30 !< No description @@ -425,7 +425,6 @@ subroutine interpolator_init( clim_type, file_name, lonb_mod, latb_mod, & ! clim_units :: A list of the units for the components listed in data_names. ! integer :: io, ierr -logical :: the_file_exists if (.not. module_is_initialized) then call fms_init diff --git a/monin_obukhov/monin_obukhov.F90 b/monin_obukhov/monin_obukhov.F90 index f9b7b5a1cb..f9475381f9 100644 --- a/monin_obukhov/monin_obukhov.F90 +++ b/monin_obukhov/monin_obukhov.F90 @@ -116,7 +116,7 @@ module monin_obukhov_mod subroutine monin_obukhov_init -integer :: unit, ierr, io, logunit +integer :: ierr, io, logunit !------------------- read namelist input ------------------------------- diff --git a/mosaic/grid.F90 b/mosaic/grid.F90 index 057198fe79..da08e1155b 100644 --- a/mosaic/grid.F90 +++ b/mosaic/grid.F90 @@ -280,7 +280,6 @@ subroutine get_grid_comp_area_SG(component,tile,area,domain) tilefile character(len=4096) :: attvalue character(len=MAX_NAME), allocatable :: nest_tile_name(:) - character(len=MAX_NAME) :: varname1, varname2 integer :: is,ie,js,je ! boundaries of our domain integer :: i0, j0 ! offsets for x and y, respectively integer :: num_nest_tile, ntiles @@ -797,7 +796,6 @@ subroutine get_grid_cell_centers_2D(component, tile, lon, lat, domain) real, intent(inout) :: lon(:,:),lat(:,:) type(domain2d), intent(in), optional :: domain ! local vars - character(len=MAX_NAME) :: varname character(len=MAX_FILE) :: filename1, filename2 integer :: nlon, nlat integer :: i,j @@ -952,7 +950,7 @@ subroutine define_cube_mosaic ( component, domain, layout, halo, maskmap ) ! ---- local vars character(len=MAX_NAME) :: varname - character(len=MAX_FILE) :: mosaic_file + character(len=MAX_FILE + len(grid_dir)) :: mosaic_file integer :: ntiles ! number of tiles integer :: ncontacts ! number of contacts between mosaic tiles integer :: n @@ -985,8 +983,8 @@ subroutine define_cube_mosaic ( component, domain, layout, halo, maskmap ) enddo varname=trim(lowercase(component))//'_mosaic_file' - call read_data(grid_file,varname,mosaic_file) - mosaic_file = grid_dir//mosaic_file + call read_data(grid_file,varname,mosaic_file(1:MAX_FILE)) + mosaic_file = grid_dir//mosaic_file(1:MAX_FILE) ! get the contact information from mosaic file ncontacts = get_mosaic_ncontacts(mosaic_file) diff --git a/mosaic/mosaic.F90 b/mosaic/mosaic.F90 index ff3d51ac46..8ffd162fde 100644 --- a/mosaic/mosaic.F90 +++ b/mosaic/mosaic.F90 @@ -62,6 +62,9 @@ module mosaic_mod public :: is_inside_polygon logical :: module_is_initialized = .true. +!--- external c routines +external get_grid_area, get_grid_great_circle_area, grad_c2l, calc_c2l_grid_info + ! Include variable "version" to be written to log file. #include @@ -142,10 +145,10 @@ subroutine get_mosaic_xgrid(xgrid_file, i1, j1, i2, j2, area, ibegin, iend) call read_compressed(xgrid_file, 'tile2_cell', tile2_cell, start=start, nread=nread, threading=MPP_MULTI) do n = 1, nxgrid - i1(n) = tile1_cell(1,n) - j1(n) = tile1_cell(2,n) - i2(n) = tile2_cell(1,n) - j2(n) = tile2_cell(2,n) + i1(n) = int(tile1_cell(1,n)) + j1(n) = int(tile1_cell(2,n)) + i2(n) = int(tile2_cell(1,n)) + j2(n) = int(tile2_cell(2,n)) area(n) = area(n)/garea end do @@ -184,10 +187,6 @@ function get_mosaic_ncontacts( mosaic_file) character(len=*), intent(in) :: mosaic_file !< The file that contains mosaic information. integer :: get_mosaic_ncontacts - character(len=len_trim(mosaic_file)+1) :: mfile - integer :: strlen - integer :: read_mosaic_ncontacts - if(field_exist(mosaic_file, "contacts") ) then get_mosaic_ncontacts = dimension_size(mosaic_file, "ncontact", no_domain=.TRUE.) else @@ -433,7 +432,6 @@ function is_inside_polygon(lon1, lat1, lon2, lat2 ) real, intent(in) :: lon1, lat1 real, intent(in) :: lon2(:), lat2(:) logical :: is_inside_polygon - real, dimension(size(lon2(:))) :: x2, y2, z2 integer :: npts, isinside integer :: inside_a_polygon diff --git a/mosaic2/grid2.F90 b/mosaic2/grid2.F90 index bf4c1e973b..aaedad2799 100644 --- a/mosaic2/grid2.F90 +++ b/mosaic2/grid2.F90 @@ -300,7 +300,7 @@ subroutine get_grid_size_for_all_tiles(component,nx,ny) ! local vars integer :: siz(2) ! for the size of external fields - character(len=MAX_NAME) :: varname1, varname2 + character(len=MAX_NAME) :: varname1 varname1 = 'AREA_'//trim(uppercase(component)) @@ -368,7 +368,7 @@ subroutine get_grid_cell_area_SG(component, tile, cellarea, domain) 'Illegal component name "'//trim(component)//'": must be one of ATM, LND, or OCN') end select ! convert area to m2 - cellarea = cellarea*4.*PI*radius**2 + cellarea = real(cellarea*4.*PI*radius**2, r4_kind) case(VERSION_2, VERSION_3) if (present(domain)) then call mpp_get_compute_domain(domain,xsize=nlon,ysize=nlat) @@ -441,12 +441,12 @@ subroutine get_grid_comp_area_SG(component,tile,area,domain) character(len=MAX_NAME) :: & xgrid_name, & ! name of the variable holding xgrid names tile_name, & ! name of the tile - xgrid_file, & ! name of the current xgrid file - mosaic_name,& ! name of the mosaic - tilefile + mosaic_name ! name of the mosaic + character(len=MAX_FILE) :: & + tilefile, & ! name of current tile file + xgrid_file ! name of the current xgrid file character(len=4096) :: attvalue character(len=MAX_NAME), allocatable :: nest_tile_name(:) - character(len=MAX_NAME) :: varname1, varname2 integer :: is,ie,js,je ! boundaries of our domain integer :: i0, j0 ! offsets for x and y, respectively integer :: num_nest_tile, ntiles @@ -600,7 +600,7 @@ subroutine get_grid_comp_area_SG(component,tile,area,domain) deallocate(nest_tile_name) end select ! version ! convert area to m2 - area = area*4.*PI*radius**2 + area = real(area*4.*PI*radius**2, r4_kind) !! R8 version ################################### type is (real(r8_kind)) select case (grid_version ) diff --git a/mosaic2/mosaic2.F90 b/mosaic2/mosaic2.F90 index 8242dd6888..14d18b1fa5 100644 --- a/mosaic2/mosaic2.F90 +++ b/mosaic2/mosaic2.F90 @@ -125,8 +125,6 @@ subroutine get_mosaic_xgrid(fileobj, i1, j1, i2, j2, area, ibegin, iend) real :: garea real :: get_global_area - logical :: is_mixed_prec - garea = get_global_area() ! When start and nread present, make sure nread(1) is the same as the size of the data @@ -169,15 +167,15 @@ subroutine get_mosaic_xgrid(fileobj, i1, j1, i2, j2, area, ibegin, iend) end select do n = 1, nxgrid - i1(n) = tile1_cell(1,n) - j1(n) = tile1_cell(2,n) - i2(n) = tile2_cell(1,n) - j2(n) = tile2_cell(2,n) + i1(n) = int(tile1_cell(1,n)) + j1(n) = int(tile1_cell(2,n)) + i2(n) = int(tile2_cell(1,n)) + j2(n) = int(tile2_cell(2,n)) select type(area) type is (real(r4_kind)) - area(n) = area(n)/garea + area(n) = real(area(n)/garea, r4_kind) type is (real(r8_kind)) - area(n) = area(n)/garea + area(n) = real(area(n)/garea, r8_kind) end select end do @@ -527,7 +525,6 @@ function is_inside_polygon(lon1, lat1, lon2, lat2 ) real, intent(in) :: lon1, lat1 real, intent(in) :: lon2(:), lat2(:) logical :: is_inside_polygon - real, dimension(size(lon2(:))) :: x2, y2, z2 integer :: npts, isinside integer :: inside_a_polygon diff --git a/mpp/include/mpp_chksum_int.h b/mpp/include/mpp_chksum_int.h index ac64965d0b..daee6caad2 100644 --- a/mpp/include/mpp_chksum_int.h +++ b/mpp/include/mpp_chksum_int.h @@ -54,7 +54,7 @@ function MPP_CHKSUM_INT_RMASK_( var, pelist, mask_val ) integer(KIND=i8_kind) :: i8tmp=0 !high fidelity error message character(LEN=1) :: tmpStr1,tmpStr2,tmpStr3 - character(LEN=32) :: tmpStr4,tmpStr5 + character(LEN=32) :: tmpStr4 character(LEN=512) :: errStr ! Primary Logic: These first two are the "expected" branches. diff --git a/mpp/include/mpp_comm_mpi.inc b/mpp/include/mpp_comm_mpi.inc index e4af850344..921178fc48 100644 --- a/mpp/include/mpp_comm_mpi.inc +++ b/mpp/include/mpp_comm_mpi.inc @@ -35,12 +35,10 @@ integer, optional, intent(in) :: localcomm integer, optional, intent(in) :: test_level character(len=*), optional, intent(in) :: alt_input_nml_path - integer :: my_pe, num_pes, len, i, iunit + integer :: i, iunit logical :: opened, existed integer :: io_status integer :: t_level - character(len=5) :: this_pe - type(mpp_type), pointer :: dtype if( module_is_initialized )return @@ -219,7 +217,7 @@ end subroutine mpp_init !####################################################################### !> To be called at the end of a run subroutine mpp_exit() - integer :: i, j, k, n, nmax, istat, out_unit, log_unit + integer :: i, j, n, nmax, out_unit, log_unit real :: t, tmin, tmax, tavg, tstd real :: m, mmin, mmax, mavg, mstd, t_total logical :: opened @@ -354,7 +352,7 @@ end subroutine mpp_exit character(len=*), intent(inout) :: data(:) integer, intent(in) :: length, from_pe integer, intent(in), optional :: pelist(:) - integer :: n, i, from_rank, out_unit + integer :: n, i, from_rank character :: str1D(length*size(data(:))) pointer(lptr, str1D) @@ -387,6 +385,9 @@ end subroutine mpp_exit return end subroutine mpp_broadcast_char +! defines initialization value for mpp_type data +#define MPP_TYPE_INIT_VALUE 0. + #undef MPP_TRANSMIT_ #define MPP_TRANSMIT_ mpp_transmit_real8 #undef MPP_TRANSMIT_SCALAR_ @@ -615,6 +616,8 @@ end subroutine mpp_exit #include #endif +#undef MPP_TYPE_INIT_VALUE +#define MPP_TYPE_INIT_VALUE 0 #undef MPP_TRANSMIT_ #define MPP_TRANSMIT_ mpp_transmit_int8 #undef MPP_TRANSMIT_SCALAR_ @@ -727,6 +730,8 @@ end subroutine mpp_exit #define MPI_TYPE_ MPI_INTEGER4 #include +#undef MPP_TYPE_INIT_VALUE +#define MPP_TYPE_INIT_VALUE .false. #undef MPP_TRANSMIT_ #define MPP_TRANSMIT_ mpp_transmit_logical8 #undef MPP_TRANSMIT_SCALAR_ @@ -838,6 +843,7 @@ end subroutine mpp_exit #undef MPI_TYPE_ #define MPI_TYPE_ MPI_INTEGER4 #include +#undef MPP_TYPE_INIT_VALUE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! @@ -1266,6 +1272,7 @@ end subroutine mpp_exit #define MPI_TYPE_ MPI_REAL8 #include +#ifdef OVERLOAD_C4 #undef MPP_ALLTOALL_ #undef MPP_ALLTOALLV_ #undef MPP_ALLTOALLW_ @@ -1279,7 +1286,9 @@ end subroutine mpp_exit #define MPP_TYPE_BYTELEN_ 8 #define MPI_TYPE_ MPI_COMPLEX8 #include +#endif +#ifdef OVERLOAD_C8 #undef MPP_ALLTOALL_ #undef MPP_ALLTOALLV_ #undef MPP_ALLTOALLW_ @@ -1293,6 +1302,7 @@ end subroutine mpp_exit #define MPP_TYPE_BYTELEN_ 16 #define MPI_TYPE_ MPI_COMPLEX16 #include +#endif #undef MPP_ALLTOALL_ #undef MPP_ALLTOALLV_ diff --git a/mpp/include/mpp_comm_nocomm.inc b/mpp/include/mpp_comm_nocomm.inc index fba67d395a..2ee9e00795 100644 --- a/mpp/include/mpp_comm_nocomm.inc +++ b/mpp/include/mpp_comm_nocomm.inc @@ -281,6 +281,9 @@ end subroutine mpp_exit ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! set init value for mpp_type +#define MPP_TYPE_INIT_VALUE 0. + #undef MPP_TRANSMIT_ #define MPP_TRANSMIT_ mpp_transmit_real8 #undef MPP_TRANSMIT_SCALAR_ @@ -509,6 +512,8 @@ end subroutine mpp_exit #include #endif +#undef MPP_TYPE_INIT_VALUE +#define MPP_TYPE_INIT_VALUE 0 #undef MPP_TRANSMIT_ #define MPP_TRANSMIT_ mpp_transmit_int8 #undef MPP_TRANSMIT_SCALAR_ @@ -621,6 +626,8 @@ end subroutine mpp_exit #define MPI_TYPE_ MPI_INTEGER4 #include +#undef MPP_TYPE_INIT_VALUE +#define MPP_TYPE_INIT_VALUE .false. #undef MPP_TRANSMIT_ #define MPP_TRANSMIT_ mpp_transmit_logical8 #undef MPP_TRANSMIT_SCALAR_ @@ -732,6 +739,7 @@ end subroutine mpp_exit #undef MPI_TYPE_ #define MPI_TYPE_ MPI_INTEGER4 #include +#undef MPP_TYPE_INIT_VALUE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! diff --git a/mpp/include/mpp_define_nest_domains.inc b/mpp/include/mpp_define_nest_domains.inc index 9eec82080d..51152edc28 100644 --- a/mpp/include/mpp_define_nest_domains.inc +++ b/mpp/include/mpp_define_nest_domains.inc @@ -112,11 +112,8 @@ subroutine mpp_define_nest_domains(nest_domain, domain, num_nest, nest_level, ti !! default is 0 and currently only support extra_halo = 0. character(len=*), optional, intent(in ) :: name !< name of the nest domain - logical :: concurrent integer :: n, l, m, my_tile_coarse - integer :: nx_coarse, ny_coarse - integer :: nx_fine, ny_fine - integer :: npes, npes_level, prev_tile_coarse + integer :: npes_level, prev_tile_coarse integer :: extra_halo_local, npes_nest_top integer, dimension(:), allocatable :: pes, pe_start_pos, pe_end_pos, pelist_level logical, dimension(:), allocatable :: is_nest_fine, is_nest_coarse @@ -376,10 +373,10 @@ subroutine mpp_shift_nest_domains(nest_domain, domain, delta_i_coarse, delta_j_c integer, intent(in ) :: delta_j_coarse(:) !< Array of deltas of coarse grid in y direction integer, optional, intent(in ) :: extra_halo !< Extra halo size - integer :: n, l, m, my_tile_coarse + integer :: n, l, my_tile_coarse integer :: num_nest - integer :: extra_halo_local, npes_nest_top - integer :: nnest, nlevels, ntiles_top, ntiles, pos + integer :: extra_halo_local + integer :: nlevels, pos integer, pointer :: nest_level(:) nest_level => nest_domain%nest_level @@ -448,14 +445,11 @@ subroutine define_nest_level_type(nest_domain, x_refine, y_refine, extra_halo) integer, intent(in ) :: x_refine, y_refine integer :: n - integer :: nx_coarse, ny_coarse - integer :: nx_fine, ny_fine integer :: npes, npes_fine, npes_coarse - integer :: extra_halo_local integer, allocatable :: pes_coarse(:) integer, allocatable :: pes_fine(:) integer, dimension(nest_domain%num_nest) :: my_nest_id - integer :: my_num_nest, nnest + integer :: my_num_nest npes = size(nest_domain%pelist(:)) npes_coarse = size(nest_domain%domain_coarse%list(:)) @@ -594,18 +588,13 @@ subroutine compute_overlap_coarse_to_fine(nest_domain, overlap, extra_halo, posi integer :: isc_coarse, iec_coarse, jsc_coarse, jec_coarse integer :: is_coarse, ie_coarse, js_coarse, je_coarse integer :: is_coarse2, ie_coarse2, js_coarse2, je_coarse2 - integer :: is_convert, ie_convert, js_convert, je_convert, rotate + integer :: rotate integer :: is_convert2(2), ie_convert2(2), js_convert2(2), je_convert2(2), rotate2(2) integer :: isc_fine, iec_fine, jsc_fine, jec_fine integer :: isd_fine, ied_fine, jsd_fine, jed_fine - integer :: isc_east, iec_east, jsc_east, jec_east - integer :: isc_west, iec_west, jsc_west, jec_west - integer :: isc_south, iec_south, jsc_south, jec_south - integer :: isc_north, iec_north, jsc_north, jec_north integer :: x_refine, y_refine, ishift, jshift - integer :: nsend, nrecv, dir, from_pe, l, nn - integer :: is, ie, js, je, msgsize, nconvert - integer, allocatable :: msg1(:), msg2(:) + integer :: nsend, nrecv, dir, l, nn + integer :: nconvert integer, allocatable :: isl_coarse(:), iel_coarse(:), jsl_coarse(:), jel_coarse(:) integer, allocatable :: isl_fine(:), iel_fine(:), jsl_fine(:), jel_fine(:) integer, allocatable :: isgl_fine(:), iegl_fine(:), jsgl_fine(:), jegl_fine(:) @@ -1098,25 +1087,21 @@ subroutine compute_overlap_fine_to_coarse(nest_domain, overlap, position, name) type(domain2D), pointer :: domain_fine =>NULL() type(domain2D), pointer :: domain_coarse=>NULL() type(overlap_type), allocatable :: overlapList(:) - logical :: is_first integer :: tile_fine, tile_coarse integer :: istart_fine, iend_fine, jstart_fine, jend_fine integer :: istart_coarse, iend_coarse, jstart_coarse, jend_coarse - integer :: whalo, ehalo, shalo, nhalo integer :: npes_fine, npes_coarse, n integer :: isg_fine, ieg_fine, jsg_fine, jeg_fine integer :: isc_coarse, iec_coarse, jsc_coarse, jec_coarse integer :: is_coarse, ie_coarse, js_coarse, je_coarse - integer :: is_fine, ie_fine, js_fine, je_fine integer :: isc_fine, iec_fine, jsc_fine, jec_fine integer :: is_you, ie_you, js_you, je_you integer :: x_refine, y_refine integer :: nsend, nrecv, dir integer, allocatable :: isl_coarse(:), iel_coarse(:), jsl_coarse(:), jel_coarse(:) integer, allocatable :: isl_fine(:), iel_fine(:), jsl_fine(:), jel_fine(:) - integer :: is_convert, ie_convert, js_convert, je_convert integer :: is_convert2(2), ie_convert2(2), js_convert2(2), je_convert2(2), rotate2(2) - integer :: rotate, is2, ie2, js2, je2, nconvert + integer :: is2, ie2, js2, je2, nconvert integer :: xbegin_c, xend_c, ybegin_c, yend_c integer :: ishift, jshift, l, is3, ie3, js3, je3, nn @@ -1923,7 +1908,7 @@ function search_C2F_nest_overlap(nest_domain, nest_level, extra_halo, position) integer, intent(out) :: is_out(:), ie_out(:), js_out(:), je_out(:), rotate_out(:) integer :: convert_index_to_nest integer :: is, ie, js, je, tile, isg, ieg, jsg, jeg - integer :: ncross, rotate, nout, diff, l, ntiles + integer :: ncross, rotate, nout, diff, ntiles ntiles = ntiles_coarse call mpp_get_global_domain(domain, isg, ieg, jsg, jeg) diff --git a/mpp/include/mpp_do_get_boundary_ad.h b/mpp/include/mpp_do_get_boundary_ad.h index a784192162..b2595e041a 100644 --- a/mpp/include/mpp_do_get_boundary_ad.h +++ b/mpp/include/mpp_do_get_boundary_ad.h @@ -1,6 +1,5 @@ ! -*-f90-*- - !*********************************************************************** !* GNU Lesser General Public License !* @@ -357,7 +356,7 @@ subroutine MPP_DO_GET_BOUNDARY_AD_3D_V_(f_addrsx, f_addrsy, domain, boundx, boun integer, allocatable :: msg1(:), msg2(:) logical :: recvx(4), sendx(4) logical :: recvy(4), sendy(4) - integer :: nlist, buffer_pos,buffer_pos_old, pos, pos_, tMe, m + integer :: nlist, buffer_pos,buffer_pos_old, pos, tMe, m integer :: is, ie, js, je, msgsize, l_size, buffer_recv_size, msgsize_send integer :: i, j, k, l, n, index, to_pe, from_pe integer :: rank_x, rank_y, cur_rank, ind_x, ind_y diff --git a/mpp/include/mpp_do_global_field.h b/mpp/include/mpp_do_global_field.h index 05e1b66643..92926b2bb6 100644 --- a/mpp/include/mpp_do_global_field.h +++ b/mpp/include/mpp_do_global_field.h @@ -284,7 +284,7 @@ integer, intent(in), optional :: flags MPP_TYPE_, intent(in), optional :: default_data - integer :: i, j, k, m, n, nd, nwords, lpos, rpos, ioff, joff, from_pe, root_pe, tile_id + integer :: i, n, nd, ioff, joff, root_pe integer :: ke, isc, iec, jsc, jec, is, ie, js, je integer :: ipos, jpos logical :: xonly, yonly, root_only, global_on_this_pe diff --git a/mpp/include/mpp_do_update.h b/mpp/include/mpp_do_update.h index 76d319b07e..7bb5eefff3 100644 --- a/mpp/include/mpp_do_update.h +++ b/mpp/include/mpp_do_update.h @@ -44,7 +44,6 @@ integer :: to_pe, from_pe, pos, msgsize integer :: n, l_size, l, m, i, j, k integer :: is, ie, js, je, tMe, dir - integer :: start, start1, start2, index, is1, ie1, js1, je1, ni, nj, total integer :: buffer_recv_size, nlist, outunit integer :: send_start_pos integer :: send_msgsize(MAXLIST) diff --git a/mpp/include/mpp_do_updateV_ad.h b/mpp/include/mpp_do_updateV_ad.h index 8f8bc476ec..3d62059526 100644 --- a/mpp/include/mpp_do_updateV_ad.h +++ b/mpp/include/mpp_do_updateV_ad.h @@ -42,15 +42,11 @@ integer :: to_pe, from_pe, midpoint integer :: tMe, dir - integer :: send_start_pos, nsend - integer :: send_msgsize(2*MAXLIST) - integer :: send_pe(2*MAXLIST) integer, allocatable :: msg1(:), msg2(:) logical :: send(8), recv(8), update_edge_only MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) pointer(ptr,buffer ) integer :: buffer_pos - character(len=8) :: text integer :: buffer_recv_size, shift integer :: rank_x, rank_y, ind_x, ind_y, cur_rank integer :: nsend_x, nsend_y, nrecv_x, nrecv_y, outunit diff --git a/mpp/include/mpp_do_updateV_nonblock.h b/mpp/include/mpp_do_updateV_nonblock.h index aad3ba5cad..dd58fc58ce 100644 --- a/mpp/include/mpp_do_updateV_nonblock.h +++ b/mpp/include/mpp_do_updateV_nonblock.h @@ -33,7 +33,7 @@ subroutine MPP_START_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, upda !---local variable ------------------------------------------ integer :: i, j, k, l, is, ie, js, je, n, m - integer :: pos, nlist, msgsize, tile, l_size + integer :: pos, nlist, msgsize, l_size integer :: to_pe, from_pe, buffer_pos integer :: tMe, dir, ke_sum logical :: send(8), recv(8), update_edge_only @@ -557,7 +557,7 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_V_(id_update, f_addrsx, f_addrsy, domain, u pointer( ptr, recv_buffer ) integer :: i, j, k, l, is, ie, js, je, n, ke_sum, l_size, m - integer :: pos, nlist, msgsize, tile, buffer_pos + integer :: pos, nlist, msgsize, buffer_pos integer :: ind_x, ind_y, nrecv, nsend integer :: ind_recv_x(update_x%nrecv+update_y%nrecv), ind_recv_y(update_x%nrecv+update_y%nrecv) integer :: start_pos_recv(update_x%nrecv+update_y%nrecv) diff --git a/mpp/include/mpp_do_update_ad.h b/mpp/include/mpp_do_update_ad.h index 17b01cdd5a..07992faf15 100644 --- a/mpp/include/mpp_do_update_ad.h +++ b/mpp/include/mpp_do_update_ad.h @@ -33,7 +33,6 @@ pointer(ptr_field, field) integer :: update_flags type(overlap_type), pointer :: overPtr => NULL() - character(len=8) :: text !equate to mpp_domains_stack MPP_TYPE_ :: buffer(size(mpp_domains_stack(:))) @@ -47,10 +46,7 @@ integer :: to_pe, from_pe, pos, msgsize, msgsize_send integer :: n, l_size, l, m, i, j, k integer :: is, ie, js, je, tMe, dir - integer :: start, start1, start2, index, is1, ie1, js1, je1, ni, nj, total integer :: buffer_recv_size, nlist, outunit - integer :: send_start_pos - integer :: send_msgsize(MAXLIST) outunit = stdout() diff --git a/mpp/include/mpp_do_update_nest.h b/mpp/include/mpp_do_update_nest.h index a67702a6ea..759f019f7b 100644 --- a/mpp/include/mpp_do_update_nest.h +++ b/mpp/include/mpp_do_update_nest.h @@ -864,7 +864,6 @@ subroutine MPP_DO_UPDATE_NEST_COARSE_3D_V_(f_addrsx_in, f_addrsy_in, f_addrsx_ou integer, intent(in) :: flags character(len=8) :: text - type(overlap_type), pointer :: overPtr => NULL() integer :: from_pe, to_pe integer :: m, n, l, i, j, k integer :: is, ie, js, je, l_size diff --git a/mpp/include/mpp_do_update_nonblock.h b/mpp/include/mpp_do_update_nonblock.h index 5ed53f54aa..239638aaee 100644 --- a/mpp/include/mpp_do_update_nonblock.h +++ b/mpp/include/mpp_do_update_nonblock.h @@ -34,7 +34,7 @@ subroutine MPP_START_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type, k integer :: buffer_pos, msgsize, from_pe, to_pe, pos integer :: is, ie, js, je, sendsize, recvsize logical :: send(8), recv(8), update_edge_only - integer :: l_size, ke_sum, my_id_update + integer :: l_size, ke_sum integer :: request integer :: send_msgsize(MAXLIST) character(len=128) :: text @@ -265,12 +265,11 @@ subroutine MPP_COMPLETE_DO_UPDATE_3D_(id_update, f_addrs, domain, update, d_type integer, intent(in) :: flags !--- local variables - integer :: i, j, k, m, n, l, dir, count, tMe, tNbr - integer :: buffer_pos, msgsize, from_pe, pos + integer :: i, j, k, m, n, l, dir, count, tMe + integer :: buffer_pos, msgsize, pos integer :: is, ie, js, je logical :: send(8), recv(8), update_edge_only - integer :: l_size, ke_sum, sendsize, recvsize - character(len=128) :: text + integer :: l_size, ke_sum MPP_TYPE_ :: recv_buffer(size(mpp_domains_stack_nonblock(:))) MPP_TYPE_ :: field(update%xbegin:update%xend, update%ybegin:update%yend,ke_max) pointer( ptr, recv_buffer ) diff --git a/mpp/include/mpp_domains_define.inc b/mpp/include/mpp_domains_define.inc index 06390856d0..e6caf75a04 100644 --- a/mpp/include/mpp_domains_define.inc +++ b/mpp/include/mpp_domains_define.inc @@ -168,8 +168,8 @@ integer, intent(in) :: isg, ieg, ndivs integer, dimension(:), intent(out) :: ibegin, iend - integer :: ndiv, imax, ndmax - integer :: is, ie, n + integer :: ndiv + integer :: is, ie ie = ieg do ndiv=ndivs,1,-1 @@ -312,7 +312,7 @@ integer, intent(in), optional :: begin_halo, end_halo logical :: compute_domain_is_global, data_domain_is_global - integer :: ndiv, n, isg, ieg, i + integer :: ndiv, n, isg, ieg integer, allocatable :: pes(:) integer :: ibegin(0:ndivs-1), iend(0:ndivs-1) logical :: mask(0:ndivs-1) @@ -657,10 +657,7 @@ integer :: ibegin(0:layout(1)-1), iend(0:layout(1)-1) integer :: jbegin(0:layout(2)-1), jend(0:layout(2)-1) character(len=8) :: text - type(overlapSpec), pointer :: update=>NULL() type(overlapSpec), pointer :: check_T => NULL() - character(len=1) :: position - integer :: msgsize, l, p, is, ie, js, je, from_pe integer :: outunit logical :: send(8), recv(8) @@ -1215,10 +1212,6 @@ end subroutine check_message_size integer, allocatable :: align1(:), align2(:), is1(:), ie1(:), js1(:), je1(:), is2(:), ie2(:), js2(:), je2(:) integer, allocatable :: isgList(:), iegList(:), jsgList(:), jegList(:) real, allocatable :: refine1(:), refine2(:) - type(overlapSpec), pointer :: update=>NULL() - character(len=1) :: position - integer :: msgsize, l, p, is, ie, js, je, from_pe - integer, allocatable :: msg1(:), msg2(:), msg3(:) integer :: outunit logical :: send(8), recv(8) @@ -5244,7 +5237,7 @@ end subroutine check_message_size integer :: isc, iec, jsc, jec, isd, ied, jsd, jed integer :: isc1, iec1, jsc1, jec1, isc2, iec2, jsc2, jec2 integer :: isd1, ied1, jsd1, jed1, isd2, ied2, jsd2, jed2 - integer :: is, ie, js, je, ioff, joff, isoff, ieoff, jsoff, jeoff + integer :: is, ie, js, je, ioff, joff integer :: ntiles, max_contact integer :: nlist, list, m, n, l, count, numS, numR integer :: whalo, ehalo, shalo, nhalo @@ -5896,7 +5889,7 @@ subroutine set_contact_point(domain, position) integer :: ishift, jshift, nlist, list, m, n integer :: ntileMe, tMe, dir, count, pos, nsend, nrecv - integer :: isoff1, ieoff1, isoff2, ieoff2, jsoff1, jeoff1, jsoff2, jeoff2 + integer :: isoff1, ieoff1, jsoff1, jeoff1 type(overlap_type), pointer :: ptrIn => NULL() type(overlapSpec), pointer :: update_in => NULL() type(overlapSpec), pointer :: update_out => NULL() @@ -6301,7 +6294,7 @@ end subroutine set_check_overlap subroutine set_bound_overlap( domain, position ) type(domain2d), intent(inout) :: domain integer, intent(in) :: position - integer :: m, n, l, count, dr, tMe, i + integer :: m, n, l, count, dr, tMe integer, parameter :: MAXCOUNT = 100 integer, dimension(MAXCOUNT) :: dir, rotation, is, ie, js, je, tileMe, index integer, dimension(size(domain%x(:)), 4) :: nrecvl @@ -6312,9 +6305,6 @@ subroutine set_bound_overlap( domain, position ) integer :: nlist_send, nlist_recv, ishift, jshift integer :: ism, iem, jsm, jem, nsend, nrecv integer :: isg, ieg, jsg, jeg, nlist, list -! integer :: isc1, iec1, jsc1, jec1 -! integer :: isc2, iec2, jsc2, jec2 - integer :: isd, ied, jsd, jed integer :: npes_x, npes_y, ipos, jpos, inbr, jnbr integer :: isc, iec, jsc, jec, my_pe integer :: pe_south1, pe_south2, pe_west0, pe_west1, pe_west2 diff --git a/mpp/include/mpp_domains_misc.inc b/mpp/include/mpp_domains_misc.inc index c18acf4021..a4d89fce5e 100644 --- a/mpp/include/mpp_domains_misc.inc +++ b/mpp/include/mpp_domains_misc.inc @@ -54,7 +54,6 @@ integer, intent(in), optional :: flags integer :: n integer :: io_status, unit - logical :: opened if( module_is_initialized )return call mpp_init(flags) !this is a no-op if already initialized @@ -614,8 +613,7 @@ end subroutine init_nonblock_type type(domain2D), intent(in) :: domain_in type(domain2D), intent(inout) :: domain_out integer, allocatable :: pes(:) - logical :: native !true if I'm on the pelist of this domain - integer :: listsize, listpos + integer :: listpos integer :: n integer, dimension(12) :: msg, info !pe and compute domain of each item in list integer :: errunit, npes_in, npes_out, pstart, pend @@ -865,7 +863,7 @@ end subroutine init_nonblock_type logical :: native !true if I'm on the pelist of this domain integer :: listsize, listpos integer, allocatable :: tile_pesize(:) - integer :: n, tile, maxtile + integer :: n, maxtile integer, dimension(17) :: msg, info !pe and compute domain of each item in list integer :: errunit @@ -1826,68 +1824,6 @@ end subroutine init_nonblock_type #undef MPP_DO_UPDATE_AD_3D_ #define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_i4_3d #include -!!$#undef VECTOR_FIELD_ -!!$#define VECTOR_FIELD_ -!!$#undef MPP_TYPE_ -!!$#define MPP_TYPE_ real(r8_kind) -!!$#undef MPP_DO_UPDATE_AD_3D_ -!!$#define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_r8_3d -!!$#ifdef VECTOR_FIELD_ -!!$#undef MPP_DO_UPDATE_AD_3D_V_ -!!$#define MPP_DO_UPDATE_AD_3D_V_ mpp_do_update_ad_r8_3dv -!!$#endif -!!$#include -!!$#include -!!$#undef VECTOR_FIELD_ -!!$ -!!$#ifdef OVERLOAD_C8 -!!$#undef MPP_TYPE_ -!!$#define MPP_TYPE_ complex(c8_kind) -!!$#undef MPP_DO_UPDATE_AD_3D_ -!!$#define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_c8_3d -!!$#include -!!$#endif -!!$ -!!$ -!!$#undef MPP_TYPE_ -!!$#define MPP_TYPE_ integer(i8_kind) -!!$#undef MPP_DO_UPDATE_AD_3D_ -!!$#define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_i8_3d -!!$#include -!!$ -!!$ -!!$#ifdef OVERLOAD_R4 -!!$#undef VECTOR_FIELD_ -!!$#define VECTOR_FIELD_ -!!$#undef MPP_TYPE_ -!!$#define MPP_TYPE_ real(r4_kind) -!!$#undef MPP_DO_UPDATE_AD_3D_ -!!$#define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_r4_3d -!!$#ifdef VECTOR_FIELD_ -!!$#undef MPP_DO_UPDATE_AD_3D_V_ -!!$#define MPP_DO_UPDATE_AD_3D_V_ mpp_do_update_ad_r4_3dv -!!$#endif -!!$#include -!!$#include -!!$#endif -!!$ -!!$#ifdef OVERLOAD_C4 -!!$#undef VECTOR_FIELD_ -!!$#undef MPP_TYPE_ -!!$#define MPP_TYPE_ complex(c4_kind) -!!$#undef MPP_DO_UPDATE_AD_3D_ -!!$#define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_c4_3d -!!$#include -!!$#endif -!!$ -!!$#undef MPP_TYPE_ -!!$#define MPP_TYPE_ integer(i4_kind) -!!$#undef MPP_DO_UPDATE_AD_3D_ -!!$#define MPP_DO_UPDATE_AD_3D_ mpp_do_update_ad_i4_3d -!!$#include - -!bnc - !******************************************************** #undef MPP_TYPE_ diff --git a/mpp/include/mpp_domains_reduce.inc b/mpp/include/mpp_domains_reduce.inc index f70c568462..46d3bc935a 100644 --- a/mpp/include/mpp_domains_reduce.inc +++ b/mpp/include/mpp_domains_reduce.inc @@ -792,6 +792,7 @@ ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +#define MPP_TYPE_INIT_VALUE 0. #undef MPP_GLOBAL_FIELD_2D_ #define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_r8_2d #undef MPP_GLOBAL_FIELD_3D_ @@ -818,6 +819,8 @@ #include #endif +#undef MPP_TYPE_INIT_VALUE +#define MPP_TYPE_INIT_VALUE 0 #undef MPP_GLOBAL_FIELD_2D_ #define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_i8_2d #undef MPP_GLOBAL_FIELD_3D_ @@ -830,6 +833,8 @@ #define MPP_TYPE_ integer(i8_kind) #include +#undef MPP_TYPE_INIT_VALUE +#define MPP_TYPE_INIT_VALUE .false. #undef MPP_GLOBAL_FIELD_2D_ #define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_l8_2d #undef MPP_GLOBAL_FIELD_3D_ @@ -842,6 +847,8 @@ #define MPP_TYPE_ logical(l8_kind) #include +#undef MPP_TYPE_INIT_VALUE +#define MPP_TYPE_INIT_VALUE 0. #undef MPP_GLOBAL_FIELD_2D_ #define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_r4_2d #undef MPP_GLOBAL_FIELD_3D_ @@ -868,6 +875,8 @@ #include #endif +#undef MPP_TYPE_INIT_VALUE +#define MPP_TYPE_INIT_VALUE 0 #undef MPP_GLOBAL_FIELD_2D_ #define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_i4_2d #undef MPP_GLOBAL_FIELD_3D_ @@ -880,6 +889,8 @@ #define MPP_TYPE_ integer(i4_kind) #include +#undef MPP_TYPE_INIT_VALUE +#define MPP_TYPE_INIT_VALUE .false. #undef MPP_GLOBAL_FIELD_2D_ #define MPP_GLOBAL_FIELD_2D_ mpp_global_field2D_l4_2d #undef MPP_GLOBAL_FIELD_3D_ @@ -891,8 +902,10 @@ #undef MPP_TYPE_ #define MPP_TYPE_ logical(l4_kind) #include +#undef MPP_TYPE_INIT_VALUE !**************************************************** +#define MPP_TYPE_INIT_VALUE 0. #undef MPP_GLOBAL_FIELD_2D_AD_ #define MPP_GLOBAL_FIELD_2D_AD_ mpp_global_field2D_r8_2d_ad #undef MPP_GLOBAL_FIELD_3D_AD_ @@ -919,6 +932,8 @@ #include #endif +#undef MPP_TYPE_INIT_VALUE +#define MPP_TYPE_INIT_VALUE 0 #undef MPP_GLOBAL_FIELD_2D_AD_ #define MPP_GLOBAL_FIELD_2D_AD_ mpp_global_field2D_i8_2d_ad #undef MPP_GLOBAL_FIELD_3D_AD_ @@ -931,6 +946,8 @@ #define MPP_TYPE_ integer(i8_kind) #include +#undef MPP_TYPE_INIT_VALUE +#define MPP_TYPE_INIT_VALUE .false. #undef MPP_GLOBAL_FIELD_2D_AD_ #define MPP_GLOBAL_FIELD_2D_AD_ mpp_global_field2D_l8_2d_ad #undef MPP_GLOBAL_FIELD_3D_AD_ @@ -943,6 +960,8 @@ #define MPP_TYPE_ logical(l8_kind) #include +#undef MPP_TYPE_INIT_VALUE +#define MPP_TYPE_INIT_VALUE 0. #undef MPP_GLOBAL_FIELD_2D_AD_ #define MPP_GLOBAL_FIELD_2D_AD_ mpp_global_field2D_r4_2d_ad #undef MPP_GLOBAL_FIELD_3D_AD_ @@ -969,6 +988,8 @@ #include #endif +#undef MPP_TYPE_INIT_VALUE +#define MPP_TYPE_INIT_VALUE 0 #undef MPP_GLOBAL_FIELD_2D_AD_ #define MPP_GLOBAL_FIELD_2D_AD_ mpp_global_field2D_i4_2d_ad #undef MPP_GLOBAL_FIELD_3D_AD_ @@ -981,6 +1002,8 @@ #define MPP_TYPE_ integer(i4_kind) #include +#undef MPP_TYPE_INIT_VALUE +#define MPP_TYPE_INIT_VALUE .false. #undef MPP_GLOBAL_FIELD_2D_AD_ #define MPP_GLOBAL_FIELD_2D_AD_ mpp_global_field2D_l4_2d_ad #undef MPP_GLOBAL_FIELD_3D_AD_ @@ -992,6 +1015,7 @@ #undef MPP_TYPE_ #define MPP_TYPE_ logical(l4_kind) #include +#undef MPP_TYPE_INIT_VALUE !**************************************************** #undef MPP_DO_GLOBAL_FIELD_3D_ diff --git a/mpp/include/mpp_domains_util.inc b/mpp/include/mpp_domains_util.inc index c0f0b23b22..850d19bc78 100644 --- a/mpp/include/mpp_domains_util.inc +++ b/mpp/include/mpp_domains_util.inc @@ -1935,9 +1935,8 @@ end subroutine mpp_get_tile_compute_domains integer :: ind_s(3*MAXOVERLAP) integer :: ind_x(3*MAXOVERLAP) integer :: ind_y(3*MAXOVERLAP) - integer :: pelist(3*MAXOVERLAP), to_pe_list(3*MAXOVERLAP) - integer :: buffer_pos_recv(3*MAXOVERLAP), buffer_pos_send(3*MAXOVERLAP) - integer :: recv_size(3*MAXOVERLAP), send_size(3*MAXOVERLAP) + integer :: pelist(3*MAXOVERLAP) + integer :: send_size(3*MAXOVERLAP) integer :: position_x, position_y, npack, nunpack, dir integer :: pack_buffer_pos, unpack_buffer_pos integer :: omp_get_num_threads, nthreads diff --git a/mpp/include/mpp_gather.h b/mpp/include/mpp_gather.h index 9f8433ee2d..28c5dad7e9 100644 --- a/mpp/include/mpp_gather.h +++ b/mpp/include/mpp_gather.h @@ -66,7 +66,7 @@ subroutine MPP_GATHER_1DV_(sbuf, ssize, rbuf, rsize, pelist) integer, dimension(:), intent(in) :: rsize integer, dimension(:), intent(in), optional :: pelist(:) - integer :: cnt, l, nproc, pos, op_root + integer :: l, nproc, pos, op_root integer, allocatable :: pelist2(:) ! If pelist is provided, the first position must be diff --git a/mpp/include/mpp_get_boundary.h b/mpp/include/mpp_get_boundary.h index 68ec1a2da5..686551372b 100644 --- a/mpp/include/mpp_get_boundary.h +++ b/mpp/include/mpp_get_boundary.h @@ -27,16 +27,11 @@ subroutine MPP_GET_BOUNDARY_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffe integer, intent(in), optional :: flags, position, tile_count logical, intent(in), optional :: complete - MPP_TYPE_ :: field3D(size(field,1),size(field,2),1) - MPP_TYPE_, allocatable, dimension(:,:) :: ebuffer2D, sbuffer2D, wbuffer2D, nbuffer2D - integer :: xcount, ycount - - integer :: ntile logical :: need_ebuffer, need_sbuffer, need_wbuffer, need_nbuffer integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrs=-9999 integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrs=-9999 - integer, save :: bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0, upflags + integer, save :: bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0 integer :: buffer_size(4) integer :: max_ntile, tile, update_position, ishift, jshift logical :: do_update, is_complete, set_mismatch @@ -177,7 +172,7 @@ subroutine MPP_GET_BOUNDARY_3D_(field, domain, ebuffer, sbuffer, wbuffer, nbuffe logical :: need_ebuffer, need_sbuffer, need_wbuffer, need_nbuffer integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrs=-9999 integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrs=-9999 - integer, save :: bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0, upflags + integer, save :: bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0 integer :: buffer_size(4) integer :: max_ntile, tile, update_position, ishift, jshift logical :: do_update, is_complete, set_mismatch diff --git a/mpp/include/mpp_get_boundary_ad.h b/mpp/include/mpp_get_boundary_ad.h index 91c865a659..6c3e395573 100644 --- a/mpp/include/mpp_get_boundary_ad.h +++ b/mpp/include/mpp_get_boundary_ad.h @@ -29,16 +29,11 @@ subroutine MPP_GET_BOUNDARY_AD_2D_(field, domain, ebuffer, sbuffer, wbuffer, nbu integer, intent(in), optional :: flags, position, tile_count logical, intent(in), optional :: complete - MPP_TYPE_ :: field3D(size(field,1),size(field,2),1) - MPP_TYPE_, allocatable, dimension(:,:) :: ebuffer2D, sbuffer2D, wbuffer2D, nbuffer2D - integer :: xcount, ycount - - integer :: ntile logical :: need_ebuffer, need_sbuffer, need_wbuffer, need_nbuffer integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrs=-9999 integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrs=-9999 - integer, save :: bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0, upflags + integer, save :: bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0 integer :: buffer_size(4) integer :: max_ntile, tile, update_position, ishift, jshift logical :: do_update, is_complete, set_mismatch @@ -179,7 +174,7 @@ subroutine MPP_GET_BOUNDARY_AD_3D_(field, domain, ebuffer, sbuffer, wbuffer, nbu logical :: need_ebuffer, need_sbuffer, need_wbuffer, need_nbuffer integer(i8_kind),dimension(MAX_DOMAIN_FIELDS, MAX_TILES), save :: f_addrs=-9999 integer(i8_kind),dimension(4,MAX_DOMAIN_FIELDS, MAX_TILES),save :: b_addrs=-9999 - integer, save :: bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0, upflags + integer, save :: bsize(4)=0, isize=0, jsize=0, ksize=0, pos, list=0, l_size=0 integer :: buffer_size(4) integer :: max_ntile, tile, update_position, ishift, jshift logical :: do_update, is_complete, set_mismatch diff --git a/mpp/include/mpp_global_field.h b/mpp/include/mpp_global_field.h index 890452cbc5..f11ad15517 100644 --- a/mpp/include/mpp_global_field.h +++ b/mpp/include/mpp_global_field.h @@ -29,6 +29,8 @@ MPP_TYPE_ :: global3D(size(global,1),size(global,2),1) pointer( lptr, local3D ) pointer( gptr, global3D ) + ! initialize output, check if type macro logical + global = MPP_TYPE_INIT_VALUE lptr = LOC( local) gptr = LOC(global) call mpp_global_field( domain, local3D, global3D, flags, position,tile_count, default_data ) @@ -88,6 +90,7 @@ MPP_TYPE_ :: global3D(size(global,1),size(global,2),size(global,3)*size(local,4)) pointer( lptr, local3D ) pointer( gptr, global3D ) + global = MPP_TYPE_INIT_VALUE lptr = LOC(local) gptr = LOC(global) call mpp_global_field( domain, local3D, global3D, flags, position,tile_count, default_data ) @@ -106,6 +109,7 @@ MPP_TYPE_ :: global3D(size(global,1),size(global,2),size(global,3)*size(global,4)*size(local,5)) pointer( lptr, local3D ) pointer( gptr, global3D ) + global = MPP_TYPE_INIT_VALUE lptr = LOC(local) gptr = LOC(global) call mpp_global_field( domain, local3D, global3D, flags, position,tile_count, default_data ) diff --git a/mpp/include/mpp_global_field_ad.h b/mpp/include/mpp_global_field_ad.h index ac8d8efb27..b967e72fe8 100644 --- a/mpp/include/mpp_global_field_ad.h +++ b/mpp/include/mpp_global_field_ad.h @@ -33,6 +33,7 @@ MPP_TYPE_ :: global3D(size(global,1),size(global,2),1) pointer( lptr, local3D ) pointer( gptr, global3D ) + local = MPP_TYPE_INIT_VALUE lptr = LOC( local) gptr = LOC(global) call mpp_global_field_ad( domain, local3D, global3D, flags, position,tile_count, default_data ) @@ -73,6 +74,7 @@ MPP_TYPE_ :: global3D(size(global,1),size(global,2),size(global,3)*size(local,4)) pointer( lptr, local3D ) pointer( gptr, global3D ) + local = MPP_TYPE_INIT_VALUE lptr = LOC(local) gptr = LOC(global) call mpp_global_field_ad( domain, local3D, global3D, flags, position,tile_count, default_data ) @@ -91,6 +93,7 @@ MPP_TYPE_ :: global3D(size(global,1),size(global,2),size(global,3)*size(global,4)*size(local,5)) pointer( lptr, local3D ) pointer( gptr, global3D ) + local = MPP_TYPE_INIT_VALUE lptr = LOC(local) gptr = LOC(global) call mpp_global_field_ad( domain, local3D, global3D, flags, position,tile_count, default_data ) diff --git a/mpp/include/mpp_global_field_ug.h b/mpp/include/mpp_global_field_ug.h index 121db936fc..f57d7cb8bd 100644 --- a/mpp/include/mpp_global_field_ug.h +++ b/mpp/include/mpp_global_field_ug.h @@ -27,6 +27,7 @@ MPP_TYPE_ :: global3D(size(global,1),1) pointer( lptr, local3D ) pointer( gptr, global3D ) + global = 0 lptr = LOC( local) gptr = LOC(global) call mpp_global_field_UG( domain, local3D, global3D, flags, default_data ) @@ -42,10 +43,10 @@ integer, intent(in), optional :: flags MPP_TYPE_, intent(in), optional :: default_data - integer :: l, k, m, n, nd, nwords, lpos, rpos, ioff, joff, from_pe, tile_id + integer :: l, k, m, n, nd, nwords, lpos, rpos, tile_id integer :: ke, lsc, lec, ls, le, nword_me integer :: ipos, jpos - logical :: xonly, yonly, root_only, global_on_this_pe + logical :: root_only, global_on_this_pe MPP_TYPE_ :: clocal (domain%compute%size*size(local,2)) MPP_TYPE_ :: cremote(domain%compute%max_size*size(local,2)) integer :: stackuse @@ -176,6 +177,7 @@ MPP_TYPE_ :: global3D(size(global,1),size(global,2)*size(global,3)) pointer( lptr, local3D ) pointer( gptr, global3D ) + global = 0 lptr = LOC(local) gptr = LOC(global) call mpp_global_field_UG( domain, local3D, global3D, flags, default_data ) @@ -192,6 +194,7 @@ MPP_TYPE_ :: global3D(size(global,1),size(global,2)*size(global,3)*size(global,4)) pointer( lptr, local3D ) pointer( gptr, global3D ) + global = 0 lptr = LOC(local) gptr = LOC(global) call mpp_global_field_UG( domain, local3D, global3D, flags, default_data ) diff --git a/mpp/include/mpp_group_update.h b/mpp/include/mpp_group_update.h index 6fa52be50f..ae17628d3a 100644 --- a/mpp/include/mpp_group_update.h +++ b/mpp/include/mpp_group_update.h @@ -431,7 +431,6 @@ subroutine MPP_DO_GROUP_UPDATE_(group, domain, d_type) integer :: n, l, m, i, j, k, buffer_start_pos, nk integer :: shift, gridtype, midpoint integer :: npack, nunpack, rotation, isd - character(len=8) :: text MPP_TYPE_ :: buffer(mpp_domains_stack_size) MPP_TYPE_ :: field (group%is_s:group%ie_s,group%js_s:group%je_s, group%ksize_s) @@ -748,8 +747,8 @@ subroutine MPP_COMPLETE_GROUP_UPDATE_(group, domain, d_type) MPP_TYPE_, intent(in) :: d_type integer :: nsend, nrecv, nscalar, nvector - integer :: k, buffer_pos, msgsize, pos, m, n, l - integer :: is, ie, js, je, dir, ksize, i, j + integer :: k, buffer_pos, pos, m, n, l + integer :: is, ie, js, je, ksize, i, j integer :: shift, gridtype, midpoint, flags_v integer :: nunpack, rotation, buffer_start_pos, nk, isd logical :: recv_y(8) @@ -963,7 +962,6 @@ end subroutine MPP_RESET_GROUP_UPDATE_FIELD_4D_ subroutine MPP_RESET_GROUP_UPDATE_FIELD_2D_V_(group, fieldx, fieldy) type(mpp_group_update_type), intent(inout) :: group MPP_TYPE_, intent(in) :: fieldx(:,:), fieldy(:,:) - integer :: indx group%reset_index_v = group%reset_index_v + 1 @@ -983,7 +981,6 @@ end subroutine MPP_RESET_GROUP_UPDATE_FIELD_2D_V_ subroutine MPP_RESET_GROUP_UPDATE_FIELD_3D_V_(group, fieldx, fieldy) type(mpp_group_update_type), intent(inout) :: group MPP_TYPE_, intent(in) :: fieldx(:,:,:), fieldy(:,:,:) - integer :: indx group%reset_index_v = group%reset_index_v + 1 @@ -1003,7 +1000,6 @@ end subroutine MPP_RESET_GROUP_UPDATE_FIELD_3D_V_ subroutine MPP_RESET_GROUP_UPDATE_FIELD_4D_V_(group, fieldx, fieldy) type(mpp_group_update_type), intent(inout) :: group MPP_TYPE_, intent(in) :: fieldx(:,:,:,:), fieldy(:,:,:,:) - integer :: indx group%reset_index_v = group%reset_index_v + 1 diff --git a/mpp/include/mpp_transmit.inc b/mpp/include/mpp_transmit.inc index a1c9f26aef..100fc334ee 100644 --- a/mpp/include/mpp_transmit.inc +++ b/mpp/include/mpp_transmit.inc @@ -42,6 +42,8 @@ pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) + get_data = MPP_TYPE_INIT_VALUE + ptrp = LOC(put_data) ptrg = LOC(get_data) put_len=1; if(PRESENT(plen))put_len=plen @@ -64,6 +66,8 @@ pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) + get_data = MPP_TYPE_INIT_VALUE + ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & @@ -84,6 +88,8 @@ pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) + get_data = MPP_TYPE_INIT_VALUE + ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & @@ -104,6 +110,8 @@ pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) + get_data = MPP_TYPE_INIT_VALUE + ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & @@ -124,6 +132,8 @@ pointer( ptrp, put_data1D ) pointer( ptrg, get_data1D ) + get_data = MPP_TYPE_INIT_VALUE + ptrp = LOC(put_data) ptrg = LOC(get_data) call mpp_transmit( put_data1D, put_len, to_pe, get_data1D, get_len, from_pe, block, tag, & @@ -173,6 +183,8 @@ MPP_TYPE_ :: dummy(1) pointer( ptr, get_data1D ) + get_data = MPP_TYPE_INIT_VALUE + ptr = LOC(get_data) get_len=1; if(PRESENT(glen))get_len=glen call mpp_transmit( dummy, 1, NULL_PE, get_data1D, get_len, from_pe, block, tag, recv_request=request ) diff --git a/mpp/include/mpp_transmit_mpi.h b/mpp/include/mpp_transmit_mpi.h index 2b40002946..a24d13f9d7 100644 --- a/mpp/include/mpp_transmit_mpi.h +++ b/mpp/include/mpp_transmit_mpi.h @@ -49,7 +49,6 @@ integer, intent(out), optional :: recv_request, send_request logical :: block_comm integer :: i - MPP_TYPE_, allocatable, save :: local_data(:) !local copy used by non-parallel code (no SHMEM or MPI) integer :: comm_tag integer :: rsize diff --git a/mpp/include/mpp_unstruct_domain.inc b/mpp/include/mpp_unstruct_domain.inc index b98cb5a48c..86ac43cc7d 100644 --- a/mpp/include/mpp_unstruct_domain.inc +++ b/mpp/include/mpp_unstruct_domain.inc @@ -34,7 +34,7 @@ character(len=*), optional, intent(in) :: name integer, dimension(size(npts_tile(:))) :: ndivs_tile, pe_start, pe_end integer, dimension(0:ndivs-1) :: ibegin, iend, costs_list - integer :: ntiles, ntotal_pts, ndivs_used, max_npts, cur_tile, cur_npts + integer :: ntiles, ndivs_used, cur_tile integer :: n, ts, te, p, pos, tile_id, ngroup, group_id, my_pos, i integer :: npes_in_group, is, ie, ntotal_costs, max_cost, cur_cost, costs_left integer :: npts_left, ndiv_left, cur_pos, ndiv, prev_cost, ioff @@ -723,9 +723,6 @@ subroutine mpp_deallocate_domainUG(domain) ! null() diff --git a/mpp/include/mpp_update_domains2D.h b/mpp/include/mpp_update_domains2D.h index 759580f547..1a9939b42b 100644 --- a/mpp/include/mpp_update_domains2D.h +++ b/mpp/include/mpp_update_domains2D.h @@ -227,6 +227,7 @@ pointer( ptr_in, field3D_in ) pointer( ptr_out, field3D_out ) + field_out = 0 ptr_in = 0 ptr_out = 0 if(domain_in%initialized) ptr_in = LOC(field_in ) @@ -257,6 +258,7 @@ MPP_TYPE_ :: d_type integer(i8_kind) :: floc_in, floc_out + field_out = 0 floc_in = 0 floc_out = 0 if(domain_in%initialized) floc_in = LOC(field_in) @@ -344,6 +346,7 @@ pointer( ptr_in, field3D_in ) pointer( ptr_out, field3D_out ) + field_out = 0 ptr_in = 0 ptr_out = 0 if(domain_in%initialized) ptr_in = LOC(field_in ) @@ -367,6 +370,7 @@ pointer( ptr_in, field3D_in ) pointer( ptr_out, field3D_out ) + field_out = 0 ptr_in = 0 ptr_out = 0 if(domain_in%initialized) ptr_in = LOC(field_in ) diff --git a/mpp/include/mpp_util.inc b/mpp/include/mpp_util.inc index 923191b36b..c2c9ba5bd5 100644 --- a/mpp/include/mpp_util.inc +++ b/mpp/include/mpp_util.inc @@ -103,7 +103,7 @@ !> @brief This function returns the current standard fortran unit numbers for log messages. !! Log messages, by convention, are written to the file logfile.out. function stdlog() - integer :: stdlog,istat + integer :: stdlog logical :: opened character(len=11) :: this_pe !$ logical :: omp_in_parallel @@ -481,29 +481,10 @@ end function rarray_to_char !##################################################################### subroutine mpp_set_root_pe(num) integer, intent(in) :: num - logical :: opened if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SET_ROOT_PE: You must first call mpp_init.' ) if( .NOT.(ANY(num.EQ.peset(current_peset_num)%list(:))) ) & call mpp_error( FATAL, 'MPP_SET_ROOT_PE: you cannot set a root PE outside the current pelist.' ) - !actions to take if root_pe has changed: - ! open log_unit on new root_pe, close it on old root_pe and point its log_unit to stdout. - ! if( num.NE.root_pe )then !root_pe has changed - ! if( pe.EQ.num )then - !on the new root_pe - ! if( log_unit.NE.out_unit )then - ! inquire( unit=log_unit, opened=opened ) - ! if( .NOT.opened )open( unit=log_unit, status='OLD', file=trim(configfile), position='APPEND' ) - ! end if - ! else if( pe.EQ.root_pe )then - !on the old root_pe - ! if( log_unit.NE.out_unit )then - ! inquire( unit=log_unit, opened=opened ) - ! if( opened )close(log_unit) - ! log_unit = out_unit - ! end if - ! end if - ! end if root_pe = num return end subroutine mpp_set_root_pe @@ -577,7 +558,6 @@ end function rarray_to_char !if pelist is omitted, we reset pelist to the world pelist. integer, intent(in), optional :: pelist(:) logical, intent(in), optional :: no_sync - integer :: i if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_SET_CURRENT_PELIST: You must first call mpp_init.' ) if( PRESENT(pelist) )then @@ -796,7 +776,6 @@ end function rarray_to_char integer :: mpp_clock_id character(len=*), intent(in) :: name integer, intent(in), optional :: flags, grain - integer :: i if( .NOT.module_is_initialized )call mpp_error( FATAL, 'MPP_CLOCK_ID: You must first call mpp_init.') @@ -957,7 +936,7 @@ end function rarray_to_char real :: total_time,total_time_all,total_data real :: msg_size,eff_BW,s integer :: SD_UNIT, total_calls - integer :: i,j,k,ct, msg_cnt + integer :: j,k,ct, msg_cnt character(len=2) :: u character(len=20) :: filename character(len=20),dimension(MAX_BINS),save :: bin @@ -1005,7 +984,7 @@ end function rarray_to_char total_time = clock_summary(ct)%event(k)%total_time total_time_all = total_time_all + total_time total_data = clock_summary(ct)%event(k)%total_data - total_calls = clock_summary(ct)%event(k)%total_cnts + total_calls = int(clock_summary(ct)%event(k)%total_cnts) write(SD_UNIT,1000) clock_summary(ct)%event(k)%name(1:9) // ':' @@ -1032,7 +1011,7 @@ end function rarray_to_char u = 'MB' endif - msg_cnt = clock_summary(ct)%event(k)%msg_size_cnts(j) + msg_cnt = int(clock_summary(ct)%event(k)%msg_size_cnts(j)) msg_size = & s*(clock_summary(ct)%event(k)%msg_size_sums(j)/real(msg_cnt)) eff_BW = (1.0e-6)*( clock_summary(ct)%event(k)%msg_size_sums(j) / & @@ -1052,7 +1031,7 @@ end function rarray_to_char total_time = clock_summary(ct)%event(MAX_EVENT_TYPES)%total_time total_time_all = total_time_all + total_time - total_calls = clock_summary(ct)%event(MAX_EVENT_TYPES)%total_cnts + total_calls = int(clock_summary(ct)%event(MAX_EVENT_TYPES)%total_cnts) write(SD_UNIT,1000) clock_summary(ct)%event(MAX_EVENT_TYPES)%name(1:9) // ':' @@ -1119,7 +1098,7 @@ end function rarray_to_char clock_summary(ct)%event(j)%total_cnts = & clock_summary(ct)%event(j)%total_cnts + 1 - event_size = clocks(ct)%events(j)%bytes(i) + event_size = int(clocks(ct)%events(j)%bytes(i)) k = find_bin(event_size) @@ -1536,7 +1515,7 @@ end function rarray_to_char character(len=5) :: text logical :: file_exist - integer :: status, i, f_unit, log_unit + integer :: status, f_unit, log_unit integer :: from_pe integer :: pnum_lines, num_lines character(len=LENGTH) :: str_tmp !< Temporary variable to store line from file diff --git a/mpp/include/mpp_util_mpi.inc b/mpp/include/mpp_util_mpi.inc index 61aa918e1e..a22a4f74ff 100644 --- a/mpp/include/mpp_util_mpi.inc +++ b/mpp/include/mpp_util_mpi.inc @@ -38,8 +38,7 @@ subroutine mpp_error_basic( errortype, errormsg ) integer, intent(in) :: errortype character(len=*), intent(in), optional :: errormsg character(len=512) :: text - logical :: opened - integer :: istat, errunit + integer :: errunit if( .NOT.module_is_initialized )call ABORT() @@ -90,10 +89,9 @@ end subroutine mpp_error_basic function get_peset(pelist) integer :: get_peset integer, intent(in), optional :: pelist(:) - integer :: group, errunit - integer :: i, n, stride, l + integer :: errunit + integer :: i, n integer, allocatable :: sorted(:) - character(len=128) :: text if( .NOT.PRESENT(pelist) )then !set it to current_peset_num get_peset = current_peset_num; return @@ -172,7 +170,7 @@ subroutine mpp_sync_self( pelist, check, request, msg_size, msg_type) integer, intent(in ), optional :: msg_size(:) integer, intent(in ), optional :: msg_type(:) - integer :: i, m, n, stride, my_check, rsize + integer :: m, my_check, rsize if( debug .and. (current_clock.NE.0) )call SYSTEM_CLOCK(start_tick) my_check = EVENT_SEND diff --git a/mpp/include/system_clock.h b/mpp/include/system_clock.h index 5da0da6368..766d0e6911 100644 --- a/mpp/include/system_clock.h +++ b/mpp/include/system_clock.h @@ -33,13 +33,13 @@ subroutine system_clock_mpi( count, count_rate, count_max ) if(first_call_system_clock_mpi)then first_call_system_clock_mpi=.false. mpi_count0 = MPI_WTime() - mpi_tick_rate = 1.d0/MPI_WTick() + mpi_tick_rate = real(1.d0/MPI_WTick(), r8_kind) endif if( PRESENT(count) )then - count = (MPI_WTime()-mpi_count0)*mpi_tick_rate + count = int((MPI_WTime()-mpi_count0)*mpi_tick_rate, i8_kind) end if if( PRESENT(count_rate) )then - count_rate = mpi_tick_rate + count_rate = int(mpi_tick_rate, i8_kind) end if if( PRESENT(count_max) )then count_max = maxtick-1 diff --git a/mpp/mpp.F90 b/mpp/mpp.F90 index f0cd18948d..cb822d9827 100644 --- a/mpp/mpp.F90 +++ b/mpp/mpp.F90 @@ -187,7 +187,7 @@ module mpp_mod implicit none private - !--- public paramters ----------------------------------------------- + !--- public parameters ----------------------------------------------- public :: MPP_VERBOSE, MPP_DEBUG, ALL_PES, ANY_PE, NULL_PE, NOTE, WARNING, FATAL public :: MPP_CLOCK_SYNC, MPP_CLOCK_DETAILED, CLOCK_COMPONENT, CLOCK_SUBCOMPONENT public :: CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE, CLOCK_LOOP, CLOCK_INFRA @@ -202,9 +202,6 @@ module mpp_mod public :: mpp_init_test_clocks_init, mpp_init_test_datatype_list_init, mpp_init_test_logfile_init public :: mpp_init_test_read_namelist, mpp_init_test_etc_unit, mpp_init_test_requests_allocated - !--- public data from mpp_data_mod ------------------------------ -! public :: request - !--- public interface from mpp_util.h ------------------------------ public :: stdin, stdout, stderr, stdlog, lowercase, uppercase, mpp_error, mpp_error_state public :: mpp_set_warn_level, mpp_sync, mpp_sync_self, mpp_pe diff --git a/mpp/mpp_domains.F90 b/mpp/mpp_domains.F90 index acd4f6b3ea..182fce5de6 100644 --- a/mpp/mpp_domains.F90 +++ b/mpp/mpp_domains.F90 @@ -666,15 +666,13 @@ module mpp_domains_mod integer, parameter :: MAX_ADDRS=512 integer(i8_kind),dimension(MAX_ADDRS),save :: addrs_sorted=-9999 !< list of sorted local addresses integer, dimension(-1:MAX_ADDRS),save :: addrs_idx=-9999 !< index of address associated with d_comm - integer, dimension(MAX_ADDRS),save :: a_salvage=-9999 !< freed index list of addresses integer, save :: a_sort_len=0 !< length sorted memory list integer, save :: n_addrs=0 !< number of memory addresses used - integer(i8_kind), parameter :: ADDR2_BASE = int(Z'0000000000010000', kind=i8_kind) + integer(i8_kind), parameter :: ADDR2_BASE = 65536_i8_kind !< = 0x0000000000010000 integer, parameter :: MAX_ADDRS2=128 integer(i8_kind),dimension(MAX_ADDRS2),save :: addrs2_sorted=-9999 !< list of sorted local addresses integer, dimension(-1:MAX_ADDRS2),save :: addrs2_idx=-9999 !< index of addr2 associated with d_comm - integer, dimension(MAX_ADDRS2),save :: a2_salvage=-9999 !< freed indices of addr2 integer, save :: a2_sort_len=0 !< length sorted memory list integer, save :: n_addrs2=0 !< number of memory addresses used @@ -691,16 +689,15 @@ module mpp_domains_mod ! type(DomainCommunicator2D),dimension(MAX_FIELDS),save,target :: d_comm !< domain communicators type(DomainCommunicator2D),dimension(:),allocatable,save,target :: d_comm !< domain communicators integer, dimension(-1:MAX_FIELDS),save :: d_comm_idx=-9999 !< index of d_comm associated with sorted addresses - integer, dimension(MAX_FIELDS),save :: dc_salvage=-9999 !< freed indices of d_comm integer, save :: dc_sort_len=0 !< length sorted comm keys !! (=num active communicators) integer, save :: n_comm=0 !< number of communicators used ! integer(i8_kind), parameter :: GT_BASE=2**8 - integer(i8_kind), parameter :: GT_BASE = int(Z'0000000000000100', kind=i8_kind) + integer(i8_kind), parameter :: GT_BASE = 256_i8_kind !0x0000000000000100 ! integer(i8_kind), parameter :: KE_BASE=2**48 - integer(i8_kind), parameter :: KE_BASE = int(Z'0001000000000000', kind=i8_kind) + integer(i8_kind), parameter :: KE_BASE = 281474976710656_i8_kind !0x0001000000000000 integer(i8_kind) :: domain_cnt=0 @@ -1561,10 +1558,6 @@ module mpp_domains_mod module procedure mpp_pass_UG_to_SG_l4_3d end interface - -!!$ module procedure mpp_do_update_ad_i4_3d -!!$ end interface -! !> @ingroup mpp_domains_mod interface mpp_do_update_ad module procedure mpp_do_update_ad_r8_3d diff --git a/mpp/mpp_efp.F90 b/mpp/mpp_efp.F90 index fda6ee119d..892340f67e 100644 --- a/mpp/mpp_efp.F90 +++ b/mpp/mpp_efp.F90 @@ -257,8 +257,8 @@ function mpp_reproducing_sum_r4_2d(array, isr, ier, jsr, jer, EFP_sum, reproduci array_r8 = array - sum = mpp_reproducing_sum_r8_2d(array_r8, isr, ier, jsr, jer, EFP_sum, reproducing, & - overflow_check, err) + sum = real(mpp_reproducing_sum_r8_2d(array_r8, isr, ier, jsr, jer, EFP_sum, reproducing, & + overflow_check, err), r4_kind) return @@ -697,7 +697,7 @@ subroutine mpp_efp_list_sum_across_PEs(EFPs, nval, errors) do n=1,NUMINT ; EFPs(i)%v(n) = ints(n,i) ; enddo if (present(errors)) errors(i) = overflow_error if (overflow_error) then - write (mesg,'("mpp_efp_list_sum_across_PEs error at ",i6," val was ",ES12.6, ", prec_error = ",ES12.6)') & + write (mesg,'("mpp_efp_list_sum_across_PEs error at ",i6," val was ",ES13.6, ", prec_error = ",ES13.6)') & i, mpp_efp_to_real(EFPs(i)), real(prec_error) if(mpp_pe()==mpp_root_pe()) call mpp_error(WARNING, mesg) endif diff --git a/mpp/mpp_parameter.F90 b/mpp/mpp_parameter.F90 index 5ea11577a4..c5a2000531 100644 --- a/mpp/mpp_parameter.F90 +++ b/mpp/mpp_parameter.F90 @@ -123,11 +123,11 @@ module mpp_parameter_mod integer, parameter :: ZERO=0, NINETY=90, MINUS_NINETY=-90, ONE_HUNDRED_EIGHTY=180 integer, parameter :: NONBLOCK_UPDATE_TAG = 2 -! DOMAIN_ID_BASE acts as a counter increment for domains as they are defined. It's used in -! combination with the flag parameter defined above to create a unique identifier for -! each Domain+flags combination. Therefore, the value of any flag must not exceed DOMAIN_ID_BASE. -! integer(i8_kind), parameter :: DOMAIN_ID_BASE=INT( 2**(4*i8_kind),KIND=i8_kind ) - integer(i8_kind), parameter :: DOMAIN_ID_BASE = int(Z'0000000100000000', kind=i8_kind) +!> @var DOMAIN_ID_BASE acts as a counter increment for domains as they are defined. It's used in +!! combination with the flag parameter defined above to create a unique identifier for +!! each Domain+flags combination. Therefore, the value of any flag must not exceed DOMAIN_ID_BASE. +!! integer(i8_kind), parameter :: DOMAIN_ID_BASE=INT( 2**(4*i8_kind),KIND=i8_kind ) + integer(i8_kind), parameter :: DOMAIN_ID_BASE = 4294967296_i8_kind !! =(0x100000000) integer, parameter :: NON_BITWISE_EXACT_SUM=0 integer, parameter :: BITWISE_EXACT_SUM=1 integer, parameter :: BITWISE_EFP_SUM=2 diff --git a/mpp/mpp_pset.F90 b/mpp/mpp_pset.F90 index a23d75d19c..3bab87ef98 100644 --- a/mpp/mpp_pset.F90 +++ b/mpp/mpp_pset.F90 @@ -460,9 +460,9 @@ subroutine mpp_pset_print_chksum_1D(pset, caller, array) type(mpp_pset_type), intent(in) :: pset character(len=*), intent(in) :: caller real, intent(in) :: array(:) - integer :: errunit #ifdef PSET_DEBUG + integer :: errunit logical :: do_print integer(LONG_KIND) :: chksum diff --git a/mpp/mpp_utilities.F90 b/mpp/mpp_utilities.F90 index f0313fbeb0..de9f23326f 100644 --- a/mpp/mpp_utilities.F90 +++ b/mpp/mpp_utilities.F90 @@ -29,6 +29,7 @@ !> @{ module mpp_utilities_mod +implicit none !----------------------------------------------------------------------- ! Include variable "version" to be written to log file. #include @@ -58,19 +59,16 @@ subroutine mpp_array_global_min_max(in_array, tmask,isd,jsd,isc,iec,jsc,jec,nk, use mpp_mod, only: mpp_min, mpp_max, mpp_pe, mpp_sum + integer, intent(in) :: isd,jsd,isc,iec,jsc,jec,nk real, dimension(isd:,jsd:,:), intent(in) :: in_array real, dimension(isd:,jsd:,:), intent(in) :: tmask - integer, intent(in) :: isd,jsd,isc,iec,jsc,jec,nk real, intent(out):: g_min, g_max real, dimension(isd:,jsd:), intent(in) :: geo_x,geo_y real, dimension(:), intent(in) :: geo_z real, intent(out):: xgmin, ygmin, zgmin, xgmax, ygmax, zgmax - - real :: tmax, tmin, tmax0, tmin0 integer :: itmax, jtmax, ktmax, itmin, jtmin, ktmin - integer :: igmax, jgmax, kgmax, igmin, jgmin, kgmin real :: fudge ! arrays to enable vectorization diff --git a/random_numbers/random_numbers.F90 b/random_numbers/random_numbers.F90 index 0260eb6d81..f545e88320 100644 --- a/random_numbers/random_numbers.F90 +++ b/random_numbers/random_numbers.F90 @@ -86,7 +86,7 @@ subroutine getRandomNumber_Scalar(stream, number) type(randomNumberStream), intent(inout) :: stream real, intent( out) :: number - number = getRandomReal(stream%theNumbers) + number = real(getRandomReal(stream%theNumbers)) end subroutine getRandomNumber_Scalar ! --------------------------------------------------------- !> Draws random 1D array @@ -98,7 +98,7 @@ subroutine getRandomNumber_1D(stream, numbers) integer :: i do i = 1, size(numbers) - numbers(i) = getRandomReal(stream%theNumbers) + numbers(i) = real(getRandomReal(stream%theNumbers)) end do end subroutine getRandomNumber_1D ! --------------------------------------------------------- diff --git a/time_interp/time_interp.F90 b/time_interp/time_interp.F90 index c3106a1449..0e8b434add 100644 --- a/time_interp/time_interp.F90 +++ b/time_interp/time_interp.F90 @@ -302,7 +302,7 @@ subroutine time_interp_frac ( Time, weight ) Year_beg = set_date(year , 1, 1) Year_end = set_date(year+1, 1, 1) - weight = (Time - Year_beg) // (Year_end - Year_beg) + weight = real( (Time - Year_beg) // (Year_end - Year_beg) ) end subroutine time_interp_frac @@ -356,13 +356,13 @@ subroutine time_interp_year ( Time, weight, year1, year2 ) year1 = year year2 = year+1 Mid_year2 = year_midpt(year2) - weight = (Time - Mid_year) // (Mid_year2 - Mid_year) + weight = real( (Time - Mid_year) // (Mid_year2 - Mid_year) ) else ! current time is before mid point of current year year2 = year year1 = year-1 Mid_year1 = year_midpt(year1) - weight = (Time - Mid_year1) // (Mid_year - Mid_year1) + weight = real( (Time - Mid_year1) // (Mid_year - Mid_year1) ) endif end subroutine time_interp_year @@ -655,14 +655,14 @@ subroutine time_interp_modulo(Time, Time_beg, Time_end, Timelist, weight, index1 if( T>=Timelist(ie) ) then ! time is after the end of the portion of the time list within the requested period index1 = ie; index2 = is - weight = (T-Timelist(ie))//(Period-(Timelist(ie)-Timelist(is))) + weight = real( (T-Timelist(ie))//(Period-(Timelist(ie)-Timelist(is))) ) else if (T= Ts .and. T < Te ) then call bisect(Timelist(1:n),T,index1,index2) - weight = (T-Timelist(index1)) // (Timelist(index2)-Timelist(index1)) + weight = real( (T-Timelist(index1)) // (Timelist(index2)-Timelist(index1)) ) ! time falls before starting list value else if ( T < Ts ) then @@ -799,7 +799,7 @@ subroutine time_interp_list ( Time, Timelist, weight, index1, index2, modtime, e deallocate(terr,tserr,teerr) endif Td = Te-Ts - weight = 1. - ((Ts-T) // (Period-Td)) + weight = real( 1. - ((Ts-T) // (Period-Td)) ) index1 = n index2 = 1 @@ -832,7 +832,7 @@ subroutine time_interp_list ( Time, Timelist, weight, index1, index2, modtime, e deallocate(terr,tserr,teerr) endif Td = Te-Ts - weight = (T-Te) // (Period-Td) + weight = real( (T-Te) // (Period-Td) ) index1 = n index2 = 1 endif diff --git a/time_interp/time_interp_external.F90 b/time_interp/time_interp_external.F90 index accb070498..885cdbcf33 100644 --- a/time_interp/time_interp_external.F90 +++ b/time_interp/time_interp_external.F90 @@ -1011,7 +1011,7 @@ subroutine load_record(field, rec, interp, is_in, ie_in, js_in, je_in, window_id ! ---- local vars integer :: ib ! index in the array of input buffers integer :: isw,iew,jsw,jew ! boundaries of the domain on each window - integer :: is_region, ie_region, js_region, je_region, i, j, n + integer :: is_region, ie_region, js_region, je_region, i, j integer :: start(4), nread(4) logical :: need_compute real :: mask_in(size(field%src_data,1),size(field%src_data,2),size(field%src_data,3)) @@ -1321,7 +1321,6 @@ end function get_external_field_size function get_external_field_missing(index) integer :: index - real :: missing real :: get_external_field_missing if (index .lt. 1 .or. index .gt. num_fields) & diff --git a/time_interp/time_interp_external2.F90 b/time_interp/time_interp_external2.F90 index 1c113dcd44..e3be601c90 100644 --- a/time_interp/time_interp_external2.F90 +++ b/time_interp/time_interp_external2.F90 @@ -172,7 +172,7 @@ module time_interp_external2_mod !> @brief Initialize the @ref time_interp_external_mod module subroutine time_interp_external_init() - integer :: ioun, io_status, logunit, ierr + integer :: io_status, logunit, ierr namelist /time_interp_external_nml/ num_io_buffers, debug_this_module, & max_fields, max_files @@ -282,7 +282,7 @@ function init_external_field(file,fieldname,domain,desired_units,& integer :: init_external_field real(DOUBLE_KIND) :: slope, intercept - integer :: unit,ndim,nvar,natt,ntime,i,j + integer :: ndim,ntime,i,j integer :: iscomp,iecomp,jscomp,jecomp,isglobal,ieglobal,jsglobal,jeglobal integer :: isdata,iedata,jsdata,jedata, dxsize, dysize,dxsize_max,dysize_max logical :: verb, transpose_xy,use_comp_domain1 @@ -290,7 +290,7 @@ function init_external_field(file,fieldname,domain,desired_units,& character(len=1) :: cart character(len=1), dimension(4) :: cart_dir character(len=128) :: units, fld_units - character(len=128) :: name, msg, calendar_type, timebeg, timeend + character(len=128) :: msg, calendar_type, timebeg, timeend character(len=128) :: timename, timeunits character(len=128), allocatable :: axisname(:) integer, allocatable :: axislen(:) @@ -1036,7 +1036,7 @@ subroutine load_record(field, rec, interp, is_in, ie_in, js_in, je_in, window_id ! ---- local vars integer :: ib ! index in the array of input buffers integer :: isw,iew,jsw,jew ! boundaries of the domain on each window - integer :: is_region, ie_region, js_region, je_region, i, j, n + integer :: is_region, ie_region, js_region, je_region, i, j integer :: start(4), nread(4) logical :: need_compute real :: mask_in(size(field%src_data,1),size(field%src_data,2),size(field%src_data,3)) @@ -1342,7 +1342,6 @@ end function get_external_field_size function get_external_field_missing(index) integer :: index - real :: missing real :: get_external_field_missing if (index .lt. 1 .or. index .gt. num_fields) & @@ -1378,7 +1377,7 @@ subroutine get_time_axis(index, time) subroutine time_interp_external_exit() - integer :: i,j + integer :: i ! ! release storage arrays ! diff --git a/time_manager/get_cal_time.F90 b/time_manager/get_cal_time.F90 index 6b6848fcc0..bfb44963a2 100644 --- a/time_manager/get_cal_time.F90 +++ b/time_manager/get_cal_time.F90 @@ -160,14 +160,13 @@ function get_cal_time(time_increment, units, calendar, permit_calendar_conversio logical, intent(in), optional :: permit_calendar_conversion type(time_type) :: get_cal_time integer :: year, month, day, hour, minute, second -integer :: i1, i2, i3, i4, i5, i6, increment_seconds, increment_days, increment_years, increment_months +integer :: i1, increment_seconds, increment_days, increment_years, increment_months real :: month_fraction integer :: calendar_tm_i, calendar_in_i, ierr, io, logunit logical :: correct_form character(len=32) :: calendar_in_c character(len=64) :: err_msg -character(len=4) :: formt='(i )' -type(time_type) :: base_time, base_time_plus_one_yr, base_time_plus_one_mo +type(time_type) :: base_time, base_time_plus_one_yr real :: dt logical :: permit_conversion_local @@ -285,16 +284,16 @@ function get_cal_time(time_increment, units, calendar, permit_calendar_conversio if(lowercase(units(1:10)) == 'days since') then increment_days = floor(time_increment) - increment_seconds = 86400*(time_increment - increment_days) + increment_seconds = int(86400*(time_increment - increment_days)) else if(lowercase(units(1:11)) == 'hours since') then increment_days = floor(time_increment/24) - increment_seconds = 86400*(time_increment/24 - increment_days) + increment_seconds = int(86400*(time_increment/24 - increment_days)) else if(lowercase(units(1:13)) == 'minutes since') then increment_days = floor(time_increment/1440) - increment_seconds = 86400*(time_increment/1440 - increment_days) + increment_seconds = int(86400*(time_increment/1440 - increment_days)) else if(lowercase(units(1:13)) == 'seconds since') then increment_days = floor(time_increment/86400) - increment_seconds = 86400*(time_increment/86400 - increment_days) + increment_seconds = int(86400*(time_increment/86400 - increment_days)) else if(lowercase(units(1:11)) == 'years since') then ! The time period between between (base_time + time_increment) and ! (base_time + time_increment + 1 year) may be 360, 365, or 366 days. @@ -305,7 +304,7 @@ function get_cal_time(time_increment, units, calendar, permit_calendar_conversio call get_time(base_time_plus_one_yr - base_time, second, day) dt = (day*86400+second)*(time_increment-floor(time_increment)) increment_days = floor(dt/86400) - increment_seconds = dt - increment_days*86400 + increment_seconds = int(dt - increment_days*86400) else if(lowercase(units(1:12)) == 'months since') then month_fraction = time_increment - floor(time_increment) increment_years = floor(time_increment/12) @@ -314,7 +313,7 @@ function get_cal_time(time_increment, units, calendar, permit_calendar_conversio base_time = set_date(year+increment_years,month+increment_months ,day,hour,minute,second) dt = 86400*days_in_month(base_time) * month_fraction increment_days = floor(dt/86400) - increment_seconds = dt - increment_days*86400 + increment_seconds = int(dt - increment_days*86400) else call error_mesg('get_cal_time','"'//trim(units)//'"'//' is not an acceptable units attribute of time.'// & ' It must begin with: "years since", "months since", "days since", "hours since", "minutes since", or "seconds since"',FATAL) diff --git a/time_manager/time_manager.F90 b/time_manager/time_manager.F90 index b77355ced1..312e31006c 100644 --- a/time_manager/time_manager.F90 +++ b/time_manager/time_manager.F90 @@ -995,9 +995,9 @@ function time_scalar_mult(time, n) ! ticks could be up to ticks_per_second-1 tick_prod = dble(time%ticks) * dble(n) -num_sec = tick_prod/dble(ticks_per_second) +num_sec = int(tick_prod/dble(ticks_per_second)) sec_prod = dble(time%seconds) * dble(n) + num_sec -ticks = tick_prod - num_sec * ticks_per_second +ticks = int(tick_prod - num_sec * ticks_per_second) ! If sec_prod is large compared to precision of double precision, things ! can go bad. Need to warn and abort on this. @@ -1009,8 +1009,8 @@ function time_scalar_mult(time, n) 'Insufficient precision to handle scalar product in time_scalar_mult; contact developer',FATAL) end if -days = sec_prod / dble(seconds_per_day) -seconds = sec_prod - dble(days) * dble(seconds_per_day) +days = int(sec_prod / dble(seconds_per_day)) +seconds = int(sec_prod - dble(days) * dble(seconds_per_day)) time_scalar_mult = set_time(seconds, time%days * n + days, ticks) @@ -1087,7 +1087,7 @@ function time_divide(time1, time2) d2 = time2%days * dble(seconds_per_day) + dble(time2%seconds) + time2%ticks/dble(ticks_per_second) ! Get integer quotient of this, check carefully to avoid round-off problems. -time_divide = d1 / d2 +time_divide = int(d1 / d2) ! Verify time_divide*time2 is <= time1 and (time_divide + 1)*time2 is > time1 if(time_divide * time2 > time1 .or. (time_divide + 1) * time2 <= time1) & @@ -1193,8 +1193,8 @@ function time_type_to_real(time) if(.not.module_is_initialized) call time_manager_init -time_type_to_real = dble(time%days) * 86400.d0 + dble(time%seconds) + & - dble(time%ticks)/dble(ticks_per_second) +time_type_to_real = real(dble(time%days) * 86400.d0 + dble(time%seconds) + & + dble(time%ticks)/dble(ticks_per_second), kind=r8_kind) end function time_type_to_real @@ -1293,9 +1293,9 @@ function time_scalar_divide(time, n) d = time%days*dseconds_per_day*dticks_per_second + dble(time%seconds)*dticks_per_second + dble(time%ticks) div = d/dble(n) -days = div/(dseconds_per_day*dticks_per_second) -seconds = div/dticks_per_second - days*dseconds_per_day -ticks = div - (days*dseconds_per_day + dble(seconds))*dticks_per_second +days = int(div/(dseconds_per_day*dticks_per_second)) +seconds = int(div/dticks_per_second - days*dseconds_per_day) +ticks = int(div - (days*dseconds_per_day + dble(seconds))*dticks_per_second) time_scalar_divide = set_time(seconds, days, ticks) ! Need to make sure that roundoff isn't killing this @@ -1463,8 +1463,6 @@ subroutine set_calendar_type(type, err_msg) integer, intent(in) :: type character(len=*), intent(out), optional :: err_msg -integer :: iday, days_this_month, year, month, day -logical :: leap character(len=256) :: err_msg_local if(.not.module_is_initialized) call time_manager_init() @@ -2927,11 +2925,8 @@ end function length_of_year_thirty function length_of_year_gregorian() type(time_type) :: length_of_year_gregorian -integer :: days, seconds -days = days_in_400_year_period / 400 -seconds = 86400*(days_in_400_year_period/400. - days) -length_of_year_gregorian = set_time(seconds, days) +length_of_year_gregorian = set_time(20952, 365) !20952 = 86500 * (days_in_400_yrs/400. - (days_in_400_yrs/400)) end function length_of_year_gregorian @@ -2941,7 +2936,7 @@ function length_of_year_julian() type(time_type) :: length_of_year_julian -length_of_year_julian = set_time((24 / 4) * 60 * 60, 365) +length_of_year_julian = set_time(21600, 365) !21600 = (24/4) * 60 * 60 end function length_of_year_julian @@ -2977,7 +2972,7 @@ function day_of_year(time) ! START OF days_in_year BLOCK ! -!> @brief Retruns the number of days in the calendar year corresponding to the date represented by +!> @brief Returns the number of days in the calendar year corresponding to the date represented by !! time for the default calendar. !> @returns The number of days in this year for the default calendar type. function days_in_year(Time) diff --git a/topography/gaussian_topog.F90 b/topography/gaussian_topog.F90 index fb1fd7922c..84b0443e04 100644 --- a/topography/gaussian_topog.F90 +++ b/topography/gaussian_topog.F90 @@ -216,7 +216,6 @@ end function get_gaussian_topog subroutine read_namelist integer :: unit, ierr, io - real :: dtr !> read namelist diff --git a/topography/topography.F90 b/topography/topography.F90 index 8e17af5762..e97d14e9f9 100644 --- a/topography/topography.F90 +++ b/topography/topography.F90 @@ -749,7 +749,6 @@ end subroutine find_indices subroutine input_data ( indx, xdat, ydat, zdat ) integer, intent(in) :: indx real, intent(out) :: xdat(ipts+1), ydat(jpts+1), zdat(ipts,jpts) - integer :: nc if( file_is_opened(indx) ) then call read_data(fileobj(indx), 'xdat', xdat) diff --git a/tracer_manager/tracer_manager.F90 b/tracer_manager/tracer_manager.F90 index 79ea8ac623..6add5c33e9 100644 --- a/tracer_manager/tracer_manager.F90 +++ b/tracer_manager/tracer_manager.F90 @@ -96,7 +96,8 @@ module tracer_manager_mod adjust_mass, & adjust_positive_def, & NO_TRACER, & - MAX_TRACER_FIELDS + MAX_TRACER_FIELDS, & + set_tracer_method !> @brief Function which returns the number assigned to the tracer name. !! @@ -836,10 +837,6 @@ subroutine print_tracer_info(model,n) write(log_unit, *)'----------------------------------------------------' endif -900 FORMAT(A,2(1x,E12.6)) -901 FORMAT(E12.6,1x,E12.6) - - end subroutine print_tracer_info !####################################################################### @@ -1122,7 +1119,7 @@ subroutine set_tracer_profile(model, n, tracer, err_msg) if (mpp_pe() == mpp_root_pe() ) write(*,700) 'Tracer ',trim(tracers(n1)%tracer_name), & ' initialized with surface value of ',surf_value, & ' and vertical multiplier of ',multiplier - 700 FORMAT (3A,E12.6,A,F10.6) + 700 FORMAT (3A,E13.6,A,F13.6) endif ! end of query scheme