diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index a76d37cd6e..7d2af296e0 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -305,7 +305,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & do j=js-2,je+2 ; do i=is-2,ie+2 fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) - enddo; enddo + enddo ; enddo if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) @@ -353,7 +353,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice do j=js,je ; do i=is,ie if (sfc_state%SST(i,j) <= -0.0539*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 - enddo; enddo + enddo ; enddo endif if (CS%salt_restore_as_sflux) then do j=js,je ; do i=is,ie @@ -361,7 +361,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! kg Salt m-2 s-1 - enddo; enddo + enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl) @@ -382,7 +382,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & (CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif - enddo; enddo + enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl) @@ -392,7 +392,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo endif endif endif @@ -536,12 +536,12 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl) do j=js,je ; do i=is,ie fluxes%vprec(i,j) = fluxes%vprec(i,j) + (net_FW2(i,j) - net_FW(i,j)/G%areaT(i,j)) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo else fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo endif endif diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index dca6b8a837..395a4d3abb 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -1079,9 +1079,9 @@ subroutine ocean_model_data2D_get(OS,Ocean, name, array2D,isc,jsc) case('mask') array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) !OR same result -! do j=g_jsc,g_jec; do i=g_isc,g_iec +! do j=g_jsc,g_jec ; do i=g_isc,g_iec ! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) -! enddo; enddo +! enddo ; enddo case('t_surf') array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET case('t_pme') diff --git a/config_src/ice_solo_driver/coupler_types.F90 b/config_src/ice_solo_driver/coupler_types.F90 index a57d2dd37e..99a74e085c 100644 --- a/config_src/ice_solo_driver/coupler_types.F90 +++ b/config_src/ice_solo_driver/coupler_types.F90 @@ -68,7 +68,8 @@ module coupler_types_mod type, public :: coupler_3d_bc_type integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_3d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary condition fields + type(coupler_3d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary + !! condition fields logical :: set = .false. !< If true, this type has been initialized integer :: isd, isc, iec, ied !< The i-direction data and computational domain index ranges for this type integer :: jsd, jsc, jec, jed !< The j-direction data and computational domain index ranges for this type @@ -115,7 +116,8 @@ module coupler_types_mod type, public :: coupler_2d_bc_type integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_2d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary condition fields + type(coupler_2d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary + !! condition fields logical :: set = .false. !< If true, this type has been initialized integer :: isd, isc, iec, ied !< The i-direction data and computational domain index ranges for this type integer :: jsd, jsc, jec, jed !< The j-direction data and computational domain index ranges for this type @@ -156,7 +158,8 @@ module coupler_types_mod type, public :: coupler_1d_bc_type integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_1d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary condition fields + type(coupler_1d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary + !! condition fields logical :: set = .false. !< If true, this type has been initialized end type coupler_1d_bc_type @@ -291,7 +294,8 @@ subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je, & integer, intent(in) :: ie !< upper bound of first dimension integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then + !! don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique @@ -310,7 +314,7 @@ subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je, & if (var_in%num_bcs >= 0) & call CT_spawn_1d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_2d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_1d_2d @@ -340,7 +344,8 @@ subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, & integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then + !! don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique @@ -360,7 +365,7 @@ subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, & if (var_in%num_bcs >= 0) & call CT_spawn_1d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_3d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_1d_3d @@ -383,7 +388,8 @@ subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je, & integer, intent(in) :: ie !< upper bound of first dimension integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique @@ -402,7 +408,7 @@ subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je, & if (var_in%num_bcs >= 0) & call CT_spawn_2d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_2d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_2d_2d @@ -432,7 +438,8 @@ subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd, & integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique @@ -452,7 +459,7 @@ subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd, & if (var_in%num_bcs >= 0) & call CT_spawn_2d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_3d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_2d_3d @@ -475,7 +482,8 @@ subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je, & integer, intent(in) :: ie !< upper bound of first dimension integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique @@ -494,7 +502,7 @@ subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je, & if (var_in%num_bcs >= 0) & call CT_spawn_3d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_2d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_3d_2d @@ -524,7 +532,8 @@ subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd, & integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique @@ -544,7 +553,7 @@ subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd, & if (var_in%num_bcs >= 0) & call CT_spawn_3d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_3d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_3d_3d @@ -1174,8 +1183,10 @@ subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this copy. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this copy. logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose !! value of pass_through ice matches this logical :: copy_bc @@ -1249,8 +1260,10 @@ subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this copy. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this copy. logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose !! value of pass_through ice matches this logical :: copy_bc @@ -1329,8 +1342,10 @@ subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this copy. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this copy. logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose !! value of pass_through ice matches this integer, optional, intent(in) :: ind3_start !< The starting value of the 3rd @@ -1563,8 +1578,10 @@ subroutine CT_rescale_data_2d(var, scale, halo_size, bc_index, field_index, & !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this copy. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this copy. logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose !! value of pass_through ice matches this logical :: do_bc @@ -1640,8 +1657,10 @@ subroutine CT_rescale_data_3d(var, scale, halo_size, bc_index, field_index, & !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this copy. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this copy. logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose !! value of pass_through ice matches this logical :: do_bc @@ -1718,8 +1737,10 @@ subroutine CT_increment_data_2d_2d(var_in, var, halo_size, bc_index, field_index !! boundary condition that is being copied real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this increment. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose !! value of pass_through ice matches this @@ -1802,8 +1823,10 @@ subroutine CT_increment_data_3d_3d(var_in, var, halo_size, bc_index, field_index !! boundary condition that is being copied real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this increment. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose !! value of pass_through ice matches this @@ -1893,8 +1916,10 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi !! boundary condition that is being copied real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this increment. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose !! value of pass_through ice matches this @@ -1946,7 +1971,8 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi elseif ((1+var_in%ied-var_in%isd) == size(weights,1)) then iow = 1 + (var_in%isc - var_in%isd) - var%isc else - call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the i-size of a computational or data domain.") + call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the i-size "//& + "of a computational or data domain.") endif if ((1+var%jec-var%jsc) == size(weights,2)) then jow = 1 - var%jsc @@ -1955,7 +1981,8 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi elseif ((1+var_in%jed-var_in%jsd) == size(weights,2)) then jow = 1 + (var_in%jsc - var_in%jsd) - var%jsc else - call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the j-size of a computational or data domain.") + call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the j-size "//& + "of a computational or data domain.") endif io1 = var_in%isc - var%isc ; jo1 = var_in%jsc - var%jsc ; kow = 1 - var_in%ks @@ -2720,7 +2747,8 @@ end subroutine CT_set_data_3d !> This routine registers the diagnostics of a coupler_2d_bc_type. subroutine CT_set_diags_2d(var, diag_name, axes, time) type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field @@ -2746,7 +2774,8 @@ end subroutine CT_set_diags_2d !> This routine registers the diagnostics of a coupler_3d_bc_type. subroutine CT_set_diags_3d(var, diag_name, axes, time) type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field @@ -3106,9 +3135,9 @@ end subroutine CT_restore_state_3d !> This subroutine potentially overrides the values in a coupler_2d_bc_type subroutine CT_data_override_2d(gridname, var, Time) - character(len=3), intent(in) :: gridname !< 3-character long model grid ID - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to override - type(time_type), intent(in) :: time !< The current model time + character(len=3), intent(in) :: gridname !< 3-character long model grid ID + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override + type(time_type), intent(in) :: time !< The current model time integer :: m, n @@ -3120,9 +3149,9 @@ end subroutine CT_data_override_2d !> This subroutine potentially overrides the values in a coupler_3d_bc_type subroutine CT_data_override_3d(gridname, var, Time) - character(len=3), intent(in) :: gridname !< 3-character long model grid ID - type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to override - type(time_type), intent(in) :: time !< The current model time + character(len=3), intent(in) :: gridname !< 3-character long model grid ID + type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to override + type(time_type), intent(in) :: time !< The current model time integer :: m, n diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 index 628b138639..7bfc7ec5ad 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/ice_solo_driver/ice_shelf_driver.F90 @@ -265,7 +265,8 @@ program SHELF_main Time_end = daymax endif - if (is_root_pe()) print *,"Time_step_shelf", time_type_to_real(Time_step_shelf), "TIme_end", time_type_to_real(Time_end) + if (is_root_pe()) print *,"Time_step_shelf", time_type_to_real(Time_step_shelf), & + "TIme_end", time_type_to_real(Time_end) if (Time >= Time_end) call MOM_error(FATAL, & "MOM_driver: The run has been started at or after the end time of the run.") diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 index 098931351c..6a70999d50 100644 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ b/config_src/ice_solo_driver/user_surface_forcing.F90 @@ -22,8 +22,8 @@ module user_surface_forcing !* * !* USER_buoyancy forcing is used to set the surface buoyancy * !* forcing, which may include a number of fresh water flux fields * -!* (evap, liq_precip, froz_precip, liq_runoff, froz_runoff, and * -!* virt_precip) and the surface heat fluxes (sw, lw, latent and sens) * +!* (evap, lprec, fprec, lrunoff, frunoff, and * +!* vprec) and the surface heat fluxes (sw, lw, latent and sens) * !* if temperature and salinity are state variables, or it may simply * !* be the buoyancy flux if it is not. This routine also has coded a * !* restoring to surface values of temperature and salinity. * @@ -44,13 +44,14 @@ module user_surface_forcing !* * !********+*********+*********+*********+*********+*********+*********+** use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, param_file_type, log_version use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, MOM_read_data +use MOM_io, only : file_exists, read_data use MOM_time_manager, only : time_type, operator(+), operator(/), get_time use MOM_tracer_flow_control, only : call_tracer_set_forcing use MOM_tracer_flow_control, only : tracer_flow_control_CS @@ -84,14 +85,17 @@ module user_surface_forcing contains +!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy. +!! These are the stresses in the direction of the model grid (i.e. the same +!! direction as the u- and v- velocities.) They are both in Pa. subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by - !! a previous call to user_surface_forcing_init + type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to user_surface_forcing_init ! This subroutine sets the surface wind stresses, forces%taux and forces%tauy. ! These are the stresses in the direction of the model grid (i.e. the same @@ -121,6 +125,9 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + ! Allocate the forcing arrays, if necessary. + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) + ! Set the surface wind stresses, in units of Pa. A positive taux ! accelerates the ocean to the (pseudo-)east. @@ -144,15 +151,19 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) end subroutine USER_wind_forcing +!> This subroutine specifies the current surface fluxes of buoyancy or +!! temperature and fresh water. It may also be modified to add +!! surface fluxes of user provided tracers. subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + !! describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which !! the fluxes apply, in s type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(user_surface_forcing_CS), pointer :: CS + type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to user_surface_forcing_init ! This subroutine specifies the current surface fluxes of buoyancy or ! temperature and fresh water. It may also be modified to add @@ -161,9 +172,9 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! When temperature is used, there are long list of fluxes that need to be ! set - essentially the same as for a full coupled model, but most of these ! can be simply set to zero. The net fresh water flux should probably be -! set in fluxes%evap and fluxes%liq_precip, with any salinity restoring -! appearing in fluxes%virt_precip, and the other water flux components -! (froz_precip, liq_runoff and froz_runoff) left as arrays full of zeros. +! set in fluxes%evap and fluxes%lprec, with any salinity restoring +! appearing in fluxes%vprec, and the other water flux components +! (fprec, lrunoff and frunoff) left as arrays full of zeros. ! Evap is usually negative and precip is usually positive. All heat fluxes ! are in W m-2 and positive for heat going into the ocean. All fresh water ! fluxes are in kg m-2 s-1 and positive for water moving into the ocean. @@ -201,19 +212,19 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! Allocate and zero out the forcing arrays, as necessary. This portion is ! usually not changed. if (CS%use_temperature) then - call alloc_if_needed(fluxes%evap, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%liq_precip, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%froz_precip, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%liq_runoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%froz_runoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%virt_precip, isd, ied, jsd, jed) - - call alloc_if_needed(fluxes%sw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%latent, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%sens, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) + + call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) else ! This is the buoyancy only mode. - call alloc_if_needed(fluxes%buoy, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) endif @@ -226,10 +237,10 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! Fluxes of fresh water through the surface are in units of kg m-2 s-1 ! and are positive downward - i.e. evaporation should be negative. fluxes%evap(i,j) = -0.0 * G%mask2dT(i,j) - fluxes%liq_precip(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%lprec(i,j) = 0.0 * G%mask2dT(i,j) - ! virt_precip will be set later, if it is needed for salinity restoring. - fluxes%virt_precip(i,j) = 0.0 + ! vprec will be set later, if it is needed for salinity restoring. + fluxes%vprec(i,j) = 0.0 ! Heat fluxes are in units of W m-2 and are positive into the ocean. fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) @@ -247,7 +258,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) if (CS%restorebuoy) then if (CS%use_temperature) then - call alloc_if_needed(fluxes%heat_restore, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) ! When modifying the code, comment out this error message. It is here ! so that the original (unmodified) version is not accidentally used. call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & @@ -260,9 +271,9 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) Temp_restore = 0.0 Salin_restore = 0.0 - fluxes%heat_restore(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & + fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) - fluxes%virt_precip(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & ((Salin_restore - sfc_state%SSS(i,j)) / & (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo @@ -287,24 +298,15 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) end subroutine USER_buoyancy_forcing -subroutine alloc_if_needed(ptr, isd, ied, jsd, jed) - ! If ptr is not associated, this routine allocates it with the given size - ! and zeros out its contents. This is equivalent to safe_alloc_ptr in - ! MOM_diag_mediator, but is here so as to be completely transparent. - real, pointer :: ptr(:,:) - integer :: isd, ied, jsd, jed - if (.not.associated(ptr)) then - allocate(ptr(isd:ied,jsd:jed)) - ptr(:,:) = 0.0 - endif -end subroutine alloc_if_needed - +!> This subroutine initializes the USER_surface_forcing module subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) - type(time_type), intent(in) :: Time + type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag - type(user_surface_forcing_CS), pointer :: CS + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. + type(user_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to + !! the control structure for this module + ! Arguments: Time - The current model time. ! (in) G - The ocean's grid structure. ! (in) param_file - A structure indicating the open file to parse for @@ -330,18 +332,20 @@ subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & "If true, Temperature and salinity are used as state \n"//& "variables.", default=.true.) + call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80) - call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to \n"//& "calculate accelerations and the mass for conservation \n"//& "properties, or with BOUSSINSEQ false to convert some \n"//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) + call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & + "The background gustiness in the winds.", units="Pa", & + default=0.02) + call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back \n"//& "toward some specified surface state with a rate \n"//& diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index 354e309ed9..c3967caf6d 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -1622,7 +1622,8 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) glb%ocn_state%dirs%restart_output_dir, .true.) ! Once we start using the ice shelf module, the following will be needed if (glb%ocn_state%use_ice_shelf) then - call ice_shelf_save_restart(glb%ocn_state%Ice_shelf_CSp, glb%ocn_state%Time, glb%ocn_state%dirs%restart_output_dir, .true.) + call ice_shelf_save_restart(glb%ocn_state%Ice_shelf_CSp, glb%ocn_state%Time, & + glb%ocn_state%dirs%restart_output_dir, .true.) endif endif @@ -1732,7 +1733,8 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & ! GMM, check ocean_model_MOM.F90 to enable the following option !if (OS%icebergs_apply_rigid_boundary) then ! This assumes that the iceshelf and ocean are on the same grid. I hope this is true. - ! call add_berg_flux_to_shelf(OS%grid, OS%forces,OS%fluxes,OS%use_ice_shelf,OS%density_iceberg,OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, time_step, OS%berg_area_threshold) + ! call add_berg_flux_to_shelf(OS%grid, OS%forces,OS%fluxes,OS%use_ice_shelf,OS%density_iceberg, & + ! OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, time_step, OS%berg_area_threshold) !endif ! Indicate that there are new unused fluxes. @@ -1752,7 +1754,8 @@ subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & ! GMM, check ocean_model_MOM.F90 to enable the following option !if (OS%icebergs_apply_rigid_boundary) then !This assumes that the iceshelf and ocean are on the same grid. I hope this is true - ! call add_berg_flux_to_shelf(OS%grid, OS%forces, OS%flux_tmp, OS%use_ice_shelf,OS%density_iceberg,OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, time_step, OS%berg_area_threshold) + ! call add_berg_flux_to_shelf(OS%grid, OS%forces, OS%flux_tmp, OS%use_ice_shelf,OS%density_iceberg, & + ! OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, time_step, OS%berg_area_threshold) !endif ! Accumulate the forcing over time steps diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index 513358932e..578aa68a2a 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -44,7 +44,7 @@ module MESO_surface_forcing !* * !********+*********+*********+*********+*********+*********+*********+** use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type @@ -97,11 +97,13 @@ module MESO_surface_forcing contains +!### This subroutine sets zero surface wind stresses, but it is not even +!### used by the MESO experimeents. This subroutine can be deleted. -RWH subroutine MESO_wind_forcing(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(MESO_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a previous !! call to MESO_surface_forcing_init @@ -160,15 +162,18 @@ subroutine MESO_wind_forcing(sfc_state, forces, day, G, CS) end subroutine MESO_wind_forcing +!> This subroutine sets up the MESO buoyancy forcing, which uses control-theory style +!! specification restorative buoyancy fluxes at large scales. subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which !! the fluxes apply, in s type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(MESO_surface_forcing_CS), pointer :: CS + type(MESO_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by + !! a previous call to MESO_surface_forcing_init ! This subroutine specifies the current surface fluxes of buoyancy or ! temperature and fresh water. It may also be modified to add @@ -215,30 +220,30 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! Allocate and zero out the forcing arrays, as necessary. This portion is ! usually not changed. if (CS%use_temperature) then - call alloc_if_needed(fluxes%evap, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lprec, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%fprec, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lrunoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%frunoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%vprec, isd, ied, jsd, jed) - - call alloc_if_needed(fluxes%sw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%latent, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%sens, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%heat_content_lprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) + + call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%heat_content_lprec, isd, ied, jsd, jed) else ! This is the buoyancy only mode. - call alloc_if_needed(fluxes%buoy, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) endif ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. if (CS%restorebuoy .and. first_call) then !### .or. associated(CS%ctrl_forcing_CSp)) then - call alloc_if_needed(CS%T_Restore, isd, ied, jsd, jed) - call alloc_if_needed(CS%S_Restore, isd, ied, jsd, jed) - call alloc_if_needed(CS%Heat, isd, ied, jsd, jed) - call alloc_if_needed(CS%PmE, isd, ied, jsd, jed) - call alloc_if_needed(CS%Solar, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%T_Restore, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%S_Restore, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%Heat, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%PmE, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%Solar, isd, ied, jsd, jed) call MOM_read_data(trim(CS%inputdir)//trim(CS%SSTrestore_file), "SST", & CS%T_Restore(:,:), G%Domain) @@ -281,7 +286,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) if (CS%restorebuoy) then if (CS%use_temperature) then - call alloc_if_needed(fluxes%heat_added, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) ! When modifying the code, comment out this error message. It is here ! so that the original (unmodified) version is not accidentally used. ! call MOM_error(FATAL, "MESO_buoyancy_surface_forcing: " // & @@ -323,24 +328,16 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) end subroutine MESO_buoyancy_forcing -subroutine alloc_if_needed(ptr, isd, ied, jsd, jed) - ! If ptr is not associated, this routine allocates it with the given size - ! and zeros out its contents. This is equivalent to safe_alloc_ptr in - ! MOM_diag_mediator, but is here so as to be completely transparent. - real, pointer :: ptr(:,:) - integer :: isd, ied, jsd, jed - if (.not.associated(ptr)) then - allocate(ptr(isd:ied,jsd:jed)) - ptr(:,:) = 0.0 - endif -end subroutine alloc_if_needed - +!> Initialize the MESO surface forcing module subroutine MESO_surface_forcing_init(Time, G, param_file, diag, CS) - type(time_type), intent(in) :: Time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag - type(MESO_surface_forcing_CS), pointer :: CS + + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(inout) :: diag !< structure used to regulate diagnostic output + type(MESO_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module + ! Arguments: Time - The current model time. ! (in) G - The ocean's grid structure. ! (in) param_file - A structure indicating the open file to parse for diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 2727f42e1f..80a622b5ec 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -273,11 +273,11 @@ program MOM_main else calendar = uppercase(calendar) if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN - else if (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN - else if (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP - else if (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS - else if (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR - else if (calendar(1:1) /= ' ') then + elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN + elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP + elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS + elseif (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR + elseif (calendar(1:1) /= ' ') then call MOM_error(FATAL,'MOM_driver: Invalid namelist value '//trim(calendar)//' for calendar') else call MOM_error(FATAL,'MOM_driver: No namelist value for calendar') @@ -641,7 +641,7 @@ program MOM_main call get_date(Time, yr, mon, day, hr, mins, sec) write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & 'Current model time: year, month, day, hour, minute, second' - end if + endif call close_file(unit) endif diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 37bcaea17e..38ac1917a8 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -213,20 +213,23 @@ module MOM_surface_forcing end type surface_forcing_CS - integer :: id_clock_forcing contains +!> This subroutine calls other subroutines in this file to get surface forcing fields. +!! It also allocates and initializes the fields in the forcing and mech_forcing types +!! the first time it is called. subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day_start - type(time_type), intent(in) :: day_interval + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day_start !< The start time of the fluxes + type(time_type), intent(in) :: day_interval !< Length of time over which these fluxes applied type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine calls other subroutines in this file to get surface forcing fields. ! It also allocates and initializes the fields in the flux type. @@ -370,15 +373,17 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, CS end subroutine set_forcing +!> This subroutine sets the surface wind stresses to constant values subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - real, intent(in) :: tau_x0 - real, intent(in) :: tau_y0 - type(time_type), intent(in) :: day + real, intent(in) :: tau_x0 !< The zonal wind stress in Pa + real, intent(in) :: tau_y0 !< The meridional wind stress in Pa + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! subroutine sets the surface wind stresses to zero @@ -424,13 +429,15 @@ subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, CS) end subroutine wind_forcing_const +!> This subroutine sets the surface wind stresses to set up two idealized gyres. subroutine wind_forcing_2gyre(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine sets the surface wind stresses according to double gyre. @@ -467,13 +474,15 @@ subroutine wind_forcing_2gyre(sfc_state, forces, day, G, CS) end subroutine wind_forcing_2gyre +!> This subroutine sets the surface wind stresses to set up a single idealized gyre. subroutine wind_forcing_1gyre(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine sets the surface wind stresses according to single gyre. @@ -509,23 +518,17 @@ subroutine wind_forcing_1gyre(sfc_state, forces, day, G, CS) end subroutine wind_forcing_1gyre +!> This subroutine sets the surface wind stresses to set up idealized gyres. subroutine wind_forcing_gyres(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine sets the surface wind stresses according to gyres. - -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - real :: PI, y integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -561,13 +564,15 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, CS) end subroutine wind_forcing_gyres +! This subroutine sets the surface wind stresses from input files. subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine sets the surface wind stresses. @@ -599,16 +604,16 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) time_lev_daily = days - 365*floor(real(days) / 365.0) if (time_lev_daily < 31) then ; time_lev_monthly = 0 - else if (time_lev_daily < 59) then ; time_lev_monthly = 1 - else if (time_lev_daily < 90) then ; time_lev_monthly = 2 - else if (time_lev_daily < 120) then ; time_lev_monthly = 3 - else if (time_lev_daily < 151) then ; time_lev_monthly = 4 - else if (time_lev_daily < 181) then ; time_lev_monthly = 5 - else if (time_lev_daily < 212) then ; time_lev_monthly = 6 - else if (time_lev_daily < 243) then ; time_lev_monthly = 7 - else if (time_lev_daily < 273) then ; time_lev_monthly = 8 - else if (time_lev_daily < 304) then ; time_lev_monthly = 9 - else if (time_lev_daily < 334) then ; time_lev_monthly = 10 + elseif (time_lev_daily < 59) then ; time_lev_monthly = 1 + elseif (time_lev_daily < 90) then ; time_lev_monthly = 2 + elseif (time_lev_daily < 120) then ; time_lev_monthly = 3 + elseif (time_lev_daily < 151) then ; time_lev_monthly = 4 + elseif (time_lev_daily < 181) then ; time_lev_monthly = 5 + elseif (time_lev_daily < 212) then ; time_lev_monthly = 6 + elseif (time_lev_daily < 243) then ; time_lev_monthly = 7 + elseif (time_lev_daily < 273) then ; time_lev_monthly = 8 + elseif (time_lev_daily < 304) then ; time_lev_monthly = 9 + elseif (time_lev_daily < 334) then ; time_lev_monthly = 10 else ; time_lev_monthly = 11 endif @@ -720,13 +725,15 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) end subroutine wind_forcing_from_file +! This subroutine sets the surface wind stresses via the data override facility. subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine sets the surface wind stresses ! Arguments: @@ -791,29 +798,23 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, CS) end subroutine wind_forcing_by_data_override +!> This subroutine specifies zero surface bouyancy fluxes from input files. subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which !! the fluxes apply, in s type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine specifies the current surface fluxes of buoyancy ! temperature and fresh water. It may also be modified to add ! surface fluxes of user provided tracers. ! This case has surface buoyancy forcing from input files. -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) dt = amount of time over which the fluxes apply -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - real, dimension(SZI_(G),SZJ_(G)) :: & temp, & ! A 2-d temporary work array with various units. SST_anom, & ! Instantaneous sea surface temperature anomalies from a @@ -847,16 +848,16 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) time_lev_daily = days - 365*floor(real(days) / 365.0) if (time_lev_daily < 31) then ; time_lev_monthly = 0 - else if (time_lev_daily < 59) then ; time_lev_monthly = 1 - else if (time_lev_daily < 90) then ; time_lev_monthly = 2 - else if (time_lev_daily < 120) then ; time_lev_monthly = 3 - else if (time_lev_daily < 151) then ; time_lev_monthly = 4 - else if (time_lev_daily < 181) then ; time_lev_monthly = 5 - else if (time_lev_daily < 212) then ; time_lev_monthly = 6 - else if (time_lev_daily < 243) then ; time_lev_monthly = 7 - else if (time_lev_daily < 273) then ; time_lev_monthly = 8 - else if (time_lev_daily < 304) then ; time_lev_monthly = 9 - else if (time_lev_daily < 334) then ; time_lev_monthly = 10 + elseif (time_lev_daily < 59) then ; time_lev_monthly = 1 + elseif (time_lev_daily < 90) then ; time_lev_monthly = 2 + elseif (time_lev_daily < 120) then ; time_lev_monthly = 3 + elseif (time_lev_daily < 151) then ; time_lev_monthly = 4 + elseif (time_lev_daily < 181) then ; time_lev_monthly = 5 + elseif (time_lev_daily < 212) then ; time_lev_monthly = 6 + elseif (time_lev_daily < 243) then ; time_lev_monthly = 7 + elseif (time_lev_daily < 273) then ; time_lev_monthly = 8 + elseif (time_lev_daily < 304) then ; time_lev_monthly = 9 + elseif (time_lev_daily < 334) then ; time_lev_monthly = 10 else ; time_lev_monthly = 11 endif @@ -1080,16 +1081,17 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) call callTree_leave("buoyancy_forcing_from_files") end subroutine buoyancy_forcing_from_files - +!> This subroutine specifies zero surface bouyancy fluxes from data over-ride. subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes + real, intent(in) :: dt !< The amount of time over which + !! the fluxes apply, in s + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine specifies the current surface fluxes of buoyancy ! temperature and fresh water. It may also be modified to add @@ -1153,7 +1155,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, CS ! but evap is normally a positive quantity in the files fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) - enddo; enddo + enddo ; enddo call data_override('OCN', 'sens', fluxes%sens(:,:), day, & is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) @@ -1162,7 +1164,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, CS do j=js,je ; do i=is,ie fluxes%sens(i,j) = -fluxes%sens(i,j) ! Normal convention is positive into the ocean ! but sensible is normally a positive quantity in the files - enddo; enddo + enddo ; enddo call data_override('OCN', 'sw', fluxes%sw(:,:), day, & is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) @@ -1258,16 +1260,17 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, CS call callTree_leave("buoyancy_forcing_from_data_override") end subroutine buoyancy_forcing_from_data_override - +!> This subroutine specifies zero surface bouyancy fluxes subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which !! the fluxes apply, in s type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine specifies the current surface fluxes of buoyancy ! temperature and fresh water. It may also be modified to add @@ -1313,15 +1316,17 @@ subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) end subroutine buoyancy_forcing_zero +!> This subroutine sets up spatially and temporally constant surface heat fluxes. subroutine buoyancy_forcing_const(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which !! the fluxes apply, in s type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine specifies the current surface fluxes of buoyancy ! temperature and fresh water. It may also be modified to add @@ -1366,15 +1371,18 @@ subroutine buoyancy_forcing_const(sfc_state, fluxes, day, dt, G, CS) end subroutine buoyancy_forcing_const +!> This subroutine sets surface fluxes of heat and salinity by restoring to temperature and +!! saliinty profiles that vary linearly with latitude. subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which !! the fluxes apply, in s type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine specifies the current surface fluxes of buoyancy ! temperature and fresh water. It may also be modified to add @@ -1456,15 +1464,18 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) call callTree_leave("buoyancy_forcing_linear") end subroutine buoyancy_forcing_linear - +!> Save a restart file for the forcing fields subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & filename_suffix) - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(time_type), intent(in) :: Time - character(len=*), intent(in) :: directory - logical, optional, intent(in) :: time_stamped - character(len=*), optional, intent(in) :: filename_suffix + type(time_type), intent(in) :: Time !< model time at this call; needed for mpp_write calls + character(len=*), intent(in) :: directory !< directory into which to write these restart files + logical, optional, intent(in) :: time_stamped !< If true, the restart file names + !! include a unique time stamp; the default is false. + character(len=*), optional, intent(in) :: filename_suffix !< optional suffix (e.g., a time-stamp) + !! to append to the restart fname ! Arguments: ! CS = pointer to control structure from previous surface_forcing_init call @@ -1482,13 +1493,14 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & end subroutine forcing_save_restart - +!> Initialize the surface forcing module subroutine surface_forcing_init(Time, G, param_file, diag, CS, tracer_flow_CSp) - type(time_type), intent(in) :: Time + type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(inout) :: diag - type(surface_forcing_CS), pointer :: CS + type(diag_ctrl), target, intent(inout) :: diag !< structure used to regulate diagnostic output + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call type(tracer_flow_control_CS), pointer :: tracer_flow_CSp ! Arguments: @@ -1891,9 +1903,11 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, tracer_flow_CSp) end subroutine surface_forcing_init +!> Deallocate memory associated with the surface forcing module subroutine surface_forcing_end(CS, fluxes) - type(surface_forcing_CS), pointer :: CS - type(forcing), optional, intent(inout) :: fluxes + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + type(forcing), optional, intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields ! Arguments: CS - A pointer to the control structure returned by a previous ! call to surface_forcing_init, it will be deallocated here. ! (inout) fluxes - A structure containing pointers to any possible diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 index 972132ae6a..55476f9051 100644 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ b/config_src/solo_driver/Neverland_surface_forcing.F90 @@ -4,7 +4,7 @@ module Neverland_surface_forcing ! This file is part of MOM6. See LICENSE.md for the license. use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type @@ -160,13 +160,13 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) "Temperature and salinity mode not coded!" ) else ! This is the buoyancy only mode. - call alloc_if_needed(fluxes%buoy, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) endif ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. if (CS%restorebuoy .and. CS%first_call) then - call alloc_if_needed(CS%buoy_restore, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%buoy_restore, isd, ied, jsd, jed) CS%first_call = .false. ! Set CS%buoy_restore(i,j) here endif @@ -205,18 +205,6 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) end subroutine Neverland_buoyancy_forcing -!> If ptr is not associated, this routine allocates it with the given size -!! and zeros out its contents. This is equivalent to safe_alloc_ptr in -!! MOM_diag_mediator, but is here so as to be completely transparent. -subroutine alloc_if_needed(ptr, isd, ied, jsd, jed) - real, pointer :: ptr(:,:) - integer :: isd, ied, jsd, jed - if (.not.associated(ptr)) then - allocate(ptr(isd:ied,jsd:jed)) - ptr(:,:) = 0.0 - endif -end subroutine alloc_if_needed - !> Initializes the Neverland control structure. subroutine Neverland_surface_forcing_init(Time, G, param_file, diag, CS) type(time_type), intent(in) :: Time !< The current model time. diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index 3127101cb4..6a70999d50 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -44,7 +44,7 @@ module user_surface_forcing !* * !********+*********+*********+*********+*********+*********+*********+** use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, param_file_type, log_version @@ -85,13 +85,17 @@ module user_surface_forcing contains +!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy. +!! These are the stresses in the direction of the model grid (i.e. the same +!! direction as the u- and v- velocities.) They are both in Pa. subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(user_surface_forcing_CS), pointer :: CS + type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to user_surface_forcing_init ! This subroutine sets the surface wind stresses, forces%taux and forces%tauy. ! These are the stresses in the direction of the model grid (i.e. the same @@ -147,15 +151,19 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) end subroutine USER_wind_forcing +!> This subroutine specifies the current surface fluxes of buoyancy or +!! temperature and fresh water. It may also be modified to add +!! surface fluxes of user provided tracers. subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + !! describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which !! the fluxes apply, in s type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(user_surface_forcing_CS), pointer :: CS + type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to user_surface_forcing_init ! This subroutine specifies the current surface fluxes of buoyancy or ! temperature and fresh water. It may also be modified to add @@ -204,19 +212,19 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! Allocate and zero out the forcing arrays, as necessary. This portion is ! usually not changed. if (CS%use_temperature) then - call alloc_if_needed(fluxes%evap, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lprec, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%fprec, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lrunoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%frunoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%vprec, isd, ied, jsd, jed) - - call alloc_if_needed(fluxes%sw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%latent, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%sens, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) + + call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) else ! This is the buoyancy only mode. - call alloc_if_needed(fluxes%buoy, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) endif @@ -250,7 +258,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) if (CS%restorebuoy) then if (CS%use_temperature) then - call alloc_if_needed(fluxes%heat_added, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) ! When modifying the code, comment out this error message. It is here ! so that the original (unmodified) version is not accidentally used. call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & @@ -290,24 +298,15 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) end subroutine USER_buoyancy_forcing -subroutine alloc_if_needed(ptr, isd, ied, jsd, jed) - ! If ptr is not associated, this routine allocates it with the given size - ! and zeros out its contents. This is equivalent to safe_alloc_ptr in - ! MOM_diag_mediator, but is here so as to be completely transparent. - real, pointer :: ptr(:,:) - integer :: isd, ied, jsd, jed - if (.not.associated(ptr)) then - allocate(ptr(isd:ied,jsd:jed)) - ptr(:,:) = 0.0 - endif -end subroutine alloc_if_needed - +!> This subroutine initializes the USER_surface_forcing module subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) - type(time_type), intent(in) :: Time + type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag - type(user_surface_forcing_CS), pointer :: CS + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. + type(user_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to + !! the control structure for this module + ! Arguments: Time - The current model time. ! (in) G - The ocean's grid structure. ! (in) param_file - A structure indicating the open file to parse for diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index e4d297ddc8..c56d8a3fc3 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -1225,7 +1225,7 @@ subroutine ALE_initThicknessToCoord( CS, G, GV, h ) do j = G%jsd,G%jed ; do i = G%isd,G%ied h(i,j,:) = GV%m_to_H * getStaticThickness( CS%regridCS, 0., G%bathyT(i,j) ) - enddo; enddo + enddo ; enddo end subroutine ALE_initThicknessToCoord diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 1f3488a7bc..ebe8b93bf6 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -1147,7 +1147,7 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) totalThickness = 0.0 do k = 1,nz totalThickness = totalThickness + h(i,j,k) - end do + enddo zOld(nz+1) = - nominalDepth do k = nz,1,-1 @@ -1190,8 +1190,8 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) call adjust_interface_motion( CS, nz, h(i,j,:), dzInterface(i,j,:) ) - end do - end do + enddo + enddo end subroutine build_zstar_grid @@ -1236,7 +1236,7 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) totalThickness = 0.0 do k = 1,nz totalThickness = totalThickness + h(i,j,k) - end do + enddo call build_sigma_column(CS%sigma_CS, nominalDepth, totalThickness, zNew) @@ -1244,7 +1244,7 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) zOld(nz+1) = -nominalDepth do k = nz,1,-1 zOld(k) = zOld(k+1) + h(i, j, k) - end do + enddo call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) ) @@ -1267,8 +1267,8 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) dzInterface(i,j,CS%nk+1) = 0. #endif - end do - end do + enddo + enddo end subroutine build_sigma_grid @@ -1393,8 +1393,8 @@ subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) endif #endif - end do ! end loop on i - end do ! end loop on j + enddo ! end loop on i + enddo ! end loop on j end subroutine build_rho_grid @@ -1466,7 +1466,7 @@ subroutine build_grid_HyCOM1( G, GV, h, tv, h_new, dzInterface, CS ) else ! on land dzInterface(i,j,:) = 0. endif ! mask2dT - enddo; enddo ! i,j + enddo ; enddo ! i,j call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) @@ -1597,7 +1597,7 @@ subroutine build_grid_SLight(G, GV, h, tv, dzInterface, CS) else ! on land dzInterface(i,j,:) = 0. endif ! mask2dT - enddo; enddo ! i,j + enddo ; enddo ! i,j end subroutine build_grid_SLight @@ -1704,7 +1704,7 @@ subroutine build_grid_arbitrary( G, GV, h, dzInterface, h_new, CS ) total_height = 0.0 do k = 1,nz total_height = total_height + h(i,j,k) - end do + enddo eta = total_height - local_depth @@ -1715,7 +1715,7 @@ subroutine build_grid_arbitrary( G, GV, h, dzInterface, h_new, CS ) z_inter(1) = eta do k = 1,nz z_inter(k+1) = z_inter(k) - delta_h - end do + enddo ! Refine grid in the middle do k = 1,nz+1 @@ -1725,15 +1725,15 @@ subroutine build_grid_arbitrary( G, GV, h, dzInterface, h_new, CS ) if ( x <= x1 ) then t = y1*x/x1 - else if ( (x > x1 ) .and. ( x < x2 )) then + elseif ( (x > x1 ) .and. ( x < x2 )) then t = y1 + (y2-y1) * (x-x1) / (x2-x1) else t = y2 + (1.0-y2) * (x-x2) / (1.0-x2) - end if + endif z_inter(k) = -t * max_depth + eta - end do + enddo ! Modify interface heights to account for topography z_inter(nz+1) = - local_depth @@ -1742,8 +1742,8 @@ subroutine build_grid_arbitrary( G, GV, h, dzInterface, h_new, CS ) do k = nz,1,-1 if ( z_inter(k) < (z_inter(k+1) + min_thickness) ) then z_inter(k) = z_inter(k+1) + min_thickness - end if - end do + endif + enddo ! Chnage in interface position x = 0. ! Left boundary at x=0 @@ -1751,11 +1751,11 @@ subroutine build_grid_arbitrary( G, GV, h, dzInterface, h_new, CS ) do k = 2,nz x = x + h(i,j,k) dzInterface(i,j,k) = z_inter(k) - x - end do + enddo dzInterface(i,j,nz+1) = 0. - end do - end do + enddo + enddo stop 'OOOOOOPS' ! For some reason the gnu compiler will not let me delete this ! routine???? @@ -1792,17 +1792,17 @@ subroutine inflate_vanished_layers_old( CS, G, GV, h ) ! Build grid for current column do k = 1,GV%ke hTmp(k) = h(i,j,k) - end do + enddo call old_inflate_layers_1d( CS%min_thickness, GV%ke, hTmp ) ! Save modified grid do k = 1,GV%ke h(i,j,k) = hTmp(k) - end do + enddo - end do - end do + enddo + enddo end subroutine inflate_vanished_layers_old @@ -1859,7 +1859,7 @@ subroutine convective_adjustment(G, GV, h, tv) call calculate_density( tv%T(i,j,k+1), tv%S(i,j,k+1), p_col(k+1), & densities(k+1), tv%eqn_of_state ) stratified = .false. - end if + endif enddo ! k if ( stratified ) exit @@ -1962,7 +1962,7 @@ subroutine set_target_densities_from_GV( GV, CS ) CS%target_density(nz+1) = GV%Rlay(nz)+0.5*(GV%Rlay(nz)-GV%Rlay(nz-1)) do k = 2,nz CS%target_density(k) = CS%target_density(k-1) + CS%coordinateResolution(k) - end do + enddo CS%target_density_set = .true. end subroutine set_target_densities_from_GV @@ -2080,7 +2080,7 @@ function getCoordinateInterfaces( CS ) ! The following line has an "abs()" to allow ferret users to reference ! data by index. It is a temporary work around... :( -AJA getCoordinateInterfaces(:) = abs( getCoordinateInterfaces(:) ) - end if + endif end function getCoordinateInterfaces diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 10ba747d14..c0620122c1 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -140,7 +140,7 @@ subroutine buildGridFromH(nz, h, x) x(1) = 0.0 do k = 1,nz x(k+1) = x(k) + h(k) - end do + enddo end subroutine buildGridFromH @@ -389,21 +389,21 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & call PLM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect) - end if + endif iMethod = INTEGRATION_PLM case ( REMAPPING_PPM_H4 ) call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) - end if + endif iMethod = INTEGRATION_PPM case ( REMAPPING_PPM_IH4 ) call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) - end if + endif iMethod = INTEGRATION_PPM case ( REMAPPING_PQM_IH4IH3 ) call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) @@ -412,7 +412,7 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & ppoly_r_coefs, h_neglect ) - end if + endif iMethod = INTEGRATION_PQM case ( REMAPPING_PQM_IH6IH5 ) call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neglect_edge ) @@ -421,7 +421,7 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & ppoly_r_coefs, h_neglect ) - end if + endif iMethod = INTEGRATION_PQM case default call MOM_error( FATAL, 'MOM_remapping, build_reconstructions_1d: '//& @@ -1119,7 +1119,7 @@ subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & xL, xR, h1(iTarget), u1(iTarget), jStart, xStart, h_neglect ) - end do ! end iTarget loop on target grid cells + enddo ! end iTarget loop on target grid cells end subroutine remapByProjection @@ -1206,7 +1206,7 @@ subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, dx1, & if (present(h1)) h1(iTarget) = hNew endif - end do ! end iTarget loop on target grid cells + enddo ! end iTarget loop on target grid cells end subroutine remapByDeltaZ @@ -1321,7 +1321,7 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, call MOM_error( FATAL,'The selected integration method is invalid' ) end select - end if ! end checking whether source cell is vanished + endif ! end checking whether source cell is vanished ! 2. Cell is not vanished else @@ -1454,8 +1454,8 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, do k = jL+1,jR-1 q = q + h0(k) * u0(k) hAct = hAct + h0(k) - end do - end if + enddo + endif ! Integrate from left boundary of cell jR up to xR xi0 = 0.0 @@ -1494,7 +1494,7 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, call MOM_error( FATAL,'The selected integration method is invalid' ) end select - end if ! end integration for non-vanished cells + endif ! end integration for non-vanished cells ! The cell average is the integrated value divided by the cell width #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ @@ -1507,7 +1507,7 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, uAve = q / hC #endif - end if ! end if clause to check if cell is vanished + endif ! endif clause to check if cell is vanished end subroutine integrateReconOnInterval diff --git a/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90 index 8590a7297f..75490bee9f 100644 --- a/src/ALE/P1M_functions.F90 +++ b/src/ALE/P1M_functions.F90 @@ -87,7 +87,7 @@ subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coef, h_neglect ) ppoly_coef(k,1) = u0_l ppoly_coef(k,2) = u0_r - u0_l - end do ! end loop on interior cells + enddo ! end loop on interior cells end subroutine P1M_interpolation @@ -147,7 +147,7 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) if ( (u1 - u0) * (ppoly_E(2,1) - u0_r) < 0.0 ) then slope = 2.0 * ( ppoly_E(2,1) - u0 ) - end if + endif ! Using the limited slope, the left edge value is reevaluated and ! the interpolant coefficients recomputed @@ -155,7 +155,7 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) ppoly_E(1,1) = u0 - 0.5 * slope else ppoly_E(1,1) = u0 - end if + endif ppoly_coef(1,1) = ppoly_E(1,1) ppoly_coef(1,2) = ppoly_E(1,2) - ppoly_E(1,1) @@ -175,13 +175,13 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) if ( (u1 - u0) * (u0_l - ppoly_E(N-1,2)) < 0.0 ) then slope = 2.0 * ( u1 - ppoly_E(N-1,2) ) - end if + endif if ( h1 /= 0.0 ) then ppoly_E(N,2) = u1 + 0.5 * slope else ppoly_E(N,2) = u1 - end if + endif ppoly_coef(N,1) = ppoly_E(N,1) ppoly_coef(N,2) = ppoly_E(N,2) - ppoly_E(N,1) diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index acc3e064ce..3034d2a8b4 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -144,7 +144,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) else h_l = h(k-1) u_l = u(k-1) - end if + endif if ( k == N ) then h_r = h(k) @@ -152,7 +152,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) else h_r = h(k+1) u_r = u(k+1) - end if + endif ! Compute limited slope sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) @@ -163,28 +163,28 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) else slope = 0.0 - end if + endif ! If the slopes are close to zero in machine precision and in absolute ! value, we set the slope to zero. This prevents asymmetric representation ! near extrema. These expressions are both nondimensional. if ( abs(u1_l*h_c) < eps ) then u1_l = 0.0 - end if + endif if ( abs(u1_r*h_c) < eps ) then u1_r = 0.0 - end if + endif ! The edge slopes are limited from above by the respective ! one-sided slopes if ( abs(u1_l) > abs(sigma_l) ) then u1_l = sigma_l - end if + endif if ( abs(u1_r) > abs(sigma_r) ) then u1_r = sigma_r - end if + endif ! Build cubic interpolant (compute the coefficients) call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) @@ -197,7 +197,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) ! cubic coefficients if ( monotonic == 0 ) then call monotonize_cubic( h_c, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ) - end if + endif ! Store edge slopes ppoly_S(k,1) = u1_l @@ -206,7 +206,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) ! Recompute coefficients of cubic call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) - end do ! loop on cells + enddo ! loop on cells end subroutine P3M_limiter @@ -278,7 +278,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & slope = 2.0 * ( u1 - u0 ) / ( h0 + hNeglect ) if ( abs(u1_r) > abs(slope) ) then u1_r = slope - end if + endif ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell @@ -297,7 +297,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & u0_l = u0_r u1_l = 0.0 u1_r = 0.0 - end if + endif ! Store edge values and slope, build cubic and check monotonicity ppoly_E(i0,1) = u0_l @@ -317,7 +317,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ppoly_S(i0,2) = u1_r call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coef ) - end if + endif ! ----- Right boundary ----- i0 = N-1 @@ -338,7 +338,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & slope = 2.0 * ( u1 - u0 ) / ( h1 + hNeglect ) if ( abs(u1_l) > abs(slope) ) then u1_l = slope - end if + endif ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell @@ -357,7 +357,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & u0_r = u0_l u1_l = 0.0 u1_r = 0.0 - end if + endif ! Store edge values and slope, build cubic and check monotonicity ppoly_E(i1,1) = u0_l @@ -376,7 +376,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & ppoly_S(i1,2) = u1_r call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) - end if + endif end subroutine P3M_boundary_extrapolation @@ -474,10 +474,10 @@ integer function is_cubic_monotonic( ppoly_coef, k ) if ( abs(c) > 1e-15 ) then xi_0 = 0.5 * ( -b - sqrt( rho ) ) / c xi_1 = 0.5 * ( -b + sqrt( rho ) ) / c - else if ( abs(b) > 1e-15 ) then + elseif ( abs(b) > 1e-15 ) then xi_0 = - a / b xi_1 = - a / b - end if + endif ! If one of the roots of the first derivative lies in (0,1), ! the cubic is not monotonic. @@ -486,11 +486,11 @@ integer function is_cubic_monotonic( ppoly_coef, k ) monotonic = 0 else monotonic = 1 - end if + endif else ! there are no real roots --> cubic is monotonic monotonic = 1 - end if + endif ! Set the return value is_cubic_monotonic = monotonic @@ -560,11 +560,11 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ! set them to zero if ( u1_l*slope <= 0.0 ) then u1_l = 0.0 - end if + endif if ( u1_r*slope <= 0.0 ) then u1_r = 0.0 - end if + endif ! Compute the location of the inflexion point, which is the root ! of the second derivative @@ -582,8 +582,8 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ! If the inflexion point lies in [0,1], change boolean value if ( (xi_ip >= 0.0) .AND. (xi_ip <= 1.0) ) then found_ip = 1 - end if - end if + endif + endif ! When there is an inflexion point within [0,1], check the slope ! to see if it is consistent with the limited PLM slope. If not, @@ -599,9 +599,9 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r inflexion_l = 1 else inflexion_r = 1 - end if - end if - end if ! found_ip + endif + endif + endif ! found_ip ! At this point, if the cubic is not monotonic, we know where the ! inflexion point should lie. When the cubic is monotonic, both @@ -618,12 +618,12 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r u1_l = 0.0 u1_r = 3.0 * (u0_r - u0_l) / h - else if (u1_l_tmp*slope < 0.0) then + elseif (u1_l_tmp*slope < 0.0) then u1_r = u1_r_tmp u1_l = 1.5*(u0_r - u0_l)/h - 0.5*u1_r - else if (u1_r_tmp*slope < 0.0) then + elseif (u1_r_tmp*slope < 0.0) then u1_l = u1_l_tmp u1_r = 3.0*(u0_r - u0_l)/h - 2.0*u1_l @@ -633,9 +633,9 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r u1_l = u1_l_tmp u1_r = u1_r_tmp - end if + endif - end if ! end treating case with inflexion point on the left + endif ! end treating case with inflexion point on the left ! Move inflexion point on the right if ( inflexion_r == 1 ) then @@ -648,12 +648,12 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r u1_l = 3.0 * (u0_r - u0_l) / h u1_r = 0.0 - else if (u1_l_tmp*slope < 0.0) then + elseif (u1_l_tmp*slope < 0.0) then u1_r = u1_r_tmp u1_l = 3.0*(u0_r - u0_l)/h - 2.0*u1_r - else if (u1_r_tmp*slope < 0.0) then + elseif (u1_r_tmp*slope < 0.0) then u1_l = u1_l_tmp u1_r = 1.5*(u0_r - u0_l)/h - 0.5*u1_l @@ -663,17 +663,17 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r u1_l = u1_l_tmp u1_r = u1_r_tmp - end if + endif - end if ! end treating case with inflexion point on the right + endif ! end treating case with inflexion point on the right if ( abs(u1_l*h) < eps ) then u1_l = 0.0 - end if + endif if ( abs(u1_r*h) < eps ) then u1_r = 0.0 - end if + endif end subroutine monotonize_cubic diff --git a/src/ALE/PCM_functions.F90 b/src/ALE/PCM_functions.F90 index bcb963faa6..6d407b0cc5 100644 --- a/src/ALE/PCM_functions.F90 +++ b/src/ALE/PCM_functions.F90 @@ -56,7 +56,7 @@ subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coef ) ! The edge values are equal to the cell average do k = 1,N ppoly_E(k,:) = u(k) - end do + enddo end subroutine PCM_reconstruction diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index 73f9206c21..12cd558e60 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -102,7 +102,7 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) ! Extrema in the mean values require a PCM reconstruction avoid generating ! larger extreme values. slope = 0.0 - end if + endif ! This block tests to see if roundoff causes edge values to be out of bounds u_min = min( u_l, u_c, u_r ) @@ -130,7 +130,7 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) ppoly_E(k,1) = u_c - 0.5 * slope ppoly_E(k,2) = u_c + 0.5 * slope - end do ! end loop on interior cells + enddo ! end loop on interior cells ! Boundary cells use PCM. Extrapolation is handled in a later routine. slp(1) = 0. diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index d0eb8325ad..11dabad684 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -198,7 +198,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) slope = 2.0 * ( u1 - u0 ) if ( abs(u1_r) > abs(slope) ) then u1_r = slope - end if + endif ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell @@ -215,11 +215,11 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) if ( exp1 > exp2 ) then u0_l = 3.0 * u0 - 2.0 * u0_r - end if + endif if ( exp1 < -exp2 ) then u0_r = 3.0 * u0 - 2.0 * u0_l - end if + endif ppoly_E(i0,1) = u0_l ppoly_E(i0,2) = u0_r @@ -251,7 +251,7 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) slope = 2.0 * ( u1 - u0 ) if ( abs(u1_l) > abs(slope) ) then u1_l = slope - end if + endif ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell @@ -268,11 +268,11 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) if ( exp1 > exp2 ) then u0_l = 3.0 * u1 - 2.0 * u0_r - end if + endif if ( exp1 < -exp2 ) then u0_r = 3.0 * u1 - 2.0 * u0_l - end if + endif ppoly_E(i1,1) = u0_l ppoly_E(i1,2) = u0_r diff --git a/src/ALE/PQM_functions.F90 b/src/ALE/PQM_functions.F90 index 6c89c7ac10..3a4e517e57 100644 --- a/src/ALE/PQM_functions.F90 +++ b/src/ALE/PQM_functions.F90 @@ -83,7 +83,7 @@ subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ppoly_coef(k,4) = d ppoly_coef(k,5) = e - end do ! end loop on cells + enddo ! end loop on cells end subroutine PQM_reconstruction @@ -171,7 +171,7 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) else slope = 0.0 - end if + endif ! If one of the slopes has the wrong sign compared with the ! limited PLM slope, it is set equal to the limited PLM slope @@ -186,7 +186,7 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) u1_r = 0.0 inflexion_l = -1 inflexion_r = -1 - end if + endif ! Edge values are bounded and averaged when discontinuous and not ! monotonic, edge slopes are consistent and the cell is not an extremum. @@ -232,12 +232,12 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) inflexion_l = 1 else inflexion_r = 1 - end if - end if + endif + endif ! If both x1 and x2 do not lie in [0,1], check whether ! only x1 lies in [0,1] - else if ( (x1 >= 0.0) .AND. (x1 <= 1.0) ) then + elseif ( (x1 >= 0.0) .AND. (x1 <= 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b @@ -249,11 +249,11 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) inflexion_l = 1 else inflexion_r = 1 - end if - end if + endif + endif ! If x1 does not lie in [0,1], check whether x2 lies in [0,1] - else if ( (x2 >= 0.0) .AND. (x2 <= 1.0) ) then + elseif ( (x2 >= 0.0) .AND. (x2 <= 1.0) ) then gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b @@ -265,12 +265,12 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) inflexion_l = 1 else inflexion_r = 1 - end if - end if + endif + endif - end if ! end checking where the inflexion points lie + endif ! end checking where the inflexion points lie - end if ! end checking if alpha1 != 0 AND rho >= 0 + endif ! end checking if alpha1 != 0 AND rho >= 0 ! If alpha1 is zero, the second derivative of the quartic reduces ! to a straight line @@ -289,14 +289,14 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) inflexion_l = 1 else inflexion_r = 1 - end if - end if ! check slope consistency + endif + endif ! check slope consistency - end if + endif - end if ! end check whether we can find the root of the straight line + endif ! end check whether we can find the root of the straight line - end if ! end checking whether to shift inflexion points + endif ! end checking whether to shift inflexion points ! At this point, we know onto which edge to shift inflexion points if ( inflexion_l == 1 ) then @@ -316,15 +316,15 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) u0_r = 5.0 * u_c - 4.0 * u0_l u1_r = 20.0 * (u_c - u0_l) / ( h_c + hNeglect ) - else if ( u1_r * slope < 0.0 ) then + elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = (5.0*u_c - 3.0*u0_r) / 2.0 u1_l = 10.0 * (-u_c + u0_r) / (3.0 * h_c + hNeglect) - end if + endif - else if ( inflexion_r == 1 ) then + elseif ( inflexion_r == 1 ) then ! We modify the edge slopes so that both inflexion points ! collapse onto the right edge @@ -341,15 +341,15 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) u0_r = ( 5.0 * u_c - 3.0 * u0_l ) / 2.0 u1_r = 10.0 * (u_c - u0_l) / (3.0 * h_c + hNeglect) - else if ( u1_r * slope < 0.0 ) then + elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = 5.0 * u_c - 4.0 * u0_r u1_l = 20.0 * ( -u_c + u0_r ) / (h_c + hNeglect) - end if + endif - end if ! clause to check where to collapse inflexion points + endif ! clause to check where to collapse inflexion points ! Save edge values and edge slopes for reconstruction ppoly_E(k,1) = u0_l @@ -357,7 +357,7 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ppoly_S(k,1) = u1_l ppoly_S(k,2) = u1_r - end do ! end loop on interior cells + enddo ! end loop on interior cells ! Constant reconstruction within boundary cells ppoly_E(1,:) = u(1) @@ -431,7 +431,7 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) slope = 2.0 * ( u1 - u0 ) if ( abs(u1_r) > abs(slope) ) then u1_r = slope - end if + endif ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell @@ -448,11 +448,11 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) if ( exp1 > exp2 ) then u0_l = 3.0 * u0 - 2.0 * u0_r - end if + endif if ( exp1 < -exp2 ) then u0_r = 3.0 * u0 - 2.0 * u0_l - end if + endif ppoly_E(i0,1) = u0_l ppoly_E(i0,2) = u0_r @@ -489,7 +489,7 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) slope = 2.0 * ( u1 - u0 ) if ( abs(u1_l) > abs(slope) ) then u1_l = slope - end if + endif ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell @@ -506,11 +506,11 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) if ( exp1 > exp2 ) then u0_l = 3.0 * u1 - 2.0 * u0_r - end if + endif if ( exp1 < -exp2 ) then u0_r = 3.0 * u1 - 2.0 * u0_l - end if + endif ppoly_E(i1,1) = u0_l ppoly_E(i1,2) = u0_r @@ -636,7 +636,7 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, else u0_l = u_plm u1_l = slope / (h0 + hNeglect) - end if + endif ! Monotonize quartic inflexion_l = 0 @@ -664,18 +664,18 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b if ( gradient1 * slope < 0.0 ) then inflexion_l = 1 - end if - end if + endif + endif x2 = 0.5 * ( - alpha2 + sqrt_rho ) / alpha1 if ( (x2 > 0.0) .and. (x2 < 1.0) ) then gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b if ( gradient2 * slope < 0.0 ) then inflexion_l = 1 - end if - end if + endif + endif - end if + endif if (( alpha1 == 0.0 ) .and. ( alpha2 /= 0.0 )) then @@ -684,10 +684,10 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, gradient1 = 3.0 * d * (x1**2) + 2.0 * c * x1 + b if ( gradient1 * slope < 0.0 ) then inflexion_l = 1 - end if - end if + endif + endif - end if + endif if ( inflexion_l == 1 ) then @@ -706,15 +706,15 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, u0_r = 5.0 * um - 4.0 * u0_l u1_r = 20.0 * (um - u0_l) / ( h0 + hNeglect ) - else if ( u1_r * slope < 0.0 ) then + elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = (5.0*um - 3.0*u0_r) / 2.0 u1_l = 10.0 * (-um + u0_r) / (3.0 * h0 + hNeglect ) - end if + endif - end if + endif ! Store edge values, edge slopes and coefficients ppoly_E(i0,1) = u0_l @@ -789,7 +789,7 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, else u0_r = u_plm u1_r = slope / h1 - end if + endif ! Monotonize quartic inflexion_r = 0 @@ -817,18 +817,18 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b if ( gradient1 * slope < 0.0 ) then inflexion_r = 1 - end if - end if + endif + endif x2 = 0.5 * ( - alpha2 + sqrt_rho ) / alpha1 if ( (x2 > 0.0) .and. (x2 < 1.0) ) then gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b if ( gradient2 * slope < 0.0 ) then inflexion_r = 1 - end if - end if + endif + endif - end if + endif if (( alpha1 == 0.0 ) .and. ( alpha2 /= 0.0 )) then @@ -837,10 +837,10 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, gradient1 = 3.0 * d * (x1**2) + 2.0 * c * x1 + b if ( gradient1 * slope < 0.0 ) then inflexion_r = 1 - end if - end if + endif + endif - end if + endif if ( inflexion_r == 1 ) then @@ -859,15 +859,15 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, u0_r = ( 5.0 * um - 3.0 * u0_l ) / 2.0 u1_r = 10.0 * (um - u0_l) / (3.0 * h1) - else if ( u1_r * slope < 0.0 ) then + elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = 5.0 * um - 4.0 * u0_r u1_l = 20.0 * ( -um + u0_r ) / h1 - end if + endif - end if + endif ! Store edge values, edge slopes and coefficients ppoly_E(i1,1) = u0_l diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index d3141cfd2d..84bb9e5518 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -123,14 +123,14 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & xTmp(1) = 0.0 do k = 1,count_nonzero_layers xTmp(k+1) = xTmp(k) + h_nv(k) - end do + enddo ! Compute densities on source column p(:) = CS%ref_pressure call calculate_density(T, S, p, densities, 1, nz, eqn_of_state) do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) - end do + enddo ! Based on source column density profile, interpolate to generate a new grid call build_and_interpolate_grid(CS%interp_CS, densities, count_nonzero_layers, & @@ -141,10 +141,10 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & call old_inflate_layers_1d(CS%min_thickness, CS%nk, h_new) ! Comment: The following adjustment of h_new, and re-calculation of h_new via x1 needs to be removed - x1(1) = 0.0 ; do k = 1,CS%nk ; x1(k+1) = x1(k) + h_new(k) ; end do + x1(1) = 0.0 ; do k = 1,CS%nk ; x1(k+1) = x1(k) + h_new(k) ; enddo do k = 1,CS%nk h_new(k) = x1(k+1) - x1(k) - end do + enddo else ! count_nonzero_layers <= 1 if (nz == CS%nk) then @@ -231,12 +231,12 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ if ( count_nonzero_layers <= 1 ) then h1(:) = h0(:) exit ! stop iterations here - end if + endif xTmp(1) = 0.0 do k = 1,count_nonzero_layers xTmp(k+1) = xTmp(k) + hTmp(k) - end do + enddo ! Compute densities within current water column call calculate_density( T_tmp, S_tmp, p, densities,& @@ -244,7 +244,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) - end do + enddo ! One regridding iteration ! Based on global density profile, interpolate to generate a new grid @@ -252,12 +252,12 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ hTmp, xTmp, CS%target_density, nz, h1, x1, h_neglect, h_neglect_edge) call old_inflate_layers_1d( CS%min_thickness, nz, h1 ) - x1(1) = 0.0 ; do k = 1,nz ; x1(k+1) = x1(k) + h1(k) ; end do + x1(1) = 0.0 ; do k = 1,nz ; x1(k+1) = x1(k) + h1(k) ; enddo ! Remap T and S from previous grid to new grid do k = 1,nz h1(k) = x1(k+1) - x1(k) - end do + enddo call remapping_core_h(remapCS, nz, h0, S, nz, h1, Tmp, h_neglect, h_neglect_edge) S_tmp(:) = Tmp(:) @@ -273,7 +273,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ x0(k) = x0(k-1) + h0(k-1) x1(k) = x1(k-1) + h1(k-1) deviation = deviation + (x0(k)-x1(k))**2 - end do + enddo deviation = sqrt( deviation / (nz-1) ) m = m + 1 @@ -281,7 +281,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ ! Copy final grid onto start grid for next iteration h0(:) = h1(:) - end do ! end regridding iterations + enddo ! end regridding iterations if (CS%integrate_downward_for_e) then zInterface(1) = 0. @@ -330,12 +330,12 @@ subroutine copy_finite_thicknesses(nk, h_in, threshold, nout, h_out, mapping) if (h_out(nout) > thickest_h_out) then thickest_h_out = h_out(nout) k_thickest = nout - end if + endif else ! Add up mass in vanished layers thickness_in_vanished = thickness_in_vanished + h_in(k) - end if - end do + endif + enddo ! No finite layers if (nout <= 1) return @@ -367,8 +367,8 @@ subroutine old_inflate_layers_1d( min_thickness, nk, h ) do k = 1,nk if ( h(k) > min_thickness ) then count_nonzero_layers = count_nonzero_layers + 1 - end if - end do + endif + enddo ! If all layer thicknesses are greater than the threshold, exit routine if ( count_nonzero_layers == nk ) return @@ -377,9 +377,9 @@ subroutine old_inflate_layers_1d( min_thickness, nk, h ) if ( count_nonzero_layers == 0 ) then do k = 1,nk h(k) = min_thickness - end do + enddo return - end if + endif ! Inflate zero layers correction = 0.0 @@ -388,8 +388,8 @@ subroutine old_inflate_layers_1d( min_thickness, nk, h ) delta = min_thickness - h(k) correction = correction + delta h(k) = h(k) + delta - end if - end do + endif + enddo ! Modify thicknesses of nonzero layers to ensure volume conservation maxThickness = h(1) @@ -398,8 +398,8 @@ subroutine old_inflate_layers_1d( min_thickness, nk, h ) if ( h(k) > maxThickness ) then maxThickness = h(k) k_found = k - end if - end do + endif + enddo h(k_found) = h(k_found) - correction diff --git a/src/ALE/polynomial_functions.F90 b/src/ALE/polynomial_functions.F90 index 0cc4eb0b71..78c75f53a0 100644 --- a/src/ALE/polynomial_functions.F90 +++ b/src/ALE/polynomial_functions.F90 @@ -45,7 +45,7 @@ real function evaluation_polynomial( coeff, ncoef, x ) f = 0.0 do k = 1,ncoef f = f + coeff(k) * ( x**(k-1) ) - end do + enddo evaluation_polynomial = f @@ -73,7 +73,7 @@ real function first_derivative_polynomial( coeff, ncoef, x ) f = 0.0 do k = 2,ncoef f = f + REAL(k-1)*coeff(k) * ( x**(k-2) ) - end do + enddo first_derivative_polynomial = f @@ -99,7 +99,7 @@ real function integration_polynomial( xi0, xi1, Coeff, npoly ) do k = 1,npoly+1 integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) - end do + enddo ! !One non-answer-changing way of unrolling the above is: ! k=1 diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index e07f3c3bd5..59d36e3e0e 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -116,23 +116,23 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) tri_b(i+1) = a * u(i) + b * u(i+1) - end do ! end loop on cells + enddo ! end loop on cells ! Boundary conditions: left boundary x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + h(i-1) - end do + enddo do i = 1,4 do j = 1,4 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(i) * ( h(i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 4 ) @@ -148,17 +148,17 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + h(N-5+i) - end do + enddo do i = 1,4 do j = 1,4 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(N-4+i) * ( h(N-4+i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 4 ) @@ -176,7 +176,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) do i = 2,N edge_slopes(i,1) = tri_x(i) edge_slopes(i-1,2) = tri_x(i) - end do + enddo edge_slopes(1,1) = tri_x(1) edge_slopes(N,2) = tri_x(N+1) @@ -364,7 +364,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) tri_u(k+1) = beta tri_b(k+1) = a * u(k-1) + b * u(k) + c * u(k+1) + d * u(k+2) - end do ! end loop on cells + enddo ! end loop on cells ! Use a right-biased stencil for the second row @@ -481,17 +481,17 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + h(i-1) - end do + enddo do i = 1,6 do j = 1,6 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(i) * h(i) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 6 ) @@ -621,17 +621,17 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + h(N-7+i) - end do + enddo do i = 1,6 do j = 1,6 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(N-6+i) * h(N-6+i) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 6 ) @@ -652,7 +652,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) do i = 2,N edge_slopes(i,1) = tri_x(i) edge_slopes(i-1,2) = tri_x(i) - end do + enddo edge_slopes(1,1) = tri_x(1) edge_slopes(N,2) = tri_x(N+1) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index d43cf5cc36..5fe4700c38 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -89,7 +89,7 @@ subroutine bound_edge_values( N, h, u, edge_val, h_neglect ) k0 = 1 k1 = 1 k2 = 2 - else if ( k == N ) then + elseif ( k == N ) then k0 = N-1 k1 = N k2 = N @@ -97,7 +97,7 @@ subroutine bound_edge_values( N, h, u, edge_val, h_neglect ) k0 = k-1 k1 = k k2 = k+1 - end if + endif ! All cells can now be treated equally h_l = h(k0) @@ -119,7 +119,7 @@ subroutine bound_edge_values( N, h, u, edge_val, h_neglect ) slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) else slope = 0.0 - end if + endif ! The limiter must be used in the local coordinate system to each cell. ! Hence, we must multiply the slope by h1. The multiplication by 0.5 is @@ -129,11 +129,11 @@ subroutine bound_edge_values( N, h, u, edge_val, h_neglect ) if ( (u_l-u0_l)*(u0_l-u_c) < 0.0 ) then u0_l = u_c - sign( min( abs(slope), abs(u0_l-u_c) ), slope ) - end if + endif if ( (u_r-u0_r)*(u0_r-u_c) < 0.0 ) then u0_r = u_c + sign( min( abs(slope), abs(u0_r-u_c) ), slope ) - end if + endif ! Finally bound by neighboring cell means in case of round off u0_l = max( min( u0_l, max(u_l, u_c) ), min(u_l, u_c) ) @@ -143,7 +143,7 @@ subroutine bound_edge_values( N, h, u, edge_val, h_neglect ) edge_val(k,1) = u0_l edge_val(k,2) = u0_r - end do ! loop on interior edges + enddo ! loop on interior edges end subroutine bound_edge_values @@ -178,9 +178,9 @@ subroutine average_discontinuous_edge_values( N, edge_val ) u0_avg = 0.5 * ( u0_minus + u0_plus ) edge_val(k,2) = u0_avg edge_val(k+1,1) = u0_avg - end if + endif - end do ! end loop on interior edges + enddo ! end loop on interior edges end subroutine average_discontinuous_edge_values @@ -224,9 +224,9 @@ subroutine check_discontinuous_edge_values( N, u, edge_val ) u0_avg = max( min( u0_avg, max(um_minus, um_plus) ), min(um_minus, um_plus) ) edge_val(k,2) = u0_avg edge_val(k+1,1) = u0_avg - end if + endif - end do ! end loop on interior edges + enddo ! end loop on interior edges end subroutine check_discontinuous_edge_values @@ -284,7 +284,7 @@ subroutine edge_values_explicit_h2( N, h, u, edge_val, h_neglect ) ! value of left cell edge_val(k-1,2) = edge_val(k,1) - end do ! end loop on interior cells + enddo ! end loop on interior cells ! Boundary edge values are simply equal to the boundary cell averages edge_val(1,1) = u(1) @@ -388,24 +388,24 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect ) endif #endif - end do ! end loop on interior cells + enddo ! end loop on interior cells ! Determine first two edge values f1 = max( hNeglect, hMinFrac*sum(h(1:4)) ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max(f1, h(i-1)) - end do + enddo do i = 1,4 do j = 1,4 A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) - end do + enddo B(i) = u(i) * max(f1, h(i) ) - end do + enddo call solve_linear_system( A, B, C, 4 ) @@ -433,17 +433,17 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max(f1, h(N-5+i)) - end do + enddo do i = 1,4 do j = 1,4 A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) - end do + enddo B(i) = u(N-4+i) * max(f1, h(N-4+i) ) - end do + enddo call solve_linear_system( A, B, C, 4 ) @@ -461,10 +461,10 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect ) do i = 1,4 do j = 1,4 A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) - end do + enddo write(0,*) A(i,:) B(i) = u(N-4+i) * ( h(N-4+i) ) - end do + enddo write(0,*) 'B=',B write(0,*) 'C=',C write(0,*) 'h(:N)=',h(N-3:N) @@ -561,24 +561,24 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect ) tri_b(i+1) = a * u(i) + b * u(i+1) - end do ! end loop on cells + enddo ! end loop on cells ! Boundary conditions: left boundary h0 = max( hNeglect, hMinFrac*sum(h(1:4)) ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max( h0, h(i-1) ) - end do + enddo do i = 1,4 do j = 1,4 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(i) * max( h0, h(i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 4 ) @@ -591,17 +591,17 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max( h0, h(N-5+i) ) - end do + enddo do i = 1,4 do j = 1,4 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(N-4+i) * max( h0, h(N-4+i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 4 ) @@ -615,7 +615,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect ) do i = 2,N edge_val(i,1) = tri_x(i) edge_val(i-1,2) = tri_x(i) - end do + enddo edge_val(1,1) = tri_x(1) edge_val(N,2) = tri_x(N+1) @@ -812,7 +812,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) tri_u(k+1) = beta tri_b(k+1) = a * u(k-1) + b * u(k) + c * u(k+1) + d * u(k+2) - end do ! end loop on cells + enddo ! end loop on cells ! Use a right-biased stencil for the second row @@ -940,17 +940,17 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + max( g, h(i-1) ) - end do + enddo do i = 1,6 do j = 1,6 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(i) * max( g, h(i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 6 ) @@ -1085,17 +1085,17 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + max( g, h(N-7+i) ) - end do + enddo do i = 1,6 do j = 1,6 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(N-6+i) * max( g, h(N-6+i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 6 ) @@ -1110,7 +1110,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) do i = 2,N edge_val(i,1) = tri_x(i) edge_val(i-1,2) = tri_x(i) - end do + enddo edge_val(1,1) = tri_x(1) edge_val(N,2) = tri_x(N+1) diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index d9d2a19228..fd445e7318 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -104,7 +104,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if + endif case ( INTERPOLATION_P1M_H4 ) degree = DEGREE_1 @@ -112,11 +112,11 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) else call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) - end if + endif call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if + endif case ( INTERPOLATION_P1M_IH4 ) degree = DEGREE_1 @@ -124,18 +124,18 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) else call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) - end if + endif call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if + endif case ( INTERPOLATION_PLM ) degree = DEGREE_1 call PLM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call PLM_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) - end if + endif case ( INTERPOLATION_PPM_H4 ) if ( n0 >= 4 ) then @@ -145,15 +145,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & ppoly0_coefs, h_neglect ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif case ( INTERPOLATION_PPM_IH4 ) if ( n0 >= 4 ) then @@ -163,15 +163,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & ppoly0_coefs, h_neglect ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif case ( INTERPOLATION_P3M_IH4IH3 ) if ( n0 >= 4 ) then @@ -183,15 +183,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, h_neglect_edge ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif case ( INTERPOLATION_P3M_IH6IH5 ) if ( n0 >= 6 ) then @@ -203,15 +203,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, h_neglect_edge ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif case ( INTERPOLATION_PQM_IH4IH3 ) if ( n0 >= 4 ) then @@ -223,15 +223,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif case ( INTERPOLATION_PQM_IH6IH5 ) if ( n0 >= 6 ) then @@ -243,15 +243,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif end select end subroutine regridding_set_ppolys @@ -288,7 +288,7 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & t = target_values(k) x1(k) = get_polynomial_coordinate ( n0, h0, x0, ppoly0_E, ppoly0_coefs, t, degree ) h1(k-1) = x1(k) - x1(k-1) - end do + enddo h1(n1) = x1(n1+1) - x1(n1) end subroutine interpolate_grid @@ -373,7 +373,7 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & if ( target_value <= ppoly_E(1,1) ) then x_tgt = x_g(1) return ! return because there is no need to look further - end if + endif ! Since discontinuous edge values are allowed, we check whether the target ! value lies between two discontinuous edge values at interior interfaces @@ -383,8 +383,8 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & x_tgt = x_g(k) return ! return because there is no need to look further exit - end if - end do + endif + enddo ! If the target value is outside the range of all values, we ! force the target coordinate to be equal to the lowest or @@ -392,7 +392,7 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & if ( target_value >= ppoly_E(N,2) ) then x_tgt = x_g(N+1) return ! return because there is no need to look further - end if + endif ! At this point, we know that the target value is bounded and does not ! lie between discontinuous, monotonic edge values. Therefore, @@ -404,8 +404,8 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & ( target_value < ppoly_E(k,2) ) ) then k_found = k exit - end if - end do + endif + enddo ! At this point, 'k_found' should be strictly positive. If not, this is ! a major failure because it means we could not find any target cell @@ -419,14 +419,14 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & 'inconsistent interpolant (perhaps not monotonically '//& 'increasing)' call MOM_error( FATAL, 'Aborting execution' ) - end if + endif ! Reset all polynomial coefficients to 0 and copy those pertaining to ! the found cell a(:) = 0.0 do i = 1,degree+1 a(i) = ppoly_coefs(k_found,i) - end do + enddo ! Guess value to start Newton-Raphson iterations (middle of cell) xi0 = 0.5 @@ -439,7 +439,7 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & if ( ( iter > NR_ITERATIONS ) .OR. & ( abs(delta) < NR_TOLERANCE ) ) then exit - end if + endif numerator = a(1) + a(2)*xi0 + a(3)*xi0*xi0 + a(4)*xi0*xi0*xi0 + & a(5)*xi0*xi0*xi0*xi0 - target_value @@ -459,16 +459,16 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & xi0 = 0.0 grad = a(2) if ( grad == 0.0 ) xi0 = xi0 + eps - end if + endif if ( xi0 > 1.0 ) then xi0 = 1.0 grad = a(2) + 2*a(3) + 3*a(4) + 4*a(5) if ( grad == 0.0 ) xi0 = xi0 - eps - end if + endif iter = iter + 1 - end do ! end Newton-Raphson iterations + enddo ! end Newton-Raphson iterations x_tgt = x_g(k_found) + xi0 * h(k_found) end function get_polynomial_coordinate diff --git a/src/ALE/regrid_solvers.F90 b/src/ALE/regrid_solvers.F90 index 7e44039831..18ef1e5e0b 100644 --- a/src/ALE/regrid_solvers.F90 +++ b/src/ALE/regrid_solvers.F90 @@ -63,16 +63,16 @@ subroutine solve_linear_system( A, B, X, system_size ) else ! Go to the next row to see ! if there is a valid pivot there k = k + 1 - end if + endif - end do ! end loop to find pivot + enddo ! end loop to find pivot ! If no pivot could be found, the system is singular and we need ! to end the execution if ( .NOT. found_pivot ) then write(0,*) ' A=',A call MOM_error( FATAL, 'The linear system is singular !' ) - end if + endif ! If the pivot is in a row that is different than row i, that is if ! k is different than i, we need to swap those two rows @@ -81,18 +81,18 @@ subroutine solve_linear_system( A, B, X, system_size ) swap_a = A(i,j) A(i,j) = A(k,j) A(k,j) = swap_a - end do + enddo swap_b = B(i) B(i) = B(k) B(k) = swap_b - end if + endif ! Transform pivot to 1 by dividing the entire row ! (right-hand side included) by the pivot pivot = A(i,i) do j = i,system_size A(i,j) = A(i,j) / pivot - end do + enddo B(i) = B(i) / pivot ! #INV: At this point, A(i,i) is a suitable pivot and it is equal to 1 @@ -103,11 +103,11 @@ subroutine solve_linear_system( A, B, X, system_size ) factor = A(k,i) do j = (i+1),system_size ! j is the column index A(k,j) = A(k,j) - factor * A(i,j) - end do + enddo B(k) = B(k) - factor * B(i) - end do + enddo - end do ! end loop on i + enddo ! end loop on i ! Solve system by back substituting @@ -116,9 +116,9 @@ subroutine solve_linear_system( A, B, X, system_size ) X(i) = B(i) do j = (i+1),system_size X(i) = X(i) - A(i,j) * X(j) - end do + enddo X(i) = X(i) / A(i,i) - end do + enddo end subroutine solve_linear_system @@ -147,18 +147,18 @@ subroutine solve_tridiagonal_system( Al, Ad, Au, B, X, system_size ) do k = 1,N-1 Al(k+1) = Al(k+1) / Ad(k) Ad(k+1) = Ad(k+1) - Al(k+1) * Au(k) - end do + enddo ! Forward sweep do k = 2,N B(k) = B(k) - Al(k) * B(k-1) - end do + enddo ! Backward sweep X(N) = B(N) / Ad(N) do k = N-1,1,-1 X(k) = ( B(k) - Au(k)*X(k+1) ) / Ad(k) - end do + enddo end subroutine solve_tridiagonal_system diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 9fca715e42..c1dcf4cf33 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2882,7 +2882,7 @@ subroutine extract_surface_state(CS, sfc_state) endif ! numberOfErrors endif ! localError endif ! mask2dT - enddo; enddo + enddo ; enddo call sum_across_PEs(numberOfErrors) if (numberOfErrors>0) then write(msg(1:240),'(3(a,i9,x))') 'There were a total of ',numberOfErrors, & diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 9d01f108d1..690fcb42e9 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -549,7 +549,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) vhm = 10.0*vhc elseif (abs(vhc) > c1*abs(vhm)) then if (abs(vhc) < c2*abs(vhm)) then ; vhc = (3.0*vhc+(1.0-c2*3.0)*vhm) - else if (abs(vhc) <= c3*abs(vhm)) then ; vhc = vhm + elseif (abs(vhc) <= c3*abs(vhm)) then ; vhc = vhm else ; vhc = slope*vhc+(1.0-c3*slope)*vhm endif endif diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index c430179917..a54d7bb01f 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -665,7 +665,7 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, LB, vol_CFL, & if (marginal) then ; h_u(I,j,k) = h_marg else ; h_u(I,j,k) = h_avg ; endif - enddo; enddo ; enddo + enddo ; enddo ; enddo if (present(visc_rem_u)) then !$OMP parallel do default(shared) do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh @@ -1948,7 +1948,7 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ slp(i,j) = sign(1.,slp(i,j)) * min(abs(slp(i,j)), 2. * min(dMx, dMn)) ! * (G%mask2dT(i-1,j) * G%mask2dT(i,j) * G%mask2dT(i+1,j)) endif - enddo; enddo + enddo ; enddo if (local_open_BC) then do n=1, OBC%number_of_segments @@ -1975,7 +1975,7 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ ! Left/right values following Eq. B2 in Lin 1994, MWR (132) h_L(i,j) = 0.5*( h_im1 + h_in(i,j) ) + oneSixth*( slp(i-1,j) - slp(i,j) ) h_R(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i+1,j) ) - enddo; enddo + enddo ; enddo endif if (local_open_BC) then diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 91f9f6546b..b4d00144b8 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -763,7 +763,7 @@ subroutine setup_u_point_obc(OBC, G, segment_str, l_seg, PF) if (Je_obc>Js_obc) then OBC%segment(l_seg)%direction = OBC_DIRECTION_E - else if (Je_obcIs_obc) then OBC%segment(l_seg)%direction = OBC_DIRECTION_S - else if (Ie_obc0.) then + elseif (G%mask2dCu(I,j)>0.) then h_stack(:) = h(i+ishift,j,:) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) - else if (G%mask2dCu(I,j+1)>0.) then + elseif (G%mask2dCu(I,j+1)>0.) then h_stack(:) = h(i+ishift,j+1,:) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(I,j,:), & @@ -2462,10 +2462,10 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (segment%field(m)%name == 'V') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc:je_obc)) - else if (segment%field(m)%name == 'U') then + elseif (segment%field(m)%name == 'U') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc+1:je_obc)) - else if (segment%field(m)%name == 'DVDX') then + elseif (segment%field(m)%name == 'DVDX') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) else allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) @@ -2474,10 +2474,10 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (segment%field(m)%name == 'U') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc:je_obc)) - else if (segment%field(m)%name == 'V') then + elseif (segment%field(m)%name == 'V') then allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) allocate(segment%field(m)%bt_vel(is_obc+1:ie_obc,js_obc:je_obc)) - else if (segment%field(m)%name == 'DUDY') then + elseif (segment%field(m)%name == 'DUDY') then allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) else allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) @@ -2520,30 +2520,36 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) G%dxCv(i,J)) if (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(i,J,:) = segment%normal_vel(i,J,:) enddo - elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_E_or_W .and. associated(segment%tangential_vel)) then + elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_E_or_W .and. & + associated(segment%tangential_vel)) then I=is_obc do J=js_obc,je_obc do k=1,G%ke segment%tangential_vel(I,J,k) = segment%field(m)%buffer_dst(I,J,k) enddo - if (associated(segment%nudged_tangential_vel)) segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) + if (associated(segment%nudged_tangential_vel)) & + segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) enddo - elseif (trim(segment%field(m)%name) == 'U' .and. segment%is_N_or_S .and. associated(segment%tangential_vel)) then + elseif (trim(segment%field(m)%name) == 'U' .and. segment%is_N_or_S .and. & + associated(segment%tangential_vel)) then J=js_obc do I=is_obc,ie_obc do k=1,G%ke segment%tangential_vel(I,J,k) = segment%field(m)%buffer_dst(I,J,k) enddo - if (associated(segment%nudged_tangential_vel)) segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) + if (associated(segment%nudged_tangential_vel)) & + segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) enddo - elseif (trim(segment%field(m)%name) == 'DVDX' .and. segment%is_E_or_W .and. associated(segment%tangential_grad)) then + elseif (trim(segment%field(m)%name) == 'DVDX' .and. segment%is_E_or_W .and. & + associated(segment%tangential_grad)) then I=is_obc do J=js_obc,je_obc do k=1,G%ke segment%tangential_grad(I,J,k) = segment%field(m)%buffer_dst(I,J,k) enddo enddo - elseif (trim(segment%field(m)%name) == 'DUDY' .and. segment%is_N_or_S .and. associated(segment%tangential_grad)) then + elseif (trim(segment%field(m)%name) == 'DUDY' .and. segment%is_N_or_S .and. & + associated(segment%tangential_grad)) then J=js_obc do I=is_obc,ie_obc do k=1,G%ke @@ -2583,12 +2589,12 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (associated(segment%field(m)%buffer_dst)) then do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc segment%tr_Reg%Tr(1)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) - enddo; enddo; enddo + enddo ; enddo ; enddo if (.not. segment%tr_Reg%Tr(1)%is_initialized) then ! if the tracer reservoir has not yet been initialized, then set to external value. do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc segment%tr_Reg%Tr(1)%tres(i,j,k) = segment%tr_Reg%Tr(1)%t(i,j,k) - enddo; enddo; enddo + enddo ; enddo ; enddo segment%tr_Reg%Tr(1)%is_initialized=.true. endif else @@ -2598,12 +2604,12 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (associated(segment%field(m)%buffer_dst)) then do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc segment%tr_Reg%Tr(2)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) - enddo; enddo; enddo + enddo ; enddo ; enddo if (.not. segment%tr_Reg%Tr(1)%is_initialized) then !if the tracer reservoir has not yet been initialized, then set to external value. do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc segment%tr_Reg%Tr(2)%tres(i,j,k) = segment%tr_Reg%Tr(2)%t(i,j,k) - enddo; enddo; enddo + enddo ; enddo ; enddo segment%tr_Reg%Tr(1)%is_initialized=.true. endif else diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index 37d3433330..10845e8cfa 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -78,11 +78,9 @@ module MOM_PointAccel !> This subroutine writes to an output file all of the accelerations !! that have been applied to a column of zonal velocities over the !! previous timestep. This subroutine is called from vertvisc. -subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & - maxvel, minvel, str, a, hv) +subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, vel_rpt, str, a, hv) integer, intent(in) :: I !< The zonal index of the column to be documented. - integer, intent(in) :: j !< The meridional index of the column to be - !! documented. + integer, intent(in) :: j !< The meridional index of the column to be documented. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & @@ -96,13 +94,12 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & real, intent(in) :: dt !< The ocean dynamics time step, in s. type(PointAccel_CS), pointer :: CS !< The control structure returned by a previous !! call to PointAccel_init. - real, intent(in) :: maxvel, minvel + real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report, in m s-1. real, optional, intent(in) :: str !< The surface wind stress integrated over a time !! step, in m2 s-1. - real, dimension(SZIB_(G),SZK_(G)), & - optional, intent(in) :: a !< The layer coupling coefficients from - !! vertvisc, m. - real, dimension(SZIB_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: a !< The layer coupling coefficients from vertvisc, m. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & optional, intent(in) :: hv !< The layer thicknesses at velocity grid points, !! from vertvisc, in m. @@ -110,25 +107,6 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & ! that have been applied to a column of zonal velocities over the ! previous timestep. This subroutine is called from vertvisc. -! Arguments: I - The zonal index of the column to be documented. -! (in) j - The meridional index of the column to be documented. -! (in) um - The new zonal velocity, in m s-1. -! (in) hin - The layer thickness, in m. -! (in) ADp - A structure pointing to the various accelerations in -! the momentum equations. -! (in) CDp - A structure with pointers to various terms in the continuity -! equations. -! (in) dt - The model's dynamics time step. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! PointAccel_init. -! (in) str - The surface wind stress integrated over a time -! step, in m2 s-1. -! (in) a - The layer coupling coefficients from vertvisc, m. -! (in) hv - The layer thicknesses at velocity grid points, from -! vertvisc, in m. - real :: f_eff, CFL real :: Angstrom real :: truncvel, du @@ -167,14 +145,14 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & ! Determine which layers to write out accelerations for. do k=1,nz - if (((max(CS%u_av(I,j,k),um(I,j,k)) >= maxvel) .or. & - (min(CS%u_av(I,j,k),um(I,j,k)) <= minvel)) .and. & + if (((max(CS%u_av(I,j,k),um(I,j,k)) >= vel_rpt) .or. & + (min(CS%u_av(I,j,k),um(I,j,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom)) exit enddo ks = k do k=nz,1,-1 - if (((max(CS%u_av(I,j,k), um(I,j,k)) >= maxvel) .or. & - (min(CS%u_av(I,j,k), um(I,j,k)) <= minvel)) .and. & + if (((max(CS%u_av(I,j,k), um(I,j,k)) >= vel_rpt) .or. & + (min(CS%u_av(I,j,k), um(I,j,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom)) exit enddo ke = k @@ -254,11 +232,11 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & endif if (present(a)) then write(file,'(/,"a: ",$)') - do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') a(I,k); enddo + do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') a(I,j,k); enddo endif if (present(hv)) then write(file,'(/,"hvel: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hv(I,k); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hv(I,j,k); enddo endif write(file,'(/,"Stress: ",ES10.3)') str @@ -432,11 +410,9 @@ end subroutine write_u_accel !> This subroutine writes to an output file all of the accelerations !! that have been applied to a column of meridional velocities over !! the previous timestep. This subroutine is called from vertvisc. -subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & - maxvel, minvel, str, a, hv) +subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, vel_rpt, str, a, hv) integer, intent(in) :: i !< The zonal index of the column to be documented. - integer, intent(in) :: J !< The meridional index of the column to be - !! documented. + integer, intent(in) :: J !< The meridional index of the column to be documented. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & @@ -450,13 +426,12 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & real, intent(in) :: dt !< The ocean dynamics time step, in s. type(PointAccel_CS), pointer :: CS !< The control structure returned by a previous !! call to PointAccel_init. - real, intent(in) :: maxvel, minvel + real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report, in m s-1. real, optional, intent(in) :: str !< The surface wind stress integrated over a time !! step, in m2 s-1. - real, dimension(SZI_(G),SZK_(G)), & - optional, intent(in) :: a !< The layer coupling coefficients from - !! vertvisc, m. - real, dimension(SZI_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(in) :: a !< The layer coupling coefficients from vertvisc, m. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & optional, intent(in) :: hv !< The layer thicknesses at velocity grid points, !! from vertvisc, in m. @@ -520,14 +495,14 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & prev_avail = (associated(CS%u_prev) .and. associated(CS%v_prev)) do k=1,nz - if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= maxvel) .or. & - (min(CS%v_av(i,J,k), vm(i,J,k)) <= minvel)) .and. & + if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= vel_rpt) .or. & + (min(CS%v_av(i,J,k), vm(i,J,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom)) exit enddo ks = k do k=nz,1,-1 - if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= maxvel) .or. & - (min(CS%v_av(i,J,k), vm(i,J,k)) <= minvel)) .and. & + if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= vel_rpt) .or. & + (min(CS%v_av(i,J,k), vm(i,J,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom)) exit enddo ke = k @@ -612,11 +587,11 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & endif if (present(a)) then write(file,'(/,"a: ",$)') - do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') a(i,k); enddo + do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') a(i,j,k); enddo endif if (present(hv)) then write(file,'(/,"hvel: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hv(i,k); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hv(i,J,k); enddo endif write(file,'(/,"Stress: ",ES10.3)') str diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index 2e9c80470a..53105609ca 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -96,12 +96,18 @@ end subroutine MOM_debugging_init subroutine check_redundant_vC3d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg !< An identifying message - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be checked for consistency - real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The u-component of the vector to be checked for consistency - integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency - integer, optional, intent(in) :: direction !< the direction flag to be passed to pass_vector + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The u-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -125,12 +131,18 @@ end subroutine check_redundant_vC3d subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg !< An identifying message - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be checked for consistency - real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The u-component of the vector to be checked for consistency - integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency - integer, optional, intent(in) :: direction !< the direction flag to be passed to pass_vector + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The u-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -200,9 +212,12 @@ end subroutine check_redundant_vC2d subroutine check_redundant_sB3d(mesg, array, G, is, ie, js, je) character(len=*), intent(in) :: mesg !< An identifying message - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: array !< The array to be checked for consistency - integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check ! Arguments: array - The array being checked. ! (in) mesg - A message indicating what is being checked. ! (in) G - The ocean's grid structure. @@ -225,9 +240,12 @@ end subroutine check_redundant_sB3d subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je) character(len=*), intent(in) :: mesg !< An identifying message - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(G%IsdB:,G%JsdB:), intent(in) :: array !< The array to be checked for consistency - integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check ! Arguments: array - The array being checked. ! (in) mesg - A message indicating what is being checked. ! (in) G - The ocean's grid structure. @@ -284,12 +302,18 @@ end subroutine check_redundant_sB2d subroutine check_redundant_vB3d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg !< An identifying message - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp !< The u-component of the vector to be checked for consistency - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The u-component of the vector to be checked for consistency - integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency - integer, optional, intent(in) :: direction !< the direction flag to be passed to pass_vector + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -313,12 +337,18 @@ end subroutine check_redundant_vB3d subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg !< An identifying message - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp !< The u-component of the vector to be checked for consistency - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The u-component of the vector to be checked for consistency - integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency - integer, optional, intent(in) :: direction !< the direction flag to be passed to pass_vector + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -389,9 +419,12 @@ end subroutine check_redundant_vB2d subroutine check_redundant_sT3d(mesg, array, G, is, ie, js, je) character(len=*), intent(in) :: mesg !< An identifying message - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(G%isd:,G%jsd:,:), intent(in) :: array !< The array to be checked for consistency - integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check ! Arguments: array - The array being checked. ! (in) mesg - A message indicating what is being checked. ! (in) G - The ocean's grid structure. @@ -414,9 +447,12 @@ end subroutine check_redundant_sT3d subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je) character(len=*), intent(in) :: mesg !< An identifying message - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure real, dimension(G%isd:,G%jsd:), intent(in) :: array !< The array to be checked for consistency - integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check ! Arguments: array - The array being checked. ! (in) mesg - A message indicating what is being checked. ! (in) G - The ocean's grid structure. @@ -459,12 +495,18 @@ end subroutine check_redundant_sT2d subroutine check_redundant_vT3d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg !< An identifying message - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be checked for consistency - real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The u-component of the vector to be checked for consistency - integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency - integer, optional, intent(in) :: direction !< the direction flag to be passed to pass_vector + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -488,12 +530,18 @@ end subroutine check_redundant_vT3d subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg !< An identifying message - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be checked for consistency - real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The u-component of the vector to be checked for consistency - integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency - integer, optional, intent(in) :: direction !< the direction flag to be passed to pass_vector + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -559,7 +607,7 @@ subroutine chksum_vec_C3d(mesg, u_comp, v_comp, G, halos, scalars) real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. + !! scalars that are being checked. logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -585,7 +633,7 @@ subroutine chksum_vec_C2d(mesg, u_comp, v_comp, G, halos, scalars) real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. + !! scalars that are being checked. logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -611,7 +659,7 @@ subroutine chksum_vec_B3d(mesg, u_comp, v_comp, G, halos, scalars) real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. + !! scalars that are being checked. logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -638,9 +686,9 @@ subroutine chksum_vec_B2d(mesg, u_comp, v_comp, G, halos, scalars, symmetric) real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. + !! scalars that are being checked. logical, optional, intent(in) :: symmetric !< If true, do the checksums on the - !! full symmetric computational domain. + !! full symmetric computational domain. logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -667,7 +715,7 @@ subroutine chksum_vec_A3d(mesg, u_comp, v_comp, G, halos, scalars) real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. + !! scalars that are being checked. logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -695,7 +743,7 @@ subroutine chksum_vec_A2d(mesg, u_comp, v_comp, G, halos, scalars) real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. + !! scalars that are being checked. logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 7add057e0e..8ceca4f691 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -386,7 +386,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if ((CS%id_Tpot > 0) .or. (CS%id_tob > 0)) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = gsw_pt_from_ct(tv%S(i,j,k),tv%T(i,j,k)) - enddo; enddo ; enddo + enddo ; enddo ; enddo if (CS%id_Tpot > 0) call post_data(CS%id_Tpot, work_3d, CS%diag) if (CS%id_tob > 0) call post_data(CS%id_tob, work_3d(:,:,nz), CS%diag, mask=G%mask2dT) endif @@ -403,7 +403,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & if ((CS%id_Sprac > 0) .or. (CS%id_sob > 0)) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = gsw_sp_from_sr(tv%S(i,j,k)) - enddo; enddo ; enddo + enddo ; enddo ; enddo if (CS%id_Sprac > 0) call post_data(CS%id_Sprac, work_3d, CS%diag) if (CS%id_sob > 0) call post_data(CS%id_sob, work_3d(:,:,nz), CS%diag, mask=G%mask2dT) endif @@ -691,15 +691,19 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & end subroutine calculate_diagnostic_fields -!> This subroutine finds location of R_in in an increasing ordered +!> This subroutine finds the location of R_in in an increasing ordered !! list, Rlist, returning as k the element such that !! Rlist(k) <= R_in < Rlist(k+1), and where wt and wt_p are the linear !! weights that should be assigned to elements k and k+1. subroutine find_weights(Rlist, R_in, k, nz, wt, wt_p) - real, intent(in) :: Rlist(:), R_in - integer, intent(inout) :: k - integer, intent(in) :: nz - real, intent(out) :: wt, wt_p + real, dimension(:), & + intent(in) :: Rlist !< The list of target densities, in kg m-3 + real, intent(in) :: R_in !< The density being inserted into Rlist, in kg m-3 + integer, intent(inout) :: k !< The value of k such that Rlist(k) <= R_in < Rlist(k+1) + !! The input value is a first guess + integer, intent(in) :: nz !< The number of layers in Rlist + real, intent(out) :: wt !< The weight of layer k for interpolation, nondim + real, intent(out) :: wt_p !< The weight of layer k+1 for interpolation, nondim ! This subroutine finds location of R_in in an increasing ordered ! list, Rlist, returning as k the element such that @@ -718,19 +722,19 @@ subroutine find_weights(Rlist, R_in, k, nz, wt, wt_p) if ((k_lower == 1) .or. (R_in >= Rlist(k_lower))) exit k_upper = k_lower inc = inc*2 - end do + enddo else do k_upper = min(k_upper+inc, nz) if ((k_upper == nz) .or. (R_in < Rlist(k_upper))) exit k_lower = k_upper inc = inc*2 - end do + enddo endif if ((k_lower == 1) .and. (R_in <= Rlist(k_lower))) then k = 1 ; wt = 1.0 ; wt_p = 0.0 - else if ((k_upper == nz) .and. (R_in >= Rlist(k_upper))) then + elseif ((k_upper == nz) .and. (R_in >= Rlist(k_upper))) then k = nz-1 ; wt = 0.0 ; wt_p = 1.0 else do @@ -741,7 +745,7 @@ subroutine find_weights(Rlist, R_in, k, nz, wt, wt_p) else k_lower = k_new endif - end do + enddo ! Uncomment this as a code check ! if ((R_in < Rlist(k_lower)) .or. (R_in >= Rlist(k_upper)) .or. (k_upper-k_lower /= 1)) & @@ -2060,9 +2064,12 @@ subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, CS) end subroutine set_dependent_diagnostics +!> Deallocate memory associated with the diagnostics module subroutine MOM_diagnostics_end(CS, ADp) - type(diagnostics_CS), pointer :: CS - type(accel_diag_ptrs), intent(inout) :: ADp + type(diagnostics_CS), pointer :: CS !< Control structure returned by a + !! previous call to diagnostics_init. + type(accel_diag_ptrs), intent(inout) :: ADp !< structure with pointers to + !! accelerations in momentum equation. integer :: m if (associated(CS%e)) deallocate(CS%e) diff --git a/src/diagnostics/MOM_obsolete_diagnostics.F90 b/src/diagnostics/MOM_obsolete_diagnostics.F90 index 4cf55bad3b..4bd5b61255 100644 --- a/src/diagnostics/MOM_obsolete_diagnostics.F90 +++ b/src/diagnostics/MOM_obsolete_diagnostics.F90 @@ -64,9 +64,9 @@ end subroutine register_obsolete_diagnostics !> Fakes a register of a diagnostic to find out if an obsolete !! parameter appears in the diag_table. logical function found_in_diagtable(diag, varName, newVarName) - type(diag_ctrl), intent(in) :: diag - character(len=*), intent(in) :: varName - character(len=*), optional, intent(in) :: newVarName + type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. + character(len=*), intent(in) :: varName !< The obsolete diagnostic name + character(len=*), optional, intent(in) :: newVarName !< The valid name of this diagnostic ! Local integer :: handle ! Integer handle returned from diag_manager diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 4db4d30c18..8e6cd8b8f1 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -234,7 +234,7 @@ subroutine MOM_sum_output_init(G, param_file, directory, ntrnc, & call get_filename_appendix(filename_appendix) if (len_trim(filename_appendix) > 0) then energyfile = trim(energyfile) //'.'//trim(filename_appendix) - end if + endif CS%energyfile = trim(slasher(directory))//trim(energyfile) call log_param(param_file, mdl, "output_path/ENERGYFILE", CS%energyfile) @@ -606,11 +606,11 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forc else if ((CS%timeunit >= 0.99) .and. (CS%timeunit < 1.01)) then time_units = " [seconds] " - else if ((CS%timeunit >= 3599.0) .and. (CS%timeunit < 3601.0)) then + elseif ((CS%timeunit >= 3599.0) .and. (CS%timeunit < 3601.0)) then time_units = " [hours] " - else if ((CS%timeunit >= 86399.0) .and. (CS%timeunit < 86401.0)) then + elseif ((CS%timeunit >= 86399.0) .and. (CS%timeunit < 86401.0)) then time_units = " [days] " - else if ((CS%timeunit >= 3.0e7) .and. (CS%timeunit < 3.2e7)) then + elseif ((CS%timeunit >= 3.0e7) .and. (CS%timeunit < 3.2e7)) then time_units = " [years] " else write(time_units,'(9x,"[",es8.2," s] ")') CS%timeunit @@ -1076,7 +1076,8 @@ end subroutine accumulate_net_input !! or it might be created anew. (For now only new creation occurs. subroutine depth_list_setup(G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(Sum_output_CS), pointer :: CS + type(Sum_output_CS), pointer :: CS !< The control structure returned by a + !! previous call to MOM_sum_output_init. ! This subroutine sets up an ordered list of depths, along with the ! cross sectional areas at each depth and the volume of fluid deeper ! than each depth. This might be read from a previously created file @@ -1232,10 +1233,11 @@ end subroutine create_depth_list !> This subroutine writes out the depth list to the specified file. subroutine write_depth_list(G, CS, filename, list_size) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(Sum_output_CS), pointer :: CS - character(len=*), intent(in) :: filename - integer, intent(in) :: list_size + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(Sum_output_CS), pointer :: CS !< The control structure returned by a + !! previous call to MOM_sum_output_init. + character(len=*), intent(in) :: filename !< The path to the depth list file to write. + integer, intent(in) :: list_size !< The size of the depth list. ! This subroutine writes out the depth list to the specified file. @@ -1314,9 +1316,10 @@ end subroutine write_depth_list !> This subroutine reads in the depth list to the specified file !! and allocates and sets up CS%DL and CS%list_size . subroutine read_depth_list(G, CS, filename) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(Sum_output_CS), pointer :: CS - character(len=*), intent(in) :: filename + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(Sum_output_CS), pointer :: CS !< The control structure returned by a + !! previous call to MOM_sum_output_init. + character(len=*), intent(in) :: filename !< The path to the depth list file to read. ! This subroutine reads in the depth list to the specified file ! and allocates and sets up CS%DL and CS%list_size . diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index ec4a78fc7b..9244b33738 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -120,7 +120,7 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & if (calc_modal_structure) then do k=1,nz; do j=js,je; do i=is,ie modal_structure(i,j,k) = 0.0 - enddo; enddo; enddo + enddo ; enddo ; enddo endif S => tv%S ; T => tv%T diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 88f5bc06d5..b0a889b722 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -598,7 +598,7 @@ end subroutine wave_structure !> This subroutine solves a tri-diagonal system Ax=y using either the standard !! Thomas algorithim (TDMA_T) or its more stable variant that invokes the !! "Hallberg substitution" (TDMA_H). -subroutine tridiag_solver(a,b,c,h,y,method,x) +subroutine tridiag_solver(a, b, c, h, y, method, x) real, dimension(:), intent(in) :: a !< lower diagonal with first entry equal to zero. real, dimension(:), intent(in) :: b !< middle diagonal. real, dimension(:), intent(in) :: c !< upper diagonal with last entry equal to zero. @@ -610,7 +610,7 @@ subroutine tridiag_solver(a,b,c,h,y,method,x) !! where a(k)=[-alpha(k-1/2)], b(k)=[alpha(k-1/2)+alpha(k+1/2) + h(k)], !! and c(k)=[-alpha(k+1/2)]. Only used with TDMA_H method. real, dimension(:), intent(in) :: y !< vector of known values on right hand side. - character(len=*), intent(in) :: method + character(len=*), intent(in) :: method !< A string describing the algorithm to use real, dimension(:), intent(out) :: x !< vector of unknown values to solve for. ! This subroutine solves a tri-diagonal system Ax=y using either the standard diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index dceed058f2..2df645c338 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -2341,7 +2341,7 @@ subroutine convert_temp_salt_for_TEOS10(T, S, press, G, kd, mask_z, EOS) ! S(i,j,k) = gsw_sa_from_sp(S(i,j,k),p,G%geoLonT(i,j),G%geoLatT(i,j)) T(i,j,k) = gsw_ct_from_pt(S(i,j,k),T(i,j,k)) endif - enddo; enddo; enddo + enddo ; enddo ; enddo end subroutine convert_temp_salt_for_TEOS10 ! Extractor routine for the EOS type if the members need to be accessed outside this module diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index fd880f6656..da90ef1ad7 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -198,7 +198,7 @@ integer function subchk(array, HI, di, dj, scale) do j=HI%jsc+dj,HI%jec+dj; do i=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(i,j))) subchk = subchk + bc - enddo; enddo + enddo ; enddo call sum_across_PEs(subchk) subchk=mod(subchk,1000000000) end function subchk @@ -385,7 +385,7 @@ integer function subchk(array, HI, di, dj, scale) do J=HI%jsc+dj,HI%jec+dj; do I=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(I,J))) subchk = subchk + bc - enddo; enddo + enddo ; enddo call sum_across_PEs(subchk) subchk=mod(subchk,1000000000) end function subchk @@ -573,7 +573,7 @@ integer function subchk(array, HI, di, dj, scale) do j=HI%jsc+dj,HI%jec+dj; do I=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(I,j))) subchk = subchk + bc - enddo; enddo + enddo ; enddo call sum_across_PEs(subchk) subchk=mod(subchk,1000000000) end function subchk @@ -718,7 +718,7 @@ integer function subchk(array, HI, di, dj, scale) do J=HI%jsc+dj,HI%jec+dj; do i=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(i,J))) subchk = subchk + bc - enddo; enddo + enddo ; enddo call sum_across_PEs(subchk) subchk=mod(subchk,1000000000) end function subchk diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index cae5303c96..f8e58d2072 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -45,27 +45,46 @@ module MOM_coms module procedure reproducing_sum_2d, reproducing_sum_3d end interface reproducing_sum -! The Extended Fixed Point (EFP) type provides a public interface for doing -! sums and taking differences with this type. +! The Extended Fixed Point (EFP) type provides a public interface for doing sums +! and taking differences with this type. The use of this type is documented in +! Hallberg, R. & A. Adcroft, 2014: An Order-invariant Real-to-Integer Conversion Sum. +! Parallel Computing, 40(5-6), doi:10.1016/j.parco.2014.04.007. type, public :: EFP_type ; private integer(kind=8), dimension(ni) :: v end type EFP_type -interface operator (+); module procedure EFP_plus ; end interface -interface operator (-); module procedure EFP_minus ; end interface +interface operator (+) ; module procedure EFP_plus ; end interface +interface operator (-) ; module procedure EFP_minus ; end interface interface assignment(=); module procedure EFP_assign ; end interface contains +!> This subroutine uses a conversion to an integer representation of real numbers to give an +!! order-invariant sum of distributed 2-D arrays that reproduces across domain decomposition. +!! This technique is described in Hallberg & Adcroft, 2014, Parallel Computing, +!! doi:10.1016/j.parco.2014.04.007. function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & overflow_check, err) result(sum) - real, dimension(:,:), intent(in) :: array - integer, optional, intent(in) :: isr, ier, jsr, jer - type(EFP_type), optional, intent(out) :: EFP_sum - logical, optional, intent(in) :: reproducing - logical, optional, intent(in) :: overflow_check - integer, optional, intent(out) :: err - real :: sum ! Result + real, dimension(:,:), intent(in) :: array !< The array to be summed + integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jsr !< The starting j-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jer !< The ending j-index of the sum, noting + !! that the array indices starts at 1 + type(EFP_type), optional, intent(out) :: EFP_sum !< The result in extended fixed point format + logical, optional, intent(in) :: reproducing !< If present and false, do the sum + !! using the naive non-reproducing approach + logical, optional, intent(in) :: overflow_check !< If present and false, disable + !! checking for overflows in incremental results. + !! This can speed up calculations if the number + !! of values being summed is small enough + integer, optional, intent(out) :: err !< If present, return an error code instead of + !! triggering any fatal errors directly from + !! this routine. + real :: sum !< Result ! This subroutine uses a conversion to an integer representation ! of real numbers to give order-invariant sums that will reproduce @@ -202,14 +221,27 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & end function reproducing_sum_2d +!> This subroutine uses a conversion to an integer representation of real numbers to give an +!! order-invariant sum of distributed 3-D arrays that reproduces across domain decomposition. +!! This technique is described in Hallberg & Adcroft, 2014, Parallel Computing, +!! doi:10.1016/j.parco.2014.04.007. function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & result(sum) - real, dimension(:,:,:), intent(in) :: array - integer, optional, intent(in) :: isr, ier, jsr, jer - real, dimension(:), optional, intent(out) :: sums - type(EFP_type), optional, intent(out) :: EFP_sum - integer, optional, intent(out) :: err - real :: sum ! Result + real, dimension(:,:,:), intent(in) :: array !< The array to be summed + integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jsr !< The starting j-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jer !< The ending j-index of the sum, noting + !! that the array indices starts at 1 + real, dimension(:), optional, intent(out) :: sums !< The sums by vertical layer + type(EFP_type), optional, intent(out) :: EFP_sum !< The result in extended fixed point format + integer, optional, intent(out) :: err !< If present, return an error code instead of + !! triggering any fatal errors directly from + !! this routine. + real :: sum !< Result ! This subroutine uses a conversion to an integer representation ! of real numbers to give order-invariant sums that will reproduce @@ -365,10 +397,15 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & end function reproducing_sum_3d +!> Convert a real number into the array of integers constitute its extended-fixed-point representation function real_to_ints(r, prec_error, overflow) result(ints) - real, intent(in) :: r - integer(kind=8), optional, intent(in) :: prec_error - logical, optional, intent(inout) :: overflow + real, intent(in) :: r !< The real number being converted + integer(kind=8), optional, intent(in) :: prec_error !< The PE-count dependent precision of the + !! integers that is safe from overflows during global + !! sums. This will be larger than the compile-time + !! precision parameter, and is used to detect overflows. + logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being + !! done on a value that is too large to be represented integer(kind=8), dimension(ni) :: ints ! This subroutine converts a real number to an equivalent representation ! using several long integers. @@ -401,8 +438,10 @@ function real_to_ints(r, prec_error, overflow) result(ints) end function real_to_ints +!> Convert the array of integers that constitute an extended-fixed-point +!! representation into a real number function ints_to_real(ints) result(r) - integer(kind=8), dimension(ni), intent(in) :: ints + integer(kind=8), dimension(ni), intent(in) :: ints !< The array of EFP integers real :: r ! This subroutine reverses the conversion in real_to_ints. @@ -412,10 +451,15 @@ function ints_to_real(ints) result(r) do i=1,ni ; r = r + pr(i)*ints(i) ; enddo end function ints_to_real +!> Increment an array of integers that constitutes an extended-fixed-point +!! representation with a another EFP number subroutine increment_ints(int_sum, int2, prec_error) - integer(kind=8), dimension(ni), intent(inout) :: int_sum - integer(kind=8), dimension(ni), intent(in) :: int2 - integer(kind=8), optional, intent(in) :: prec_error + integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + integer(kind=8), dimension(ni), intent(in) :: int2 !< The array of EFP integers being added + integer(kind=8), optional, intent(in) :: prec_error !!< The PE-count dependent precision of the + !! integers that is safe from overflows during global + !! sums. This will be larger than the compile-time + !! precision parameter, and is used to detect overflows. ! This subroutine increments a number with another, both using the integer ! representation in real_to_ints. @@ -441,10 +485,12 @@ subroutine increment_ints(int_sum, int2, prec_error) end subroutine increment_ints +!> Increment an EFP number with a real number without doing any carrying of +!! of overflows and using only minimal error checking. subroutine increment_ints_faster(int_sum, r, max_mag_term) - integer(kind=8), dimension(ni), intent(inout) :: int_sum - real, intent(in) :: r - real, intent(inout) :: max_mag_term + integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + real, intent(in) :: r !< The real number being added. + real, intent(inout) :: max_mag_term !< A running maximum magnitude of the r's. ! This subroutine increments a number with another, both using the integer ! representation in real_to_ints, but without doing any carrying of overflow. @@ -466,9 +512,14 @@ subroutine increment_ints_faster(int_sum, r, max_mag_term) end subroutine increment_ints_faster +!> This subroutine handles carrying of the overflow. subroutine carry_overflow(int_sum, prec_error) - integer(kind=8), dimension(ni), intent(inout) :: int_sum - integer(kind=8), intent(in) :: prec_error + integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being + !! modified by carries, but without changing value. + integer(kind=8), intent(in) :: prec_error !< The PE-count dependent precision of the + !! integers that is safe from overflows during global + !! sums. This will be larger than the compile-time + !! precision parameter, and is used to detect overflows. ! This subroutine handles carrying of the overflow. integer :: i, num_carry @@ -484,8 +535,13 @@ subroutine carry_overflow(int_sum, prec_error) end subroutine carry_overflow +!> This subroutine carries the overflow, and then makes sure that +!! all integers are of the same sign as the overall value. subroutine regularize_ints(int_sum) - integer(kind=8), dimension(ni), intent(inout) :: int_sum + integer(kind=8), dimension(ni), & + intent(inout) :: int_sum !< The array of integers being modified to take a + !! regular form with all integers of the same sign, + !! but without changing value. ! This subroutine carries the overflow, and then makes sure that ! all integers are of the same sign as the overall value. @@ -521,27 +577,34 @@ subroutine regularize_ints(int_sum) end subroutine regularize_ints +!> Returns the status of the module's error flag function query_EFP_overflow_error() logical :: query_EFP_overflow_error query_EFP_overflow_error = overflow_error end function query_EFP_overflow_error +!> Reset the module's error flag to false subroutine reset_EFP_overflow_error() overflow_error = .false. end subroutine reset_EFP_overflow_error +!> Add two extended-fixed-point numbers function EFP_plus(EFP1, EFP2) - type(EFP_type) :: EFP_plus - type(EFP_type), intent(in) :: EFP1, EFP2 + type(EFP_type) :: EFP_plus !< The result in extended fixed point format + type(EFP_type), intent(in) :: EFP1 !< The first extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The second extended fixed point number EFP_plus = EFP1 call increment_ints(EFP_plus%v(:), EFP2%v(:)) end function EFP_plus +!> Subract one extended-fixed-point number from another function EFP_minus(EFP1, EFP2) - type(EFP_type) :: EFP_minus - type(EFP_type), intent(in) :: EFP1, EFP2 + type(EFP_type) :: EFP_minus !< The result in extended fixed point format + type(EFP_type), intent(in) :: EFP1 !< The first extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The extended fixed point number being + !! subtracted from the first extended fixed point number integer :: i do i=1,ni ; EFP_minus%v(i) = -1*EFP2%v(i) ; enddo @@ -549,9 +612,10 @@ function EFP_minus(EFP1, EFP2) call increment_ints(EFP_minus%v(:), EFP1%v(:)) end function EFP_minus +!> Copy one extended-fixed-point number into another subroutine EFP_assign(EFP1, EFP2) - type(EFP_type), intent(out) :: EFP1 - type(EFP_type), intent(in) :: EFP2 + type(EFP_type), intent(out) :: EFP1 !< The recipient extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The source extended fixed point number integer i ! This subroutine assigns all components of the extended fixed point type ! variable on the RHS (EFP2) to the components of the variable on the LHS @@ -560,17 +624,22 @@ subroutine EFP_assign(EFP1, EFP2) do i=1,ni ; EFP1%v(i) = EFP2%v(i) ; enddo end subroutine EFP_assign +!> Return the real number that an extended-fixed-point number corresponds with function EFP_to_real(EFP1) - type(EFP_type), intent(inout) :: EFP1 + type(EFP_type), intent(inout) :: EFP1 !< The extended fixed point number being converted real :: EFP_to_real call regularize_ints(EFP1%v) EFP_to_real = ints_to_real(EFP1%v) end function EFP_to_real +!> Take the difference between two extended-fixed-point numbers (EFP1 - EFP2) +!! and return the result as a real number function EFP_real_diff(EFP1, EFP2) - type(EFP_type), intent(in) :: EFP1, EFP2 - real :: EFP_real_diff + type(EFP_type), intent(in) :: EFP1 !< The first extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The extended fixed point number being + !! subtracted from the first extended fixed point number + real :: EFP_real_diff !< The real result type(EFP_type) :: EFP_diff @@ -579,9 +648,11 @@ function EFP_real_diff(EFP1, EFP2) end function EFP_real_diff +!> Return the extended-fixed-point number that a real number corresponds with function real_to_EFP(val, overflow) - real, intent(in) :: val - logical, optional, intent(inout) :: overflow + real, intent(in) :: val !< The real number being converted + logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being + !! done on a value that is too large to be represented type(EFP_type) :: real_to_EFP logical :: over @@ -600,10 +671,15 @@ function real_to_EFP(val, overflow) end function real_to_EFP +!< This subroutine does a sum across PEs of a list of EFP variables, +!! returning the sums in place, with all overflows carried. subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) - type(EFP_type), dimension(:), intent(inout) :: EFPs - integer, intent(in) :: nval - logical, dimension(:), optional, intent(out) :: errors + type(EFP_type), dimension(:), & + intent(inout) :: EFPs !< The list of extended fixed point numbers + !! being summed across PEs. + integer, intent(in) :: nval !< The number of values being summed. + logical, dimension(:), & + optional, intent(out) :: errors !< A list of error flags for each sum ! This subroutine does a sum across PEs of a list of EFP variables, ! returning the sums in place, with all overflows carried. @@ -645,6 +721,8 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) end subroutine EFP_list_sum_across_PEs +!< This subroutine carries out all of the calls required to close out the infrastructure cleanly. +!! This should only be called in ocean-only runs, as the coupler takes care of this in coupled runs. subroutine MOM_infra_end ! This subroutine should contain all of the calls that are required ! to close out the infrastructure cleanly. This should only be called diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 34bde56f02..67b8789109 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -691,9 +691,10 @@ subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_num end subroutine define_axes_group +!> Set up the array extents for doing diagnostics subroutine set_diag_mediator_grid(G, diag_cs) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(diag_ctrl), intent(inout) :: diag_cs + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output ! Arguments: ! (inout) G - ocean grid structure @@ -706,11 +707,13 @@ subroutine set_diag_mediator_grid(G, diag_cs) end subroutine set_diag_mediator_grid +!> Make a real scalar diagnostic available for averaging or output subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) - integer, intent(in) :: diag_field_id - real, intent(in) :: field - type(diag_ctrl), target, intent(in) :: diag_cs - logical, optional, intent(in) :: is_static + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field !< real value being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. ! Arguments: ! (in) diag_field_id - the id for an output variable returned by a @@ -743,16 +746,18 @@ subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) end subroutine post_data_0d +!> Make a real 1-d array diagnostic available for averaging or output subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static) - integer, intent(in) :: diag_field_id - real, intent(in) :: field(:) - type(diag_ctrl), target, intent(in) :: diag_cs - logical, optional, intent(in) :: is_static + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field(:) !< 1-d array being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. ! Arguments: ! (in) diag_field_id - id for an output variable returned by a ! previous call to register_diag_field. -! (in) field - 3-d array being offered for output or averaging +! (in) field - 1-d array being offered for output or averaging ! (inout) diag_cs - structure used to regulate diagnostic output ! (in) static - If true, this is a static field that is always offered. @@ -780,12 +785,14 @@ subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static) if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) end subroutine post_data_1d_k +!> Make a real 2-d array diagnostic available for averaging or output subroutine post_data_2d(diag_field_id, field, diag_cs, is_static, mask) - integer, intent(in) :: diag_field_id - real, intent(in) :: field(:,:) - type(diag_ctrl), target, intent(in) :: diag_cs - logical, optional, intent(in) :: is_static - real, optional, intent(in) :: mask(:,:) + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. ! Arguments: ! (in) diag_field_id - id for an output variable returned by a @@ -811,12 +818,14 @@ subroutine post_data_2d(diag_field_id, field, diag_cs, is_static, mask) if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) end subroutine post_data_2d +!> Make a real 2-d array diagnostic available for averaging or output +!! using a diag_type instead of an integer id. subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) - type(diag_type), intent(in) :: diag - real, target, intent(in) :: field(:,:) - type(diag_ctrl), intent(in) :: diag_cs - logical, optional, intent(in) :: is_static - real, optional, intent(in) :: mask(:,:) + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + real, target, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. ! Arguments: ! (in) diag - structure representing the diagnostic to post @@ -916,14 +925,18 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) end subroutine post_data_2d_low +!> Make a real 3-d array diagnostic available for averaging or output. subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) - integer, intent(in) :: diag_field_id - real, intent(in) :: field(:,:,:) - type(diag_ctrl), target, intent(in) :: diag_cs - logical, optional, intent(in) :: is_static - real, optional, intent(in) :: mask(:,:,:) - real, target, optional, intent(in) :: alt_h(:,:,:) + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + real, dimension(:,:,:), & + target, optional, intent(in) :: alt_h !< An alternate thickness to use for vertically + !! remapping this diagnostic, in H. ! Arguments: ! (in) diag_field_id - id for an output variable returned by a @@ -1039,12 +1052,14 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) end subroutine post_data_3d +!> Make a real 3-d array diagnostic available for averaging or output +!! using a diag_type instead of an integer id. subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) - type(diag_type), intent(in) :: diag - real, target, intent(in) :: field(:,:,:) - type(diag_ctrl), intent(in) :: diag_cs - logical, optional, intent(in) :: is_static - real, optional, intent(in) :: mask(:,:,:) + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + real, target, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. ! Arguments: ! (in) diag - the diagnostic to post. @@ -1217,10 +1232,12 @@ subroutine post_xy_average(diag_cs, diag, field) weight=diag_cs%time_int) end subroutine post_xy_average +!> This subroutine enables the accumulation of time averages over the specified time interval. subroutine enable_averaging(time_int_in, time_end_in, diag_cs) - real, intent(in) :: time_int_in - type(time_type), intent(in) :: time_end_in - type(diag_ctrl), intent(inout) :: diag_cs + real, intent(in) :: time_int_in !< The time interval in s over which any + !! values that are offered are valid. + type(time_type), intent(in) :: time_end_in !< The end time of the valid interval + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output ! This subroutine enables the accumulation of time averages over the ! specified time interval. @@ -1228,7 +1245,7 @@ subroutine enable_averaging(time_int_in, time_end_in, diag_cs) ! Arguments: ! (in) time_int_in - time interval in s over which any ! values that are offered are valid. -! (in) time_end_in - end time in s of the valid interval +! (in) time_end_in - end time of the valid interval ! (inout) diag - structure used to regulate diagnostic output ! if (num_file==0) return @@ -1237,9 +1254,9 @@ subroutine enable_averaging(time_int_in, time_end_in, diag_cs) diag_cs%ave_enabled = .true. end subroutine enable_averaging -! Call this subroutine to avoid averaging any offered fields. +!> Call this subroutine to avoid averaging any offered fields. subroutine disable_averaging(diag_cs) - type(diag_ctrl), intent(inout) :: diag_cs + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output ! Argument: ! diag - structure used to regulate diagnostic output @@ -1249,12 +1266,12 @@ subroutine disable_averaging(diag_cs) end subroutine disable_averaging -! Call this subroutine to determine whether the averaging is -! currently enabled. .true. is returned if it is. +!> Call this subroutine to determine whether the averaging is +!! currently enabled. .true. is returned if it is. function query_averaging_enabled(diag_cs, time_int, time_end) - type(diag_ctrl), intent(in) :: diag_cs - real, optional, intent(out) :: time_int - type(time_type), optional, intent(out) :: time_end + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + real, optional, intent(out) :: time_int !< Current setting of diag%time_int, in s + type(time_type), optional, intent(out) :: time_end !< Current setting of diag%time_end logical :: query_averaging_enabled ! Arguments: @@ -1267,15 +1284,13 @@ function query_averaging_enabled(diag_cs, time_int, time_end) query_averaging_enabled = diag_cs%ave_enabled end function query_averaging_enabled +!> This function returns the valid end time for use with diagnostics that are +!! handled outside of the MOM6 diagnostics infrastructure. function get_diag_time_end(diag_cs) - type(diag_ctrl), intent(in) :: diag_cs + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(time_type) :: get_diag_time_end - -! Argument: -! (in) diag - structure used to regulate diagnostic output - -! This function returns the valid end time for diagnostics that are handled -! outside of the MOM6 infrastructure, such as via the generic tracer code. + ! This function returns the valid end time for diagnostics that are handled + ! outside of the MOM6 infrastructure, such as via the generic tracer code. get_diag_time_end = diag_cs%time_end end function get_diag_time_end @@ -1326,7 +1341,7 @@ integer function register_diag_field(module_name, field_name, axes, init_time, & !! integrated). Default/absent for intensive. ! Local variables real :: MOM_missing_value - type(diag_ctrl), pointer :: diag_cs + type(diag_ctrl), pointer :: diag_cs => NULL() type(axes_grp), pointer :: remap_axes => null() integer :: dm_id, i character(len=256) :: new_module_name @@ -1447,7 +1462,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, !! integrated). Default/absent for intensive. ! Local variables real :: MOM_missing_value - type(diag_ctrl), pointer :: diag_cs + type(diag_ctrl), pointer :: diag_cs => null() type(diag_type), pointer :: this_diag => null() integer :: fms_id, fms_xyave_id character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name, cm_string, msg @@ -1812,16 +1827,25 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & do_not_log, err_msg, interp_method, cmor_field_name, & cmor_long_name, cmor_units, cmor_standard_name) integer :: register_scalar_field - character(len=*), intent(in) :: module_name, field_name - type(time_type), intent(in) :: init_time - type(diag_ctrl), intent(inout) :: diag_cs - character(len=*), optional, intent(in) :: long_name, units, standard_name - real, optional, intent(in) :: missing_value, range(2) - logical, optional, intent(in) :: do_not_log - character(len=*), optional, intent(out):: err_msg - character(len=*), optional, intent(in) :: interp_method - character(len=*), optional, intent(in) :: cmor_field_name, cmor_long_name - character(len=*), optional, intent(in) :: cmor_units, cmor_standard_name + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field + character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field + character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field + character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field ! Output: An integer handle for a diagnostic array. ! Arguments: @@ -1918,15 +1942,26 @@ function register_static_field(module_name, field_name, axes, & cmor_field_name, cmor_long_name, cmor_units, cmor_standard_name, area, & x_cell_method, y_cell_method, area_cell_method) integer :: register_static_field - character(len=*), intent(in) :: module_name, field_name - type(axes_grp), target, intent(in) :: axes - character(len=*), optional, intent(in) :: long_name, units, standard_name - real, optional, intent(in) :: missing_value, range(2) - logical, optional, intent(in) :: mask_variant, do_not_log - character(len=*), optional, intent(in) :: interp_method - integer, optional, intent(in) :: tile_count - character(len=*), optional, intent(in) :: cmor_field_name, cmor_long_name - character(len=*), optional, intent(in) :: cmor_units, cmor_standard_name + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that + !! indicates axes for this field + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with + !! post_data calls (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field + character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field + character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field + character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field integer, optional, intent(in) :: area !< fms_id for area_t character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. @@ -1950,7 +1985,7 @@ function register_static_field(module_name, field_name, axes, & ! (in,opt) tile_count - no clue real :: MOM_missing_value - type(diag_ctrl), pointer :: diag_cs + type(diag_ctrl), pointer :: diag_cs => null() type(diag_type), pointer :: diag => null(), cmor_diag => null() integer :: dm_id, fms_id, cmor_id character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name @@ -2046,9 +2081,11 @@ function register_static_field(module_name, field_name, axes, & end function register_static_field +!> Describe an option setting in the diagnostic files. subroutine describe_option(opt_name, value, diag_CS) - character(len=*), intent(in) :: opt_name, value - type(diag_ctrl), intent(in) :: diag_CS + character(len=*), intent(in) :: opt_name !< The name of the option + character(len=*), intent(in) :: value !< A character string with the setting of the option. + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output character(len=240) :: mesg integer :: len_ind @@ -2161,13 +2198,13 @@ function ocean_register_diag(var_desc, G, diag_CS, day) end select ocean_register_diag = register_diag_field("ocean_model", trim(var_name), & - axes, day, trim(longname), trim(units), missing_value = -1.0e+34) + axes, day, trim(longname), trim(units), missing_value=-1.0e+34) end function ocean_register_diag subroutine diag_mediator_infrastructure_init(err_msg) ! This subroutine initializes the FMS diag_manager. - character(len=*), optional, intent(out) :: err_msg + character(len=*), optional, intent(out) :: err_msg !< An error message call diag_manager_init(err_msg=err_msg) end subroutine diag_mediator_infrastructure_init @@ -2455,7 +2492,7 @@ subroutine diag_masks_set(G, nz, diag_cs) end subroutine diag_masks_set subroutine diag_mediator_close_registration(diag_CS) - type(diag_ctrl), intent(inout) :: diag_CS + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output integer :: i @@ -2470,8 +2507,8 @@ subroutine diag_mediator_close_registration(diag_CS) end subroutine diag_mediator_close_registration subroutine diag_mediator_end(time, diag_CS, end_diag_manager) - type(time_type), intent(in) :: time - type(diag_ctrl), intent(inout) :: diag_cs + type(time_type), intent(in) :: time !< The current model time + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: end_diag_manager !< If true, call diag_manager_end() ! Local variables @@ -2510,24 +2547,26 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) end subroutine diag_mediator_end +!> Convert the first n elements (up to 3) of an integer array to an underscore delimited string. function i2s(a,n_in) -! "Convert the first n elements of an integer array to a string." - integer, dimension(:), intent(in) :: a - integer, optional , intent(in) :: n_in - character(len=15) :: i2s - - character(len=15) :: i2s_temp - integer :: i,n - - n=size(a) - if (present(n_in)) n = n_in - - i2s = '' - do i=1,n - write (i2s_temp, '(I4.4)') a(i) - i2s = trim(i2s) //'_'// trim(i2s_temp) - enddo - i2s = adjustl(i2s) + ! "Convert the first n elements of an integer array to a string." + ! Perhaps this belongs elsewhere in the MOM6 code? + integer, dimension(:), intent(in) :: a !< The array of integers to translate + integer, optional , intent(in) :: n_in !< The number of elements to translate, by default all + character(len=15) :: i2s !< The returned string + + character(len=15) :: i2s_temp + integer :: i,n + + n=size(a) + if (present(n_in)) n = n_in + + i2s = '' + do i=1,min(n,3) + write (i2s_temp, '(I4.4)') a(i) + i2s = trim(i2s) //'_'// trim(i2s_temp) + enddo + i2s = adjustl(i2s) end function i2s !> Returns a new diagnostic id, it may be necessary to expand the diagnostics array. diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 9ba8988d0f..c43f8f5026 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -209,7 +209,7 @@ end subroutine diag_remap_get_axes_info !! Configuration is complete when diag_remap_configure_axes() has been !! successfully called. function diag_remap_axes_configured(remap_cs) - type(diag_remap_ctrl), intent(in) :: remap_cs + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure logical :: diag_remap_axes_configured diag_remap_axes_configured = remap_cs%configured diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 10346f2542..0d68dc5dfb 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -1421,7 +1421,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & integer, optional, intent(in) :: NJPROC !< Processor counts, required with !! static memory. integer, dimension(2), optional, intent(inout) :: min_halo !< If present, this sets the - !! minimum halo size for this domain in the x- and y- + !! minimum halo size for this domain in the i- and j- !! directions, and returns the actual halo size used. character(len=*), optional, intent(in) :: domain_name !< A name for this domain, "MOM" !! if missing. @@ -1444,7 +1444,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! (in,opt) NIGLOBAL, NJGLOBAL - Total domain sizes, required with static memory. ! (in,opt) NIPROC, NJPROC - Processor counts, required with static memory. ! (in,opt) min_halo - If present, this sets the minimum halo size for this -! domain in the x- and y- directions, and returns the +! domain in the i- and j- directions, and returns the ! actual halo size used. ! (in,opt) domain_name - A name for this domain, "MOM" if missing. ! (in,opt) include_name - A name for model's include file, "MOM_memory.h" if missing. @@ -1717,7 +1717,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & "STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.",& layoutParam=.true.) call log_param(param_file, mdl, trim(njproc_nm), layout(2), & - "The number of processors in the x-direction. With \n"//& + "The number of processors in the x-direction. With \n"//& !### FIX THIS COMMENT "STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.",& layoutParam=.true.) call log_param(param_file, mdl, trim(layout_nm), layout, & @@ -1738,7 +1738,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & call parse_mask_table(mask_table, MOM_dom%maskmap, dom_name) endif - ! Set up the I/O lay-out, and check that it uses an even multiple of the + ! Set up the I/O layout, and check that it uses an even multiple of the ! number of PEs in each direction. io_layout(:) = (/ 1, 1 /) call get_param(param_file, mdl, trim(io_layout_nm), io_layout, & @@ -1751,8 +1751,8 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & &"are not allowed in ")') io_layout(1) call MOM_error(FATAL, mesg//trim(IO_layout_nm)) elseif (io_layout(1) > 0) then ; if (modulo(layout(1), io_layout(1)) /= 0) then - write(mesg,'("MOM_domains_init: The x-direction I/O-layout, IO_LAYOUT(1)=",i4, & - &", does not evenly divide the x-direction layout, NIPROC=,",i4,".")') & + write(mesg,'("MOM_domains_init: The i-direction I/O-layout, IO_LAYOUT(1)=",i4, & + &", does not evenly divide the i-direction layout, NIPROC=,",i4,".")') & io_layout(1),layout(1) call MOM_error(FATAL, mesg) endif ; endif @@ -1762,8 +1762,8 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & &"are not allowed in ")') io_layout(2) call MOM_error(FATAL, mesg//trim(IO_layout_nm)) elseif (io_layout(2) /= 0) then ; if (modulo(layout(2), io_layout(2)) /= 0) then - write(mesg,'("MOM_domains_init: The y-direction I/O-layout, IO_LAYOUT(2)=",i4, & - &", does not evenly divide the y-direction layout, NJPROC=,",i4,".")') & + write(mesg,'("MOM_domains_init: The j-direction I/O-layout, IO_LAYOUT(2)=",i4, & + &", does not evenly divide the j-direction layout, NJPROC=,",i4,".")') & io_layout(2),layout(2) call MOM_error(FATAL, mesg) endif ; endif @@ -1834,12 +1834,23 @@ end subroutine MOM_domains_init !! some properties of the new type to differ from the original one. subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & domain_name) - type(MOM_domain_type), intent(in) :: MD_in - type(MOM_domain_type), pointer :: MOM_dom - integer, dimension(2), optional, intent(inout) :: min_halo - integer, optional, intent(in) :: halo_size - logical, optional, intent(in) :: symmetric - character(len=*), optional, intent(in) :: domain_name + type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain + type(MOM_domain_type), pointer :: MOM_dom !< A pointer to a MOM_domain that will be + !! allocated if it is unassociated, and will have data + !! copied from MD_in + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domian in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, "MOM" + !! if missing. integer :: global_indices(4) logical :: mask_table_exists @@ -1915,12 +1926,21 @@ end subroutine clone_MD_to_MD !! the original one. subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & domain_name) - type(MOM_domain_type), intent(in) :: MD_in - type(domain2d), intent(inout) :: mpp_domain - integer, dimension(2), optional, intent(inout) :: min_halo - integer, optional, intent(in) :: halo_size - logical, optional, intent(in) :: symmetric - character(len=*), optional, intent(in) :: domain_name + type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain to be cloned + type(domain2d), intent(inout) :: mpp_domain !< The new mpp_domain to be set up + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domian in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, "MOM" + !! if missing. integer :: global_indices(4), layout(2), io_layout(2) integer :: X_FLAGS, Y_FLAGS, niglobal, njglobal, nihalo, njhalo @@ -1981,7 +2001,7 @@ subroutine get_domain_extent(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & isg, ieg, jsg, jeg, idg_offset, jdg_offset, & symmetric, local_indexing, index_offset) type(MOM_domain_type), & - intent(in) :: Domain + intent(in) :: Domain !< The MOM domain from which to extract information integer, intent(out) :: isc, iec, jsc, jec !< The start & end indices of the computational !! domain. integer, intent(out) :: isd, ied, jsd, jed !< The start & end indices of the data domain. @@ -2042,7 +2062,7 @@ end subroutine get_domain_extent !> Returns the global shape of h-point arrays subroutine get_global_shape(domain, niglobal, njglobal) - type(MOM_domain_type), intent(in) :: domain !< MOM domain + type(MOM_domain_type), intent(in) :: domain !< MOM domain integer, intent(out) :: niglobal !< i-index global size of h-point arrays integer, intent(out) :: njglobal !< j-index global size of h-point arrays diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index a2531fdac9..5cf0417d09 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -618,7 +618,8 @@ end subroutine read_param_int !> This subroutine reads the values of an array of integer model parameters from a parameter file. subroutine read_param_int_array(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS !< The control structure for this parameter, which is also a structure to parse for run-time parameters + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read integer, dimension(:), intent(inout) :: value !< The value of the parameter that may be !! read from the parameter file @@ -1349,7 +1350,8 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & !! present, this paramter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter integer, optional, intent(in) :: default !< The default value of the parameter - logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is logged in the layout parameter file + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is !! logged in the debugging parameter file ! This subroutine writes the value of an integer parameter to a log file, @@ -1682,7 +1684,8 @@ subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read - integer, dimension(:), intent(inout) :: value !< The value of the parameter that may be reset from the parameter file + integer, dimension(:), intent(inout) :: value !< The value of the parameter that may be reset + !! from the parameter file character(len=*), optional, intent(in) :: desc !< A description of this variable; if not !! present, this paramter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 176e6e6d13..d4f8dbff57 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -225,7 +225,7 @@ subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug endif enddo enddo - else if (nfill == nfill_prev) then + elseif (nfill == nfill_prev) then print *,& 'Unable to fill missing points using either data at the same vertical level from a connected basin'//& 'or using a point from a previous vertical level. Make sure that the original data has some valid'//& @@ -236,7 +236,7 @@ subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug nfill = sum(fill_pts(is:ie,js:je)) call sum_across_PEs(nfill) - end do + enddo if (do_smooth) then do k=1,npass @@ -1010,7 +1010,7 @@ subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) zi(:,:)=mp(1:ni,1:nj) mp = fill_boundaries(zi,cyclic_x,tripolar_n) -end do +enddo diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index 6e829c2072..664f87ad3f 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -9,23 +9,25 @@ module MOM_intrinsic_functions !* * !********+*********+*********+*********+*********+*********+*********+** - implicit none - private +implicit none ; private - public :: invcosh +public :: invcosh - contains +contains - function invcosh(x) - real, intent(in) :: x - real :: invcosh +!> Evaluate the inverse cosh, either using a math library or an +!! equivalent expression +function invcosh(x) + real, intent(in) :: x !< The argument of the inverse of cosh. NaNs will + !! occur if x<1, but there is no error checking + real :: invcosh #ifdef __INTEL_COMPILER - invcosh=acosh(x) + invcosh = acosh(x) #else - invcosh=log(x+sqrt(x*x-1)) + invcosh = log(x+sqrt(x*x-1)) #endif - end function invcosh +end function invcosh end module MOM_intrinsic_functions diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 079ac6ba3a..178924d0d7 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -216,7 +216,7 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//& " has unrecognized t_grid "//trim(vars(k)%t_grid)) end select - end do + enddo if ((use_lath .or. use_lonh .or. use_latq .or. use_lonq)) then if (.not.domain_set) call MOM_error(FATAL, "create_file: "//& @@ -260,13 +260,13 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit ! Set appropriate units, depending on the value. if (timeunit < 0.0) then time_units = "days" ! The default value. - else if ((timeunit >= 0.99) .and. (timeunit < 1.01)) then + elseif ((timeunit >= 0.99) .and. (timeunit < 1.01)) then time_units = "seconds" - else if ((timeunit >= 3599.0) .and. (timeunit < 3601.0)) then + elseif ((timeunit >= 3599.0) .and. (timeunit < 3601.0)) then time_units = "hours" - else if ((timeunit >= 86399.0) .and. (timeunit < 86401.0)) then + elseif ((timeunit >= 86399.0) .and. (timeunit < 86401.0)) then time_units = "days" - else if ((timeunit >= 3.0e7) .and. (timeunit < 3.2e7)) then + elseif ((timeunit >= 3.0e7) .and. (timeunit < 3.2e7)) then time_units = "years" else write(time_units,'(es8.2," s")') timeunit @@ -433,10 +433,11 @@ subroutine reopen_file(unit, filename, vars, novars, fields, threading, timeunit end subroutine reopen_file - +!> Read the data associated with a named axis in a file subroutine read_axis_data(filename, axis_name, var) - character(len=*), intent(in) :: filename, axis_name - real, dimension(:), intent(out) :: var + character(len=*), intent(in) :: filename !< Name of the file to read + character(len=*), intent(in) :: axis_name !< Name of the axis to read + real, dimension(:), intent(out) :: var !< The axis location data integer :: i,len,unit, ndim, nvar, natt, ntime logical :: axis_found diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 6944647008..d2d782e2c1 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -147,7 +147,8 @@ module MOM_restart !> Register a 3-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) - real, dimension(:,:,:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -177,7 +178,8 @@ end subroutine register_restart_field_ptr3d !> Register a 4-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS) - real, dimension(:,:,:,:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -207,7 +209,8 @@ end subroutine register_restart_field_ptr4d !> Register a 2-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS) - real, dimension(:,:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -237,7 +240,7 @@ end subroutine register_restart_field_ptr2d !> Register a 1-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS) - real, dimension(:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -267,7 +270,7 @@ end subroutine register_restart_field_ptr1d !> Register a 0-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS) - real, target :: f_ptr !< A pointer to the field to be read or written + real, target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -300,7 +303,8 @@ end subroutine register_restart_field_ptr0d !> Register a 4-d field for restarts, providing the metadata as individual arguments subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units, & hor_grid, z_grid, t_grid) - real, dimension(:,:,:,:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -326,7 +330,8 @@ end subroutine register_restart_field_4d !> Register a 3-d field for restarts, providing the metadata as individual arguments subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units, & hor_grid, z_grid, t_grid) - real, dimension(:,:,:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -352,7 +357,8 @@ end subroutine register_restart_field_3d !> Register a 2-d field for restarts, providing the metadata as individual arguments subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units, & hor_grid, z_grid, t_grid) - real, dimension(:,:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:,:), & + target, intent(in) :: f_ptr !< A pointer to the field to be read or written character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -380,7 +386,7 @@ end subroutine register_restart_field_2d !> Register a 1-d field for restarts, providing the metadata as individual arguments subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units, & hor_grid, z_grid, t_grid) - real, dimension(:), target :: f_ptr !< A pointer to the field to be read or written + real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field to be read or written character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -408,7 +414,7 @@ end subroutine register_restart_field_1d !> Register a 0-d field for restarts, providing the metadata as individual arguments subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units, & t_grid) - real, target :: f_ptr !< A pointer to the field to be read or written + real, target, intent(in) :: f_ptr !< A pointer to the field to be read or written character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -432,8 +438,8 @@ end subroutine register_restart_field_0d !> query_initialized_name determines whether a named field has been successfully !! read from a restart file yet. function query_initialized_name(name, CS) result(query_initialized) - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine returns .true. if the field referred to by name has ! initialized from a restart file, and .false. otherwise. @@ -467,9 +473,10 @@ function query_initialized_name(name, CS) result(query_initialized) end function query_initialized_name +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_0d(f_ptr, CS) result(query_initialized) - real, target :: f_ptr - type(MOM_restart_CS), pointer :: CS + real, target, intent(in) :: f_ptr !< A pointer to the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. @@ -496,9 +503,10 @@ function query_initialized_0d(f_ptr, CS) result(query_initialized) end function query_initialized_0d +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_1d(f_ptr, CS) result(query_initialized) - real, dimension(:), target :: f_ptr - type(MOM_restart_CS), pointer :: CS + real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. @@ -525,9 +533,11 @@ function query_initialized_1d(f_ptr, CS) result(query_initialized) end function query_initialized_1d +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_2d(f_ptr, CS) result(query_initialized) - real, dimension(:,:), target :: f_ptr - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. @@ -554,9 +564,11 @@ function query_initialized_2d(f_ptr, CS) result(query_initialized) end function query_initialized_2d +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_3d(f_ptr, CS) result(query_initialized) - real, dimension(:,:,:), target :: f_ptr - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. @@ -583,9 +595,11 @@ function query_initialized_3d(f_ptr, CS) result(query_initialized) end function query_initialized_3d +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_4d(f_ptr, CS) result(query_initialized) - real, dimension(:,:,:,:), target :: f_ptr - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. @@ -612,10 +626,12 @@ function query_initialized_4d(f_ptr, CS) result(query_initialized) end function query_initialized_4d +!> Indicate whether the field pointed to by f_ptr or with the specified variable +!! name has been initialized from a restart file. function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) - real, target :: f_ptr - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + real, target, intent(in) :: f_ptr !< A pointer to the field that is being queried + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. @@ -649,10 +665,13 @@ function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_0d_name +!> Indicate whether the field pointed to by f_ptr or with the specified variable +!! name has been initialized from a restart file. function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) - real, dimension(:), target :: f_ptr - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + real, dimension(:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. @@ -686,10 +705,13 @@ function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_1d_name +!> Indicate whether the field pointed to by f_ptr or with the specified variable +!! name has been initialized from a restart file. function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) - real, dimension(:,:), target :: f_ptr - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. @@ -723,10 +745,13 @@ function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_2d_name +!> Indicate whether the field pointed to by f_ptr or with the specified variable +!! name has been initialized from a restart file. function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) - real, dimension(:,:,:), target :: f_ptr - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. @@ -760,10 +785,13 @@ function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_3d_name +!> Indicate whether the field pointed to by f_ptr or with the specified variable +!! name has been initialized from a restart file. function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) - real, dimension(:,:,:,:), target :: f_ptr - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. @@ -797,14 +825,17 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_4d_name +!> save_restart saves all registered variables to restart files. subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) -! save_restart saves all registered variables to restart files. - character(len=*), intent(in) :: directory - type(time_type), intent(in) :: time - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(MOM_restart_CS), pointer :: CS - logical, optional, intent(in) :: time_stamped - character(len=*), optional, intent(in) :: filename + character(len=*), intent(in) :: directory !< The directory where the restart files + !! are to be written + type(time_type), intent(in) :: time !< The current model time + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous + !! call to restart_init. + logical, optional, intent(in) :: time_stamped !< If present and true, add time-stamp + !! to the restart file names. + character(len=*), optional, intent(in) :: filename !< A filename that overrides the name in CS%restartfile. type(verticalGrid_type), optional, intent(in) :: GV !< The ocean's vertical grid structure ! Arguments: directory - The directory where the restart file goes. ! (in) time - The time of this restart file. @@ -869,7 +900,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) seconds = seconds + 60*minute + 3600*hour if (year <= 9999) then write(restartname,'("_Y",I4.4,"_D",I3.3,"_S",I5.5)') year, days, seconds - else if (year <= 99999) then + elseif (year <= 99999) then write(restartname,'("_Y",I5.5,"_D",I3.3,"_S",I5.5)') year, days, seconds else write(restartname,'("_Y",I10.10,"_D",I3.3,"_S",I5.5)') year, days, seconds @@ -920,8 +951,8 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' else restartname = restartname(1:length) //'.'//trim(filename_appendix) - end if - end if + endif + endif restartpath = trim(directory)// trim(restartname) @@ -1453,8 +1484,8 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' else restartname = restartname(1:length) //'.'//trim(filename_appendix) - end if - end if + endif + endif filepath = trim(directory) // trim(restartname) if (num_restart < 10) then @@ -1531,10 +1562,14 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & end function open_restart_units +!> Initialize this module and set up a restart control structure. subroutine restart_init(param_file, CS, restart_root) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(MOM_restart_CS), pointer :: CS - character(len=*), optional, intent(in) :: restart_root + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object that is allocated here + character(len=*), optional, & + intent(in) :: restart_root !< A filename root that overrides the value + !! set by RESTARTFILE to enable the use of this module by + !! other components than MOM. ! Arguments: param_file - A structure indicating the open file to parse for ! model parameter values. ! (in/out) CS - A pointer that is set to point to the control structure @@ -1590,8 +1625,9 @@ subroutine restart_init(param_file, CS, restart_root) end subroutine restart_init +!> Indicate that all variables have now been registered. subroutine restart_init_end(CS) - type(MOM_restart_CS), pointer :: CS + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object if (associated(CS)) then if (CS%novars == 0) call restart_end(CS) @@ -1599,8 +1635,9 @@ subroutine restart_init_end(CS) end subroutine restart_init_end +!> Deallocate memory associated with a MOM_restart_CS variable. subroutine restart_end(CS) - type(MOM_restart_CS), pointer :: CS + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object if (associated(CS%restart_field)) deallocate(CS%restart_field) if (associated(CS%var_ptr0d)) deallocate(CS%var_ptr0d) @@ -1613,7 +1650,7 @@ subroutine restart_end(CS) end subroutine restart_end subroutine restart_error(CS) - type(MOM_restart_CS), pointer :: CS + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object ! Arguments: CS - A pointer that is set to point to the control structure ! for this module. (Intent in.) character(len=16) :: num ! String for error messages diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index 38c4b61180..9e2d312887 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -23,9 +23,10 @@ module MOM_spatial_means contains +!> Return the global area mean of a variable. This uses reproducing sums. function global_area_mean(var,G) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var + real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var !< The variable to average real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming real :: global_area_mean @@ -40,9 +41,10 @@ function global_area_mean(var,G) end function global_area_mean +!> Return the global area integral of a variable. This uses reproducing sums. function global_area_integral(var,G) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var + real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var !< The variable to integrate real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming real :: global_area_integral @@ -57,10 +59,11 @@ function global_area_integral(var,G) end function global_area_integral +!> Return the layerwise global thickness-weighted mean of a variable. This uses reproducing sums. function global_layer_mean(var, h, G, GV) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: var + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: var !< The variable to average real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) real, dimension(SZK_(GV)) :: global_layer_mean @@ -86,7 +89,7 @@ function global_layer_mean(var, h, G, GV) end function global_layer_mean -!> Find the global thickness-weighted mean of a variable. +!> Find the global thickness-weighted mean of a variable. This uses reproducing sums. function global_volume_mean(var, h, G, GV) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -114,7 +117,7 @@ function global_volume_mean(var, h, G, GV) end function global_volume_mean -!> Find the global mass-weighted integral of a variable +!> Find the global mass-weighted integral of a variable. This uses reproducing sums. function global_mass_integral(h, G, GV, var, on_PE_only) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -158,11 +161,14 @@ function global_mass_integral(h, G, GV, var, on_PE_only) end function global_mass_integral +!> Determine the global mean of a field along rows of constant i, returning it +!! in a 1-d array using the local indexing. This uses reproducing sums. subroutine global_i_mean(array, i_mean, G, mask) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array - real, dimension(SZJ_(G)), intent(out) :: i_mean - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: mask + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged + real, dimension(SZJ_(G)), intent(out) :: i_mean !< Global mean of array along its i-axis + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: mask !< An array used for weighting the i-mean ! This subroutine determines the global mean of a field along rows of ! constant i, returning it in a 1-d array using the local indexing. @@ -236,11 +242,14 @@ subroutine global_i_mean(array, i_mean, G, mask) end subroutine global_i_mean +!> Determine the global mean of a field along rows of constant j, returning it +!! in a 1-d array using the local indexing. This uses reproducing sums. subroutine global_j_mean(array, j_mean, G, mask) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array - real, dimension(SZI_(G)), intent(out) :: j_mean - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: mask + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged + real, dimension(SZI_(G)), intent(out) :: j_mean !< Global mean of array along its j-axis + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: mask !< An array used for weighting the j-mean ! This subroutine determines the global mean of a field along rows of ! constant j, returning it in a 1-d array using the local indexing. diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index f56834a8f6..643b150219 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -27,14 +27,14 @@ module MOM_string_functions contains +!> Return a string in which all uppercase letters have been replaced by +!! their lowercase counterparts. function lowercase(input_string) + character(len=*), intent(in) :: input_string !< The string to modify + character(len=len(input_string)) :: lowercase !< The modified output string ! This function returns a string in which all uppercase letters have been ! replaced by their lowercase counterparts. It is loosely based on the ! lowercase function in mpp_util.F90. - ! Arguments - character(len=*), intent(in) :: input_string - character(len=len(input_string)) :: lowercase - ! Local variables integer, parameter :: co=iachar('a')-iachar('A') ! case offset integer :: k @@ -42,16 +42,17 @@ function lowercase(input_string) do k=1, len_trim(input_string) if (lowercase(k:k) >= 'A' .and. lowercase(k:k) <= 'Z') & lowercase(k:k) = achar(ichar(lowercase(k:k))+co) - end do + enddo end function lowercase +!> Return a string in which all uppercase letters have been replaced by +!! their lowercase counterparts. function uppercase(input_string) - character(len=*), intent(in) :: input_string - character(len=len(input_string)) :: uppercase + character(len=*), intent(in) :: input_string !< The string to modify + character(len=len(input_string)) :: uppercase !< The modified output string ! This function returns a string in which all lowercase letters have been ! replaced by their uppercase counterparts. It is loosely based on the ! uppercase function in mpp_util.F90. - ! Arguments integer, parameter :: co=iachar('A')-iachar('a') ! case offset integer :: k @@ -59,28 +60,26 @@ function uppercase(input_string) do k=1, len_trim(input_string) if (uppercase(k:k) >= 'a' .and. uppercase(k:k) <= 'z') & uppercase(k:k) = achar(ichar(uppercase(k:k))+co) - end do + enddo end function uppercase +!> Returns a character string of a left-formatted integer +!! e.g. "123 " (assumes 19 digit maximum) function left_int(i) -! Returns a character string of a left-formatted integer -! e.g. "123 " (assumes 19 digit maximum) - ! Arguments - character(len=19) :: left_int - integer, intent(in) :: i - ! Local variables + integer, intent(in) :: i !< The integer to convert to a string + character(len=19) :: left_int !< The output string + character(len=19) :: tmp write(tmp(1:19),'(I19)') i write(left_int(1:19),'(A)') adjustl(tmp) end function left_int +!> Returns a character string of a comma-separated, compact formatted, +!! integers e.g. "1, 2, 3, 4" function left_ints(i) -! Returns a character string of a comma-separated, compact formatted, -! integers e.g. "1, 2, 3, 4" - ! Arguments - character(len=1320) :: left_ints - integer, intent(in) :: i(:) - ! Local variables + integer, intent(in) :: i(:) !< The array of integers to convert to a string + character(len=1320) :: left_ints !< The output string + character(len=1320) :: tmp integer :: j write(left_ints(1:1320),'(A)') trim(left_int(i(1))) @@ -92,10 +91,11 @@ function left_ints(i) endif end function left_ints +!> Returns a left-justified string with a real formatted like '(G)' function left_real(val) - real, intent(in) :: val - character(len=32) :: left_real -! Returns a left-justified string with a real formatted like '(G)' + real, intent(in) :: val !< The real variable to convert to a string + character(len=32) :: left_real !< The output string + integer :: l, ind if ((abs(val) < 1.0e4) .and. (abs(val) >= 1.0e-3)) then @@ -143,19 +143,18 @@ function left_real(val) left_real = adjustl(left_real) end function left_real +!> Returns a character string of a comma-separated, compact formatted, reals +!! e.g. "1., 2., 5*3., 5.E2" function left_reals(r,sep) -! Returns a character string of a comma-separated, compact formatted, reals -! e.g. "1., 2., 5*3., 5.E2" - ! Arguments - character(len=1320) :: left_reals - real, intent(in) :: r(:) + real, intent(in) :: r(:) !< The array of real variables to convert to a string character(len=*), optional, intent(in) :: sep !< The separator between !! successive values, by default it is ', '. + character(len=1320) :: left_reals !< The output string - ! Local variables integer :: j, n, b, ns logical :: doWrite character(len=10) :: separator + n=1 ; doWrite=.true. ; left_reals='' ; b=1 if (present(sep)) then separator=sep ; ns=len(sep) @@ -185,11 +184,10 @@ function left_reals(r,sep) enddo end function left_reals +!> Returns True if the string can be read/parsed to give the exact value of "val" function isFormattedFloatEqualTo(str, val) -! Returns True if the string can be read/parsed to give the exact -! value of "val" - character(len=*), intent(in) :: str - real, intent(in) :: val + character(len=*), intent(in) :: str !< The string to parse + real, intent(in) :: val !< The real value to compare with logical :: isFormattedFloatEqualTo ! Local variables real :: scannedVal @@ -204,8 +202,8 @@ end function isFormattedFloatEqualTo !! or "" if the string is not long enough. Both spaces and commas !! are interpreted as separators. character(len=120) function extractWord(string, n) - character(len=*), intent(in) :: string - integer, intent(in) :: n + character(len=*), intent(in) :: string !< The string to scan + integer, intent(in) :: n !< Number of word to extract extractWord = extract_word(string, ' ,', n) diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index 17d4a3153a..98e7c57e4f 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -49,8 +49,10 @@ module MOM_write_cputime contains +!> Evaluate the CPU time returned by SYSTEM_CLOCK at the start of a run subroutine write_cputime_start_clock(CS) - type(write_cputime_CS), pointer :: CS + type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous + !! call to MOM_write_cputime_init. ! Argument: CS - A pointer that is set to point to the control structure ! for this module integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK @@ -60,11 +62,13 @@ subroutine write_cputime_start_clock(CS) CS%prev_cputime = new_cputime end subroutine write_cputime_start_clock +!> Initialize the MOM_write_cputime module. subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - character(len=*), intent(in) :: directory - type(time_type), intent(in) :: Input_start_time - type(write_cputime_CS), pointer :: CS + character(len=*), intent(in) :: directory !< The directory where the CPU time file goes. + type(time_type), intent(in) :: Input_start_time !< The start model time of the simulation. + type(write_cputime_CS), pointer :: CS !< A pointer that may be set to point to the + !! control structure for this module. ! Arguments: param_file - A structure indicating the open file to parse for ! model parameter values. ! (in) directory - The directory where the energy file goes. @@ -106,11 +110,15 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) end subroutine MOM_write_cputime_init +!> This subroutine assesses how much CPU time the model has taken and determines how long the model +!! should be run before it saves a restart file and stops itself. subroutine write_cputime(day, n, nmax, CS) - type(time_type), intent(inout) :: day - integer, intent(in) :: n - integer, intent(inout) :: nmax - type(write_cputime_CS), pointer :: CS + type(time_type), intent(inout) :: day !< The current model time. + integer, intent(in) :: n !< The time step number of the current execution. + integer, intent(inout) :: nmax !< The number of iterations after which to stop so + !! that the simulation will not run out of CPU time. + type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous + !! call to MOM_write_cputime_init. ! This subroutine assesses how much CPU time the model has ! taken and determines how long the model should be run before it ! saves a restart file and stops itself. diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 94b628221c..6be4f7d0d3 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1089,7 +1089,7 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then sponge_area = sponge_area + G%areaT(i,j) endif - enddo; enddo + enddo ; enddo ! take into account changes in mass (or thickness) when imposing ice shelf mass if (CS%shelf_mass_is_dynamic .and. CS%override_shelf_movement .and. & @@ -1125,7 +1125,7 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) shelf_mass1 = shelf_mass1 + (CS%mass_shelf(i,j) * CS%area_shelf_h(i,j)) endif - enddo; enddo + enddo ; enddo call mpp_sum(shelf_mass0); call mpp_sum(shelf_mass1) delta_mass_shelf = (shelf_mass1 - shelf_mass0)/CS%time_step ! delta_mass_shelf = (shelf_mass1 - shelf_mass0)* & @@ -1152,7 +1152,7 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! W /m^2 fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! kg (salt)/(m^2 s) endif - enddo; enddo + enddo ; enddo if (CS%DEBUG) then if (is_root_pe()) write(*,*)'Mean melt flux (kg/(m^2 s)),dt',mean_melt_flux,CS%time_step @@ -1679,12 +1679,12 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl endif - ! else if (CS%shelf_mass_is_dynamic) then + ! elseif (CS%shelf_mass_is_dynamic) then ! call initialize_ice_shelf_boundary ( CS%u_face_mask_boundary, CS%v_face_mask_boundary, & ! CS%u_flux_boundary_values, CS%v_flux_boundary_values, & ! CS%u_boundary_values, CS%v_boundary_values, CS%h_boundary_values, & ! CS%hmask, G, param_file) - end if + endif if (CS%shelf_mass_is_dynamic .and. .not. CS%override_shelf_movement) then ! the only reason to initialize boundary conds is if the shelf is dynamic @@ -1694,7 +1694,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl !MJH CS%u_boundary_values, CS%v_boundary_values, CS%h_boundary_values, & !MJH CS%hmask, G, param_file) - end if + endif if (new_sim .and. (.not. (CS%override_shelf_movement .and. CS%mass_from_file))) then @@ -5856,14 +5856,14 @@ subroutine savearray2(fname,A,flag) WRITE(fin) 'SECOND DIMENSION TOO LARGE' CLOSE(fin) RETURN -END IF +ENDIF DO i=1,M WRITE(ln,'(E17.9)') A(i,1) DO j=2,N WRITE(sing,'(E17.9)') A(i,j) ln = TRIM(ln) // ' ' // TRIM(sing) - END DO + ENDDO if (i == 1) THEN @@ -5889,14 +5889,14 @@ subroutine savearray2(fname,A,flag) FMT1 = TRIM(FMT1) // ')' - END IF + ENDIF WRITE(UNIT=fin,IOSTAT=iock,FMT=TRIM(FMT1)) TRIM(ln) if (iock /= 0) THEN - PRINT*,iock - END IF -END DO + PRINT *,iock + ENDIF +ENDDO CLOSE(FIN) diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index ba84d55763..78d2a3fb8c 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -70,16 +70,27 @@ module MOM_grid_initialize public set_grid_metrics, initialize_masks, Adcroft_reciprocal type, public :: GPS ; private - real :: len_lon - real :: len_lat - real :: west_lon - real :: south_lat - real :: Rad_Earth - real :: Lat_enhance_factor - real :: Lat_eq_enhance - logical :: isotropic - logical :: equator_reference - integer :: niglobal, njglobal ! Duplicates of niglobal and njglobal from MOM_dom + real :: len_lon !< The longitudinal or x-direction length of the domain. + real :: len_lat !< The latitudinal or y-direction length of the domain. + real :: west_lon !< The western longitude of the domain or the equivalent + !! starting value for the x-axis. + real :: south_lat !< The southern latitude of the domain or the equivalent + !! starting value for the y-axis. + real :: Rad_Earth !< The radius of the Earth, in m. + real :: Lat_enhance_factor !< The amount by which the meridional resolution + !! is enhanced within LAT_EQ_ENHANCE of the equator. + real :: Lat_eq_enhance !< The latitude range to the north and south of the equator + !! over which the resolution is enhanced, in degrees. + logical :: isotropic !< If true, an isotropic grid on a sphere (also known as a Mercator grid) + !! is used. With an isotropic grid, the meridional extent of the domain + !! (LENLAT), the zonal extent (LENLON), and the number of grid points in each + !! direction are _not_ independent. In MOM the meridional extent is determined + !! to fit the zonal extent and the number of grid points, while grid is + !! perfectly isotropic. + logical :: equator_reference !< If true, the grid is defined to have the equator at the + !! nearest q- or h- grid point to (-LOWLAT*NJGLOBAL/LENLAT). + integer :: niglobal !< The number of i-points in the global grid computational domain + integer :: njglobal !< The number of j-points in the global grid computational domain end type GPS contains @@ -538,7 +549,7 @@ subroutine set_grid_metrics_cartesian(G, param_file) if (units_temp(1:1) == 'k') then ! Axes are measured in km. dx_everywhere = 1000.0 * G%len_lon / (REAL(niglobal)) dy_everywhere = 1000.0 * G%len_lat / (REAL(njglobal)) - else if (units_temp(1:1) == 'm') then ! Axes are measured in m. + elseif (units_temp(1:1) == 'm') then ! Axes are measured in m. dx_everywhere = G%len_lon / (REAL(niglobal)) dy_everywhere = G%len_lat / (REAL(njglobal)) else ! Axes are measured in degrees of latitude and longitude. @@ -679,7 +690,7 @@ subroutine set_grid_metrics_spherical(G, param_file) ! G%dxBu(I,J) = G%Rad_Earth * dLon*PI_180 * COS( G%geoLatBu(I,J)*PI_180 ) G%dyBu(I,J) = G%Rad_Earth * dLat*PI_180 G%areaBu(I,J) = G%dxBu(I,J) * G%dyBu(I,J) - enddo; enddo + enddo ; enddo do J=JsdB,JedB ; do i=isd,ied G%geoLonCv(i,J) = grid_LonT(i) @@ -690,7 +701,7 @@ subroutine set_grid_metrics_spherical(G, param_file) G%dxCv(i,J) = G%Rad_Earth * COS( G%geoLatCv(i,J)*PI_180 ) * dL_di ! G%dxCv(i,J) = G%Rad_Earth * (dLon*PI_180) * COS( G%geoLatCv(i,J)*PI_180 ) G%dyCv(i,J) = G%Rad_Earth * dLat*PI_180 - enddo; enddo + enddo ; enddo do j=jsd,jed ; do I=IsdB,IedB G%geoLonCu(I,j) = grid_lonB(I) @@ -701,7 +712,7 @@ subroutine set_grid_metrics_spherical(G, param_file) G%dxCu(I,j) = G%Rad_Earth * COS( G%geoLatCu(I,j)*PI_180 ) * dL_di ! G%dxCu(I,j) = G%Rad_Earth * dLon*PI_180 * COS( latitude ) G%dyCu(I,j) = G%Rad_Earth * dLat*PI_180 - enddo; enddo + enddo ; enddo do j=jsd,jed ; do i=isd,ied G%geoLonT(i,j) = grid_LonT(i) @@ -717,7 +728,7 @@ subroutine set_grid_metrics_spherical(G, param_file) ! dL_di = G%geoLatCv(i,max(jsd,J-1))*PI_180 ! In radians ! G%areaT(i,j) = Rad_Earth**2*dLon*dLat*ABS(SIN(latitude)-SIN(dL_di)) G%areaT(i,j) = G%dxT(i,j) * G%dyT(i,j) - enddo; enddo + enddo ; enddo call callTree_leave("set_grid_metrics_spherical()") end subroutine set_grid_metrics_spherical @@ -966,9 +977,11 @@ subroutine set_grid_metrics_mercator(G, param_file) end subroutine set_grid_metrics_mercator +!> This function returns the grid spacing in the logical x direction. function ds_di(x, y, GP) - real, intent(in) :: x, y - type(GPS), intent(in) :: GP + real, intent(in) :: x !< The longitude in question + real, intent(in) :: y !< The latitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: ds_di ! This function returns the grid spacing in the logical x direction. ! Arguments: x - The latitude in question. @@ -979,9 +992,11 @@ function ds_di(x, y, GP) ! dy_di(x,y,GP)*dy_di(x,y,GP)) end function ds_di +!> This function returns the grid spacing in the logical y direction. function ds_dj(x, y, GP) - real, intent(in) :: x, y - type(GPS), intent(in) :: GP + real, intent(in) :: x !< The longitude in question + real, intent(in) :: y !< The latitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: ds_dj ! This function returns the grid spacing in the logical y direction. ! Arguments: x - The latitude in question. @@ -993,13 +1008,18 @@ function ds_dj(x, y, GP) end function ds_dj +!> This function returns the contribution from the line integral along one of the four sides of a +!! cell face to the area of a cell, assuming that the sides follow a linear path in latitude and +!! longitude (i.e., on a Mercator grid). function dL(x1, x2, y1, y2) - real, intent(in) :: x1, x2, y1, y2 + real, intent(in) :: x1 !< Segment starting longitude, in degrees E. + real, intent(in) :: x2 !< Segment ending longitude, in degrees E. + real, intent(in) :: y1 !< Segment ending latitude, in degrees N. + real, intent(in) :: y2 !< Segment ending latitude, in degrees N. real :: dL -! This subroutine calculates the contribution from the line integral -! along one of the four sides of a cell face to the area of a cell, -! assuming that the sides follow a linear path in latitude and long- -! itude (i.e., on a Mercator grid). +! This subroutine calculates the contribution from the line integral along one +! of the four sides of a cell face to the area of a cell, assuming that the +! sides follow a linear path in latitude and longitude (i.e., on a Mercator grid). ! Argumnts: x1 - Segment starting longitude. ! (in) x2 - Segment ending longitude. ! (in) y1 - Segment ending latitude. @@ -1017,17 +1037,25 @@ function dL(x1, x2, y1, y2) end function dL +!> This subroutine finds and returns the value of y at which the monotonically increasing +!! function fn takes the value fnval, also returning in ittmax the number of iterations of +!! Newton's method that were used to polish the root. function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) - real :: find_root - real, external :: fn, dy_df - type(GPS), intent(in) :: GP - real, intent(in) :: fnval, y1, ymin, ymax - integer, intent(out) :: ittmax - real :: y, y_next + real :: find_root !< The value of y where fn(y) = fnval that will be returned + real, external :: fn !< The external function whose root is being sought + real, external :: dy_df !< The inverse of the derivative of that function + type(GPS), intent(in) :: GP !< A structure of grid parameters + real, intent(in) :: fnval !< The value of fn being sought + real, intent(in) :: y1 !< A first guess for y + real, intent(in) :: ymin !< The minimum permitted value of y + real, intent(in) :: ymax !< The maximum permitted value of y + integer, intent(out) :: ittmax !< The number of iterations used to polish the root + ! This subroutine finds and returns the value of y at which the ! monotonically increasing function fn takes the value fnval, also returning ! in ittmax the number of iterations of Newton's method that were ! used to polish the root. + real :: y, y_next real :: ybot, ytop, fnbot, fntop integer :: itt character(len=256) :: warnmesg @@ -1126,21 +1154,24 @@ function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) find_root = y end function find_root +!> This function calculates and returns the value of dx/di, where x is the +!! longitude in Radians, and i is the integral north-south grid index. function dx_di(x, GP) - real, intent(in) :: x - type(GPS), intent(in) :: GP + real, intent(in) :: x !< The longitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: dx_di ! This subroutine calculates and returns the value of dx/di, where -! x is the longitude in Radians, and i is the integral north-south -! grid index. +! x is the longitude in Radians, and i is the integral north-south grid index. dx_di = (GP%len_lon * 4.0*atan(1.0)) / (180.0 * GP%niglobal) end function dx_di +!> This function calculates and returns the integral of the inverse +!! of dx/di to the point x, in radians. function Int_di_dx(x, GP) - real, intent(in) :: x - type(GPS), intent(in) :: GP + real, intent(in) :: x !< The longitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: Int_di_dx ! This subroutine calculates and returns the integral of the inverse ! of dx/di to the point x, in radians. @@ -1149,9 +1180,11 @@ function Int_di_dx(x, GP) end function Int_di_dx +!> This subroutine calculates and returns the value of dy/dj, where y is the +!! latitude in Radians, and j is the integral north-south grid index. function dy_dj(y, GP) - real, intent(in) :: y - type(GPS), intent(in) :: GP + real, intent(in) :: y !< The latitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: dy_dj ! This subroutine calculates and returns the value of dy/dj, where ! y is the latitude in Radians, and j is the integral north-south @@ -1178,9 +1211,11 @@ function dy_dj(y, GP) end function dy_dj +!> This subroutine calculates and returns the integral of the inverse +!! of dy/dj to the point y, in radians. function Int_dj_dy(y, GP) - real, intent(in) :: y - type(GPS), intent(in) :: GP + real, intent(in) :: y !< The latitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: Int_dj_dy ! This subroutine calculates and returns the integral of the inverse ! of dy/dj to the point y, in radians. @@ -1207,7 +1242,7 @@ function Int_dj_dy(y, GP) if (y >= y_eq_enhance) then r = r + I_C0*0.5*(GP%lat_enhance_factor - 1.0)*y_eq_enhance - else if (y <= -y_eq_enhance) then + elseif (y <= -y_eq_enhance) then r = r - I_C0*0.5*(GP%lat_enhance_factor - 1.0)*y_eq_enhance else r = r + I_C0*0.5*(GP%lat_enhance_factor - 1.0) * & @@ -1223,8 +1258,6 @@ end function Int_dj_dy ! ------------------------------------------------------------------------------ -! ------------------------------------------------------------------------------ - !> extrapolate_metric extrapolates missing metric data into all the halo regions. subroutine extrapolate_metric(var, jh, missing) real, dimension(:,:), intent(inout) :: var !< The array in which to fill in halos diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index b150b8c4ad..e818c33acd 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -1187,9 +1187,9 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) call create_file(unit, trim(filepath), vars, nFlds_used, fields, & file_threading, dG=G) - do J=Jsq,Jeq; do I=Isq,Ieq; out_q(I,J) = G%geoLatBu(I,J); enddo; enddo + do J=Jsq,Jeq; do I=Isq,Ieq; out_q(I,J) = G%geoLatBu(I,J); enddo ; enddo call write_field(unit, fields(1), G%Domain%mpp_domain, out_q) - do J=Jsq,Jeq; do I=Isq,Ieq; out_q(I,J) = G%geoLonBu(I,J); enddo; enddo + do J=Jsq,Jeq; do I=Isq,Ieq; out_q(I,J) = G%geoLonBu(I,J); enddo ; enddo call write_field(unit, fields(2), G%Domain%mpp_domain, out_q) call write_field(unit, fields(3), G%Domain%mpp_domain, G%geoLatT) call write_field(unit, fields(4), G%Domain%mpp_domain, G%geoLonT) @@ -1210,7 +1210,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = G%dyCv(i,J) ; enddo ; enddo call write_field(unit, fields(10), G%Domain%mpp_domain, out_v) - do j=js,je ; do i=is,ie ; out_h(i,j) = G%dxT(i,j); enddo; enddo + do j=js,je ; do i=is,ie ; out_h(i,j) = G%dxT(i,j); enddo ; enddo call write_field(unit, fields(11), G%Domain%mpp_domain, out_h) do j=js,je ; do i=is,ie ; out_h(i,j) = G%dyT(i,j) ; enddo ; enddo call write_field(unit, fields(12), G%Domain%mpp_domain, out_h) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 49153586b7..491c806a6b 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1709,18 +1709,18 @@ subroutine initialize_temp_salt_linear(T, S, G, param_file, just_read_params) ! S(:,:,1) = S_top ! do k = 2,G%ke ! S(:,:,k) = S(:,:,k-1) + delta_S -! end do +! enddo do k = 1,G%ke S(:,:,k) = S_top - S_range*((real(k)-0.5)/real(G%ke)) T(:,:,k) = T_top - T_range*((real(k)-0.5)/real(G%ke)) - end do + enddo ! ! Prescribe temperature ! delta_T = T_range / ( G%ke - 1.0 ) ! T(:,:,1) = T_top ! do k = 2,G%ke ! T(:,:,k) = T(:,:,k-1) + delta_T -! end do +! enddo ! delta = 1 ! T(:,:,G%ke/2 - (delta-1):G%ke/2 + delta) = 1.0 @@ -1848,7 +1848,7 @@ subroutine initialize_sponges_file(G, GV, use_temperature, tv, param_file, CSp, ! apply the sponges, along with the interface heights. ! call initialize_sponge(Idamp, eta, G, param_file, CSp) deallocate(eta) - else if (.not. new_sponges) then ! ALE mode + elseif (.not. new_sponges) then ! ALE mode call field_size(filename,eta_var,siz,no_domain=.true.) if (siz(1) /= G%ieg-G%isg+1 .or. siz(2) /= G%jeg-G%jsg+1) & @@ -1872,7 +1872,7 @@ subroutine initialize_sponges_file(G, GV, use_temperature, tv, param_file, CSp, enddo ; enddo ; enddo do k=1,nz; do j=js,je ; do i=is,ie h(i,j,k) = eta(i,j,k)-eta(i,j,k+1) - enddo ; enddo; enddo + enddo ; enddo ; enddo call initialize_ALE_sponge(Idamp, G, param_file, ALE_CSp, h, nz_data) deallocate(eta) deallocate(h) @@ -1910,7 +1910,7 @@ subroutine initialize_sponges_file(G, GV, use_temperature, tv, param_file, CSp, call set_up_sponge_field(tmp, tv%T, G, nz, CSp) call MOM_read_data(filename, salin_var, tmp(:,:,:), G%Domain) call set_up_sponge_field(tmp, tv%S, G, nz, CSp) - else if (use_temperature) then + elseif (use_temperature) then call set_up_ALE_sponge_field(filename, potemp_var, Time, G, tv%T, ALE_CSp) call set_up_ALE_sponge_field(filename, salin_var, Time, G, tv%S, ALE_CSp) endif diff --git a/src/initialization/midas_vertmap.F90 b/src/initialization/midas_vertmap.F90 index 373062ffc3..8d022d97cc 100644 --- a/src/initialization/midas_vertmap.F90 +++ b/src/initialization/midas_vertmap.F90 @@ -408,7 +408,7 @@ function bisect_fast(a, x, lo, hi) result(bi_r) if (PRESENT(lo)) then where (lo>0) lo_=lo -end if +endif if (PRESENT(hi)) then where (hi>0) hi_=hi endif @@ -950,7 +950,7 @@ subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) zi(:,:)=mp(1:ni,1:nj) mp = fill_boundaries(zi,cyclic_x,tripolar_n) -end do +enddo return diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 2672308fd7..de5a97363b 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -308,15 +308,15 @@ subroutine init_oda(Time, G, GV, CS) do i=1, CS%ni; do j=1, CS%nj if ( global2D(i,j) > 1 ) then T_grid%mask(i,j,k) = 1.0 - end if - end do; end do + endif + enddo ; enddo if (k == 1) then T_grid%z(:,:,k) = global2D/2 else T_grid%z(:,:,k) = T_grid%z(:,:,k-1) + (global2D + global2D_old)/2 - end if + endif global2D_old = global2D - end do + enddo call ocean_da_core_init(CS%mpp_domain, T_grid, CS%Profiles, Time) @@ -363,7 +363,7 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) CS%nk, CS%h(i,j,:), T(i,j,:)) call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%S(i,j,:), & CS%nk, CS%h(i,j,:), S(i,j,:)) - enddo; enddo + enddo ; enddo do m=1,CS%ensemble_size call mpp_redistribute(CS%domains(m)%mpp_domain, T,& @@ -449,7 +449,7 @@ subroutine get_posterior_tracer(Time, CS, G, GV, h, tv, increment) used=send_data(CS%Ocean_posterior%id_s(m), CS%Ocean_posterior%S(isc:iec,jsc:jec,:,m), CS%Time) endif endif - end do + enddo tv => CS%tv h => CS%h @@ -479,7 +479,7 @@ subroutine oda(Time, CS) !! switch back to ensemble member pelist call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) - end if + endif return end subroutine oda diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index c4e771375c..11798d3bdb 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -433,7 +433,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, else do j=js-2,je+2 ; do I=Isq-1,Ieq+1 h_u(I,j) = 0.5 * (h(i,j,k) + h(i+1,j,k)) - enddo; enddo + enddo ; enddo do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 h_v(i,J) = 0.5 * (h(i,j,k) + h(i,j+1,k)) enddo ; enddo diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 076dab7b56..3be1ae6192 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -284,7 +284,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do j=jsd,jed ; do i=isd,ied ; test(i,j,1) = 1.0 ; test(i,j,2) = 0.0 ; enddo ; enddo do m=1,CS%nMode ; do fr=1,CS%nFreq call create_group_pass(pass_En, CS%En(:,:,:,fr,m), G%domain) - enddo; enddo + enddo ; enddo call create_group_pass(pass_test, test(:,:,1), test(:,:,2), G%domain, stagger=AGRID) call start_group_pass(pass_test, G%domain) @@ -920,7 +920,7 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) call MOM_error(WARNING, "refract: CFL exceeds 1.", .true.) if (CFL_ang(i,j,A) > 0.0) then ; CFL_ang(i,j,A) = 1.0 ; else ; CFL_ang(i,j,A) = -1.0 ; endif endif - enddo; enddo + enddo ; enddo ! Advect in angular space if (.not.use_PPMang) then @@ -931,7 +931,7 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) else Flux_E(i,A) = CFL_ang(i,j,A) * En2d(i,A+1) endif - enddo; enddo + enddo ; enddo else ! Use PPM do i=is,ie @@ -1109,7 +1109,7 @@ subroutine propagate(En, cn, freq, dt, G, CS, NAngle) ! Apply the propagation WITH CORNER ADVECTION/FINITE VOLUME APPROACH. LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie call propagate_corner_spread(En(:,:,a), a, NAngle, speed, dt, G, CS, LB) - end do ! a-loop + enddo ! a-loop else ! IMPLEMENT PPM ADVECTION IN HORIZONTAL----------------------- ! These could be in the control structure, as they do not vary. @@ -1436,7 +1436,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS enddo ! m-loop ! update energy in cell En(i,j) = sum(E_new)/Nsubrays - enddo; enddo + enddo ; enddo end subroutine propagate_corner_spread ! #@# This subroutine needs a doxygen description @@ -2069,7 +2069,7 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) slp(i,j) = sign(1.,slp(i,j)) * min(abs(slp(i,j)), 2. * min(dMx, dMn)) ! * (G%mask2dT(i-1,j) * G%mask2dT(i,j) * G%mask2dT(i+1,j)) endif - enddo; enddo + enddo ; enddo do j=jsl,jel ; do i=isl,iel ! Neighboring values should take into account any boundaries. The 3 @@ -2081,7 +2081,7 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) ! Left/right values following Eq. B2 in Lin 1994, MWR (132) h_l(i,j) = 0.5*( h_im1 + h_in(i,j) ) + oneSixth*( slp(i-1,j) - slp(i,j) ) h_r(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i+1,j) ) - enddo; enddo + enddo ; enddo endif call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel) @@ -2502,7 +2502,7 @@ subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) ! will be multiplied by N and En to get into [W m-2] CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor*GV%Rho0*& kappa_itides * h2(i,j) - enddo; enddo + enddo ; enddo ! Read in prescribed coast/ridge/shelf angles from file call get_param(param_file, mdl, "REFL_ANGLE_FILE", refl_angle_file, & @@ -2556,7 +2556,7 @@ subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) do i=isd,ied; do j=jsd,jed if (ridge_temp(i,j) == 1) then; CS%refl_dbl(i,j) = .true. else ; CS%refl_dbl(i,j) = .false. ; endif - enddo; enddo + enddo ; enddo ! Read in prescribed land mask from file (if overwriting -BDM). ! This should be done in MOM_initialize_topography subroutine diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 308b7ca9b6..93aeb6f750 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -198,7 +198,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ allocate(CS%Ref_h%p(CS%nz_data,CS%num_col)) do col=1,CS%num_col ; do K=1,CS%nz_data CS%Ref_h%p(K,col) = data_h(CS%col_i(col),CS%col_j(col),K) - enddo; enddo + enddo ; enddo endif total_sponge_cols = CS%num_col @@ -224,7 +224,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & CS%num_col_u = CS%num_col_u + 1 - enddo; enddo + enddo ; enddo if (CS%num_col_u > 0) then @@ -247,7 +247,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ allocate(CS%Ref_hu%p(CS%nz_data,CS%num_col_u)) do col=1,CS%num_col_u ; do K=1,CS%nz_data CS%Ref_hu%p(K,col) = data_hu(CS%col_i_u(col),CS%col_j_u(col),K) - enddo; enddo + enddo ; enddo endif total_sponge_cols_u = CS%num_col_u call sum_across_PEs(total_sponge_cols_u) @@ -261,7 +261,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & CS%num_col_v = CS%num_col_v + 1 - enddo; enddo + enddo ; enddo if (CS%num_col_v > 0) then @@ -400,7 +400,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & CS%num_col_u = CS%num_col_u + 1 - enddo; enddo + enddo ; enddo if (CS%num_col_u > 0) then @@ -432,7 +432,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & CS%num_col_v = CS%num_col_v + 1 - enddo; enddo + enddo ; enddo if (CS%num_col_v > 0) then @@ -863,7 +863,7 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) ! u points do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB; do k=1,nz hu(I,j,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) - enddo; enddo; enddo + enddo ; enddo ; enddo if (CS%new_sponges) then if (.not. present(Time)) & @@ -935,7 +935,7 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) ! v points do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec; do k=1,nz hv(i,J,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) - enddo; enddo; enddo + enddo ; enddo ; enddo do c=1,CS%num_col_v i = CS%col_i_v(c) ; j = CS%col_j_v(c) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index c0289bbd79..2861218128 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -401,7 +401,7 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) 'Constant value to enhance VT2 in KPP.', & default=1.0) endif - end if + endif call closeParameterBlock(paramFile) call get_param(paramFile, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 201588a2c2..7eafb011bd 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -1343,7 +1343,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & h_prev = h_ent ; h_ent = h_prev+dh_Newt if (h_ent > h_max) then h_ent = 0.5*(h_prev+h_max) - else if (h_ent < h_min) then + elseif (h_ent < h_min) then h_ent = 0.5*(h_prev+h_min) endif diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index afdebe4ae5..2678b18e1a 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -1091,7 +1091,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & ColHt_chg = ColHt_core * y1 if (ColHt_chg < 0.0) PE_chg = PE_chg - pres * ColHt_chg if (present(ColHt_cor)) ColHt_cor = -pres * min(ColHt_chg, 0.0) - else if (present(ColHt_cor)) then + elseif (present(ColHt_cor)) then y1 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) ColHt_cor = -pres * min(ColHt_core * y1, 0.0) endif diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 89a11217fa..a58773d066 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -1710,7 +1710,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & ColHt_chg = ColHt_core * y1 if (ColHt_chg < 0.0) PE_chg = PE_chg - pres * ColHt_chg if (present(ColHt_cor)) ColHt_cor = -pres * min(ColHt_chg, 0.0) - else if (present(ColHt_cor)) then + elseif (present(ColHt_cor)) then y1 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) ColHt_cor = -pres * min(ColHt_core * y1, 0.0) endif diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index c9f10826db..5f3f982dd1 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -736,7 +736,7 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & F(i,k) = MIN(F(i,k), ds_dsp1(i,k)*( ((F(i,k-1) + & dsp1_ds(i,k-1)*F(i,k-1)) - F(i,k-2)) + (h(i,j,k-1) - Angstrom))) F(i,k) = MAX(F(i,k),MIN(minF(i,k),0.0)) - else if (k == kb(i)+1) then + elseif (k == kb(i)+1) then F(i,k) = MIN(F(i,k), ds_dsp1(i,k)*( ((F(i,k-1) + eakb(i)) - & eb_kmb(i)) + (h(i,j,k-1) - Angstrom))) F(i,k) = MAX(F(i,k),MIN(minF(i,k),0.0)) @@ -791,7 +791,7 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & ea(i,j,k) = ea(i,j,k) - dsp1_ds(i,k)*F_cor eb(i,j,k) = eb(i,j,k) + F_cor - else if ((k==kb(i)) .and. (F(i,k) > 0.0)) then + elseif ((k==kb(i)) .and. (F(i,k) > 0.0)) then ! Rho_cor is the density anomaly that needs to be corrected, ! taking into account that the true potential density of the ! deepest buffer layer is not exactly what is returned as dS_kb. @@ -817,7 +817,7 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & ea(i,j,k) = ea(i,j,k) + ea_cor eb(i,j,k) = eb(i,j,k) - (dS_kb(i) * I_dSkbp1(i)) * ea_cor - else if (k < kb(i)) then + elseif (k < kb(i)) then ! Repetative, unless ea(kb) has been corrected. ea(i,j,k) = ea(i,j,k+1) endif @@ -1007,7 +1007,7 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, ! elsewhere, so F should always be nonnegative. ea(i,j,k) = dsp1_ds(i,k)*F(i,k) eb(i,j,k) = F(i,k) - else if (k == kb(i)) then + elseif (k == kb(i)) then ea(i,j,k) = eakb(i) eb(i,j,k) = F(i,k) elseif (k == kb(i)-1) then diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index e65af9183c..3c9188b6bb 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -372,7 +372,7 @@ subroutine int_tide_input_init(Time, G, GV, param_file, diag, CS, itide) ! Compute the fixed part of internal tidal forcing; units are [J m-2] here. CS%TKE_itidal_coef(i,j) = 0.5*kappa_h2_factor*GV%Rho0*& kappa_itides * itide%h2(i,j) * itide%tideamp(i,j)**2 - enddo; enddo + enddo ; enddo CS%id_TKE_itidal = register_diag_field('ocean_model','TKE_itidal_itide',diag%axesT1,Time, & diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 2952d9ac9b..ef6c160f9f 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -295,7 +295,7 @@ subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) chl_in(i,j,k), i, j, k, G%geoLonT(i,j), G%geoLatT(i,j) call MOM_error(FATAL,"MOM_opacity opacity_from_chl: "//trim(mesg)) endif - enddo; enddo; enddo + enddo ; enddo ; enddo else ! Only the 2-d surface chlorophyll can be read in from a file. The ! same value is assumed for all layers. diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index cc772bdb53..9906083597 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -391,7 +391,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & visc%Kd_extra_T(i,j,k) = 0.0 visc%Kd_extra_S(i,j,k) = 0.0 endif - enddo; enddo + enddo ; enddo if (associated(dd%KT_extra)) then ; do K=1,nz+1 ; do i=is,ie dd%KT_extra(i,j,K) = KT_extra(i,K) enddo ; enddo ; endif diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index e50d5db614..ec0b5a80b3 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -643,7 +643,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) if (oldfn >= ustarsq) then cycle - else if ((oldfn + Dfn) <= ustarsq) then + elseif ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) else Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn)/Dfn) @@ -659,7 +659,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) if (oldfn >= ustarsq) then cycle - else if ((oldfn + Dfn) <= ustarsq) then + elseif ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) else Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn)/Dfn) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 2fc99c48fc..1bb8eb48dd 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -273,14 +273,14 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, " "//trim(int_tide_profile_str)//" unavailable in CVMix. Available "//& "profiles in CVMix are "//trim(SIMMONS_PROFILE_STRING)//" and "//& trim(SCHMITTNER_PROFILE_STRING)//".") - else if (.not.CS%use_CVMix_tidal .and. (CS%int_tide_profile == SIMMONS_04.or. & + elseif (.not.CS%use_CVMix_tidal .and. (CS%int_tide_profile == SIMMONS_04.or. & CS%int_tide_profile == SCHMITTNER)) then call MOM_error(FATAL, "tidal_mixing_init: Tidal mixing profiles "// & trim(SIMMONS_PROFILE_STRING)//" and "//trim(SCHMITTNER_PROFILE_STRING)//& " are available only when USE_CVMix_TIDAL is True.") endif - else if (CS%use_CVMix_tidal) then + elseif (CS%use_CVMix_tidal) then call MOM_error(FATAL, "tidal_mixing_init: Cannot set INT_TIDE_DISSIPATION to False "// & "when USE_CVMix_TIDAL is set to True.") endif @@ -294,7 +294,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, if (CS%use_CVMix_tidal) then call MOM_error(FATAL, "tidal_mixing_init: Lee wave driven dissipation scheme cannot "// & "be used when CVMix tidal mixing scheme is active.") - end if + endif call get_param(param_file, mdl, "LEE_WAVE_PROFILE", tmpstr, & "LEE_WAVE_PROFILE selects the vertical profile of energy \n"//& "dissipation with LEE_WAVE_DISSIPATION. Valid values are:\n"//& @@ -325,7 +325,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, if (CS%use_CVMix_tidal) then call MOM_error(FATAL, "tidal_mixing_init: Polzin scheme cannot "// & "be used when CVMix tidal mixing scheme is active.") - end if + endif call get_param(param_file, mdl, "NU_POLZIN", CS%Nu_Polzin, & "When the Polzin decay profile is used, this is a \n"//& "non-dimensional constant in the expression for the \n"//& @@ -407,7 +407,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, if (CS%use_CVMix_tidal) then call MOM_error(FATAL, "tidal_mixing_init: Tidal amplitude files are "// & "not compatible with CVMix tidal mixing. ") - end if + endif call get_param(param_file, mdl, "TIDEAMP_FILE", tideamp_file, & "The path to the file containing the spatially varying \n"//& "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") @@ -438,7 +438,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, ! Compute the fixed part of internal tidal forcing; units are [kg s-2] here. CS%TKE_itidal(i,j) = 0.5*CS%kappa_h2_factor*GV%Rho0*& CS%kappa_itides*CS%h2(i,j)*utide*utide - enddo; enddo + enddo ; enddo endif diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 4226e4fa8c..48a6380ead 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1373,7 +1373,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) do k=1,nz ; do I=Isq,Ieq ; if (abs(u(I,j,k)) > maxvel) then u(I,j,k) = SIGN(truncvel,u(I,j,k)) if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - endif ; enddo ; enddo + endif ; enddo ; enddo endif ; endif enddo ! j-loop else ! Do not report accelerations leading to large velocities. @@ -1406,9 +1406,8 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) ! Here the diagnostic reporting subroutines are called if ! unphysically large values were found. call write_u_accel(I, j, u_old, h, ADp, CDp, dt, G, GV, CS%PointAccel_CSp, & - vel_report(I,j), -vel_report(I,j), forces%taux(I,j)*dt_Rho0, & - a=CS%a_u(:,j,:), hv=CS%h_u(:,j,:)) - endif ; enddo; enddo + vel_report(I,j), forces%taux(I,j)*dt_Rho0, a=CS%a_u, hv=CS%h_u) + endif ; enddo ; enddo endif if (len_trim(CS%v_trunc_file) > 0) then @@ -1459,7 +1458,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) do k=1,nz ; do i=is,ie ; if (abs(v(i,J,k)) > maxvel) then v(i,J,k) = SIGN(truncvel,v(i,J,k)) if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - endif ; enddo ; enddo + endif ; enddo ; enddo endif ; endif enddo ! J-loop else ! Do not report accelerations leading to large velocities. @@ -1492,9 +1491,8 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) ! Here the diagnostic reporting subroutines are called if ! unphysically large values were found. call write_v_accel(i, J, v_old, h, ADp, CDp, dt, G, GV, CS%PointAccel_CSp, & - vel_report(i,J), -vel_report(i,J), forces%tauy(i,J)*dt_Rho0, & - a=CS%a_v(:,J,:),hv=CS%h_v(:,J,:)) - endif ; enddo; enddo + vel_report(i,J), forces%tauy(i,J)*dt_Rho0, a=CS%a_v, hv=CS%h_v) + endif ; enddo ; enddo endif end subroutine vertvisc_limit_vel diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 38f3f4ee57..9c4536a013 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -214,7 +214,7 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, h, diag, OBC, CS, & ! This adds the stripes of tracer to every layer. CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + tr_y enddo - enddo; enddo; enddo + enddo ; enddo ; enddo if (NTR > 7) then do j=js,je ; do i=is,ie @@ -285,25 +285,29 @@ end subroutine initialize_DOME_tracer !! h_new[k] = h_old[k] + ea[k] - eb[k-1] + eb[k] - ea[k+1] subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old !< Layer thickness before entrainment, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_new !< Layer thickness after entrainment, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: ea !< an array to which the amount of - !! fluid entrained from the layer above during this - !! call will be added, in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: eb !< an array to which the amount of - !! fluid entrained from the layer below during this - !! call will be added, in m or kg m-2. - type(forcing), intent(in) :: fluxes !< A structure containing pointers to - !! any possible forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to DOME_register_tracer. - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to DOME_register_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! Local variables real :: b1(SZI_(G)) ! b1 and c1 are variables used by the @@ -366,7 +370,8 @@ end subroutine DOME_tracer_surface_state !> Clean up memory allocations, if any. subroutine DOME_tracer_end(CS) - type(DOME_tracer_CS), pointer :: CS + type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to DOME_register_tracer. integer :: m if (associated(CS)) then diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index f3fa46210f..f867c26764 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -165,7 +165,8 @@ subroutine initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS, & !! been read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in m or kg m-2. - type(diag_ctrl), target, intent(in) :: diag + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary conditions !! are used. This is not being used for now. @@ -263,14 +264,29 @@ end subroutine initialize_ISOMIP_tracer ! This is a simple example of a set of advected passive tracers. subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old, h_new, ea, eb - type(forcing), intent(in) :: fluxes - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(ISOMIP_tracer_CS), pointer :: CS - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to ISOMIP_register_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! Arguments: h_old - Layer thickness before entrainment, in m or kg m-2. ! (in) h_new - Layer thickness after entrainment, in m or kg m-2. @@ -371,7 +387,8 @@ subroutine ISOMIP_tracer_surface_state(state, h, G, CS) end subroutine ISOMIP_tracer_surface_state subroutine ISOMIP_tracer_end(CS) - type(ISOMIP_tracer_CS), pointer :: CS + type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to ISOMIP_register_tracer. integer :: m if (associated(CS)) then diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index fcb55382c4..11531dcb62 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -351,7 +351,7 @@ subroutine flux_init_OCMIP2_CFC(CS, verbosity) end subroutine flux_init_OCMIP2_CFC -!>This subroutine initializes the NTR tracer fields in tr(:,:,:,:) +!> This subroutine initializes the NTR tracer fields in tr(:,:,:,:) !! and it sets up the tracer output. subroutine initialize_OCMIP2_CFC(restart, day, G, GV, h, diag, OBC, CS, & sponge_CSp, diag_to_Z_CSp) @@ -420,10 +420,12 @@ end subroutine initialize_OCMIP2_CFC subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: tr - character(len=*), intent(in) :: name - real, intent(in) :: land_val, IC_val - type(OCMIP2_CFC_CS), pointer :: CS + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: tr !< The tracer concentration array + character(len=*), intent(in) :: name !< The tracer name + real, intent(in) :: land_val !< A value the tracer takes over land + real, intent(in) :: IC_val !< The initial condition value for the tracer + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_OCMIP2_CFC. ! This subroutine initializes a tracer array. @@ -464,31 +466,29 @@ end subroutine init_tracer_CFC ! flux as a source. subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h_old !< Layer thickness before entrainment, - !! in m or kg m-2. + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h_new !< Layer thickness after entrainment, - !! in m or kg m-2. + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: ea !< an array to which the amount of fluid - !! entrained from the layer above during - !! this call will be added, in m or kg m-2. + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: eb !< an array to which the amount of fluid - !! entrained from the layer below during - !! this call will be added, in m or kg m-2. - type(forcing), intent(in) :: fluxes !< A structure containing pointers to any - !! possible forcing fields. Unused fields - !! have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this - !! call, in s - type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a - !! previous call to register_OCMIP2_CFC. - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_OCMIP2_CFC. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! CFCs are relatively simple, as they are passive tracers. with only a surface @@ -701,7 +701,8 @@ subroutine OCMIP2_CFC_surface_state(state, h, G, CS) end subroutine OCMIP2_CFC_surface_state subroutine OCMIP2_CFC_end(CS) - type(OCMIP2_CFC_CS), pointer :: CS + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_OCMIP2_CFC. ! This subroutine deallocates the memory owned by this module. ! Argument: CS - The control structure returned by a previous call to ! register_OCMIP2_CFC. diff --git a/src/tracer/MOM_OCMIP2_CO2calc.F90 b/src/tracer/MOM_OCMIP2_CO2calc.F90 index 8c2809418d..aa87c19e73 100644 --- a/src/tracer/MOM_OCMIP2_CO2calc.F90 +++ b/src/tracer/MOM_OCMIP2_CO2calc.F90 @@ -421,7 +421,7 @@ function drtsafe(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & swap=fl fl=fh fh=swap -end if +endif drtsafe=0.5*(x1+x2) dxold=abs(x2-x1) dx=dxold @@ -446,7 +446,7 @@ function drtsafe(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & ! write (6,*) 'Exiting drtsafe at B on iteration ', j, ', ph = ', -log10(drtsafe) return endif - end if + endif if (abs(dx) < xacc) then ! write (6,*) 'Exiting drtsafe at C on iteration ', j, ', ph = ', -log10(drtsafe) return @@ -459,7 +459,7 @@ function drtsafe(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & else xh=drtsafe fh=f - end if + endif enddo !} j return diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 65000627ef..7b7fe8e5a2 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -298,7 +298,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia !Jasmin does not want to apply the maximum for now !if (tr_ptr(i,j,k) > g_tracer%src_var_valid_max) tr_ptr(i,j,k) = g_tracer%src_var_valid_max endif - enddo; enddo ; enddo + enddo ; enddo ; enddo !jgj: Reset CASED to 0 below K=1 if (trim(g_tracer_name) == 'cased') then @@ -306,7 +306,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia if (tr_ptr(i,j,k) /= CS%tracer_land_val) then tr_ptr(i,j,k) = 0.0 endif - enddo; enddo ; enddo + enddo ; enddo ; enddo endif elseif(.not. g_tracer%requires_restart) then !Do nothing for this tracer, it is initialized by the tracer package @@ -521,12 +521,12 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, rho_dzt(:,:,:) = GV%H_to_kg_m2 * GV%Angstrom do k = 1, nk ; do j = jsc, jec ; do i = isc, iec !{ rho_dzt(i,j,k) = GV%H_to_kg_m2 * h_old(i,j,k) - enddo; enddo ; enddo !} + enddo ; enddo ; enddo !} dzt(:,:,:) = 1.0 do k = 1, nk ; do j = jsc, jec ; do i = isc, iec !{ dzt(i,j,k) = GV%H_to_m * h_old(i,j,k) - enddo; enddo ; enddo !} + enddo ; enddo ; enddo !} do j=jsc,jec ; do i=isc,iec surface_field(i,j) = tv%S(i,j,1) @@ -662,12 +662,18 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg xgmax, ygmax, zgmax , G, CS, names, units) use mpp_utilities_mod, only: mpp_array_global_min_max integer, intent(in) :: ind_start - logical, dimension(:), intent(out) :: got_minmax + logical, dimension(:), intent(out) :: got_minmax !< Indicates whether the global min and + !! max are found for each tracer real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer, in kg !! times concentration units. real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer, in kg !! times concentration units. - real, dimension(:), intent(out) :: xgmin, ygmin, zgmin, xgmax, ygmax, zgmax + real, dimension(:), intent(out) :: xgmin !< The x-position of the global minimum + real, dimension(:), intent(out) :: ygmin !< The y-position of the global minimum + real, dimension(:), intent(out) :: zgmin !< The z-position of the global minimum + real, dimension(:), intent(out) :: xgmax !< The x-position of the global maximum + real, dimension(:), intent(out) :: ygmax !< The y-position of the global maximum + real, dimension(:), intent(out) :: zgmax !< The z-position of the global maximum type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index b3232c1bca..65679fe2a6 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -394,14 +394,14 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) hEff_sum(:,:) = 0. do k = 1,CS%nsurf-1 ; do j=G%jsc,G%jec ; do i=G%isc-1,G%iec hEff_sum(i,j) = hEff_sum(i,j) + CS%uhEff(i,j,k) - enddo ; enddo; enddo + enddo ; enddo ; enddo call post_data(CS%id_uhEff_2d, hEff_sum, CS%diag) endif if (CS%id_vhEff_2d>0) then hEff_sum(:,:) = 0. do k = 1,CS%nsurf-1 ; do j=G%jsc-1,G%jec ; do i=G%isc,G%iec hEff_sum(i,j) = hEff_sum(i,j) + CS%vhEff(i,j,k) - enddo ; enddo; enddo + enddo ; enddo ; enddo call post_data(CS%id_vhEff_2d, hEff_sum, CS%diag) endif @@ -1319,7 +1319,8 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h0. - type(remapping_CS), optional, intent(in) :: remap_CS + type(remapping_CS), optional, intent(in) :: remap_CS !< Remapping control structure used + !! to create sublayers real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value calculations !! in the same units as h0. @@ -1503,7 +1504,7 @@ end subroutine ppm_left_right_edge_values !> Returns true if unit tests of neutral_diffusion functions fail. Otherwise returns false. logical function neutral_diffusion_unit_tests(verbose) - logical, intent(in) :: verbose + logical, intent(in) :: verbose !< If true, write results to stdout neutral_diffusion_unit_tests = .false. .or. & ndiff_unit_tests_continuous(verbose) .or. ndiff_unit_tests_discontinuous(verbose) @@ -1513,7 +1514,7 @@ end function neutral_diffusion_unit_tests !> Returns true if unit tests of neutral_diffusion functions fail. Otherwise returns false. logical function ndiff_unit_tests_continuous(verbose) - logical, intent(in) :: verbose !< It true, write results to stdout + logical, intent(in) :: verbose !< If true, write results to stdout ! Local variables integer, parameter :: nk = 4 real, dimension(nk+1) :: TiL, TiR1, TiR2, TiR4, Tio ! Test interface temperatures @@ -1790,9 +1791,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) integer, dimension(ns) :: KoL, KoR real, dimension(ns) :: PoL, PoR real, dimension(ns-1) :: hEff, Flx - type(neutral_diffusion_CS) :: CS - type(EOS_type), pointer :: EOS ! Structure for linear equation of state - type(remapping_CS), pointer :: remap_CS ! Remapping control structure (PLM) + type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure + type(EOS_type), pointer :: EOS !< Structure for linear equation of state + type(remapping_CS), pointer :: remap_CS !< Remapping control structure (PLM) real, dimension(nk,2) :: poly_T_l, poly_T_r, poly_S, poly_slope ! Linear reconstruction for T real, dimension(nk,2) :: dRdT, dRdS logical, dimension(nk) :: stable_l, stable_r @@ -2222,9 +2223,9 @@ end function compare_nsp_row !> Compares output position from refine_nondim_position with an expected value logical function test_rnp(expected_pos, test_pos, title) - real, intent(in) :: expected_pos - real, intent(in) :: test_pos - character(len=*), intent(in) :: title + real, intent(in) :: expected_pos !< The expected position + real, intent(in) :: test_pos !< The position returned by the code + character(len=*), intent(in) :: title !< A label for this test ! Local variables integer :: stdunit = 6 ! Output to standard error test_rnp = expected_pos /= test_pos @@ -2236,7 +2237,7 @@ logical function test_rnp(expected_pos, test_pos, title) end function test_rnp !> Deallocates neutral_diffusion control structure subroutine neutral_diffusion_end(CS) - type(neutral_diffusion_CS), pointer :: CS + type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure if (associated(CS)) deallocate(CS) diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 1ecfd7a25a..2cc91606ff 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -174,7 +174,7 @@ subroutine drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppol real, dimension(CS%nterm), intent(in) :: ppoly_T !< Coefficients of T reconstruction real, dimension(CS%nterm), intent(in) :: ppoly_S !< Coefficients of S reconstruciton real, intent(in) :: x0 !< Nondimensional position to evaluate - real, intent(out) :: delta_rho + real, intent(out) :: delta_rho !< The density difference from a reference value real, optional, intent(out) :: P_out !< Pressure at point x0 real, optional, intent(out) :: T_out !< Temperature at point x0 real, optional, intent(out) :: S_out !< Salinity at point x0 @@ -507,7 +507,7 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to fa = fb fb = fc fc = fa - end if + endif tol = 2. * machep * abs ( sb ) + CS%xtol m = 0.5 * ( c - sb ) if ( abs ( m ) <= tol .or. fb == 0. ) then @@ -526,12 +526,12 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to r = fb / fc p = s0 * ( 2. * m * q * ( q - r ) - ( sb - sa ) * ( r - 1. ) ) q = ( q - 1. ) * ( r - 1. ) * ( s0 - 1. ) - end if + endif if ( 0. < p ) then q = - q else p = - p - end if + endif s0 = e e = d if ( 2. * p < 3. * m * q - abs ( tol * q ) .and. & @@ -540,17 +540,17 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to else e = m d = e - end if - end if + endif + endif sa = sb fa = fb if ( tol < abs ( d ) ) then sb = sb + d - else if ( 0. < m ) then + elseif ( 0. < m ) then sb = sb + tol else sb = sb - tol - end if + endif call drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & sb, fb) if ( ( 0. < fb .and. 0. < fc ) .or. & @@ -559,7 +559,7 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to fc = fa e = sb - sa d = e - end if + endif enddo ! Modified from original to ensure that the minimum is found fa = ABS(fa) ; fb = ABS(fb) ; fc = ABS(fc) diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 4c63ea2b33..deb395bc4a 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -252,7 +252,7 @@ subroutine distribute_residual_uh_barotropic(G, GV, hvol, uh) else h2d(i,k) = GV%H_subroundoff endif - enddo; enddo + enddo ; enddo ! Distribute flux. Note min/max is intended to make sure that the mass transport ! does not deplete a cell @@ -320,7 +320,7 @@ subroutine distribute_residual_vh_barotropic(G, GV, hvol, vh) else h2d(j,k) = GV%H_subroundoff endif - enddo; enddo + enddo ; enddo ! Distribute flux evenly throughout a column do j=js-1,je diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 8da247186e..a821219cd5 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -607,7 +607,7 @@ real function remaining_transport_sum(CS, uhtr, vhtr) if (ABS(vhtr(i,J,k))>vh_neglect) then remaining_transport_sum = remaining_transport_sum + ABS(vhtr(i,J,k)) endif - enddo; enddo; enddo + enddo ; enddo ; enddo call sum_across_PEs(remaining_transport_sum) end function remaining_transport_sum @@ -852,15 +852,15 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, do k = 1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 eatr_sub(i,j,k) = eatr(i,j,k) ebtr_sub(i,j,k) = ebtr(i,j,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo do k = 1, nz ; do j=js-1,je+1 ; do i=is-2,ie+1 uhtr_sub(I,j,k) = uhtr(I,j,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo do k = 1, nz ; do j=js-2,je+1 ; do i=is-1,ie+1 vhtr_sub(i,J,k) = vhtr(i,J,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo ! Calculate 3d mass transports to be used in this iteration @@ -881,7 +881,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, call update_h_horizontal_flux(G, GV, uhtr_sub, vhtr_sub, h_pre, h_new) do k = 1, nz ; do i = is-1, ie+1 ; do j=js-1, je+1 h_vol(i,j,k) = h_pre(i,j,k)*G%areaT(i,j) - enddo; enddo; enddo + enddo ; enddo ; enddo call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, dt_iter, G, GV, & CS%tracer_adv_CSp, CS%tracer_Reg, h_vol, max_iter_in=30, x_first_in=x_before_y) @@ -898,7 +898,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, call update_h_horizontal_flux(G, GV, uhtr_sub, vhtr_sub, h_pre, h_new) do k = 1, nz ; do i = is-1, ie+1 ; do j=js-1, je+1 h_vol(i,j,k) = h_pre(i,j,k)*G%areaT(i,j) - enddo; enddo; enddo + enddo ; enddo ; enddo call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, dt_iter, G, GV, & CS%tracer_adv_CSp, CS%tracer_Reg, h_vol, max_iter_in=30, x_first_in=x_before_y) @@ -922,15 +922,15 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, do k = 1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 eatr(i,j,k) = eatr(i,j,k) - eatr_sub(i,j,k) ebtr(i,j,k) = ebtr(i,j,k) - ebtr_sub(i,j,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo do k = 1, nz ; do j=js-1,je+1 ; do i=is-2,ie+1 uhtr(I,j,k) = uhtr(I,j,k) - uhtr_sub(I,j,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo do k = 1, nz ; do j=js-2,je+1 ; do i=is-1,ie+1 vhtr(i,J,k) = vhtr(i,J,k) - vhtr_sub(i,J,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo call pass_var(eatr,G%Domain) call pass_var(ebtr,G%Domain) @@ -946,7 +946,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, sum_v = sum_v + abs(vhtr(i,J-1,k))+abs(vhtr(I,J,k)) sum_abs_fluxes = sum_abs_fluxes + abs(eatr(i,j,k)) + abs(ebtr(i,j,k)) + abs(uhtr(I-1,j,k)) + & abs(uhtr(I,j,k)) + abs(vhtr(i,J-1,k)) + abs(vhtr(i,J,k)) - enddo; enddo; enddo + enddo ; enddo ; enddo call sum_across_PEs(sum_abs_fluxes) print *, "Remaining u-flux, v-flux:", sum_u, sum_v @@ -958,7 +958,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, ! Switch order of Strang split every iteration z_first = .not. z_first x_before_y = .not. x_before_y - end do + enddo end subroutine offline_advection_layer @@ -1025,7 +1025,7 @@ subroutine update_offline_fields(CS, h, fluxes, do_ale) if (CS%G%mask2dT(i,j)<1.0) then CS%h_end(i,j,k) = CS%GV%Angstrom endif - enddo; enddo ; enddo + enddo ; enddo ; enddo do k=1,nz+1 ; do j=js,je ; do i=is,ie CS%Kd(i,j,k) = max(0.0, CS%Kd(i,j,k)) @@ -1038,13 +1038,13 @@ subroutine update_offline_fields(CS, h, fluxes, do_ale) if (CS%G%mask2dCv(i,J)<1.0) then CS%vhtr(i,J,k) = 0.0 endif - enddo; enddo ; enddo + enddo ; enddo ; enddo do k=1,nz ; do j=js,je ; do I=is-1,ie if (CS%G%mask2dCu(I,j)<1.0) then CS%uhtr(I,j,k) = 0.0 endif - enddo; enddo ; enddo + enddo ; enddo ; enddo if (CS%debug) then call uvchksum("[uv]htr_sub after update_offline_fields", CS%uhtr, CS%vhtr, CS%G%HI) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 5c0bb7fd42..4d2bcd70f6 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -324,16 +324,26 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & is, ie, js, je, k, G, GV, usePPM, useHuynh) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(tracer_type), dimension(ntr), intent(inout) :: Tr - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hprev + type(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hprev !< cell volume at the end of previous + !! tracer change, in H m2 (m3 or kg) real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhr !< accumulated volume/mass flux through - !!the zonal face (m3 or kg) - real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: uh_neglect - type(ocean_OBC_type), pointer :: OBC - logical, dimension(SZJ_(G),SZK_(G)), intent(inout) :: domore_u - real, intent(in) :: Idt - integer, intent(in) :: ntr, is, ie, js, je,k - logical, intent(in) :: usePPM, useHuynh + !! the zonal face, in H m2 (m3 or kg) + real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: uh_neglect !< A tiny zonal mass flux that can + !! be neglected, in H m2 (m3 or kg) + type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used + logical, dimension(SZJ_(G),SZK_(G)), intent(inout) :: domore_u !< If true, there is more advection to be + !! done in this u-row + real, intent(in) :: Idt !< The inverse of dt, in s-1 + integer, intent(in) :: ntr !< The number of tracers + integer, intent(in) :: is !< The starting tracer i-index to work on + integer, intent(in) :: ie !< The ending tracer i-index to work on + integer, intent(in) :: js !< The starting tracer j-index to work on + integer, intent(in) :: je !< The ending tracer j-index to work on + integer, intent(in) :: k !< The k-level to work on + logical, intent(in) :: usePPM !< If true, use PPM instead of PLM + logical, intent(in) :: useHuynh !< If true, use the Huynh scheme + !! for PPM interface values real, dimension(SZI_(G),ntr) :: & slope_x ! The concentration slope per grid point in units of @@ -645,16 +655,26 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & is, ie, js, je, k, G, GV, usePPM, useHuynh) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(tracer_type), dimension(ntr), intent(inout) :: Tr - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hprev + type(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hprev !< cell volume at the end of previous + !! tracer change, in H m2 (m3 or kg) real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhr !< accumulated volume/mass flux through - !! the meridional face (m3 or kg) - real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vh_neglect - type(ocean_OBC_type), pointer :: OBC - logical, dimension(SZJB_(G),SZK_(G)), intent(inout) :: domore_v - real, intent(in) :: Idt - integer, intent(in) :: ntr, is, ie, js, je,k - logical, intent(in) :: usePPM, useHuynh + !! the meridional face, in H m2 (m3 or kg) + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vh_neglect !< A tiny meridional mass flux that can + !! be neglected, in H m2 (m3 or kg) + type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used + logical, dimension(SZJB_(G),SZK_(G)), intent(inout) :: domore_v !< If true, there is more advection to be + !! done in this v-row + real, intent(in) :: Idt !< The inverse of dt, in s-1 + integer, intent(in) :: ntr !< The number of tracers + integer, intent(in) :: is !< The starting tracer i-index to work on + integer, intent(in) :: ie !< The ending tracer i-index to work on + integer, intent(in) :: js !< The starting tracer j-index to work on + integer, intent(in) :: je !< The ending tracer j-index to work on + integer, intent(in) :: k !< The k-level to work on + logical, intent(in) :: usePPM !< If true, use PPM instead of PLM + logical, intent(in) :: useHuynh !< If true, use the Huynh scheme + !! for PPM interface values real, dimension(SZI_(G),ntr,SZJ_(G)) :: & slope_y ! The concentration slope per grid point in units of @@ -1029,7 +1049,7 @@ end subroutine tracer_advect_init !> Close the tracer advection module subroutine tracer_advect_end(CS) - type(tracer_advect_CS), pointer :: CS + type(tracer_advect_CS), pointer :: CS !< module control structure if (associated(CS)) deallocate(CS) diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index f61b5a6a5e..0bdd327033 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -85,18 +85,18 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & !$OMP h_old,convert_flux,h_neglect,eb,tr) & !$OMP private(sink,h_minus_dsink,b_denom_1,b1,d1,h_tr,c1) !$OMP do - do j=js,je; do i=is,ie ; sfc_src(i,j) = 0.0 ; btm_src(i,j) = 0.0 ; enddo; enddo + do j=js,je; do i=is,ie ; sfc_src(i,j) = 0.0 ; btm_src(i,j) = 0.0 ; enddo ; enddo if (present(sfc_flux)) then if (convert_flux) then !$OMP do do j = js, je; do i = is,ie sfc_src(i,j) = (sfc_flux(i,j)*dt) * GV%kg_m2_to_H - enddo; enddo + enddo ; enddo else !$OMP do do j = js, je; do i = is,ie sfc_src(i,j) = sfc_flux(i,j) - enddo; enddo + enddo ; enddo endif endif if (present(btm_flux)) then @@ -104,12 +104,12 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & !$OMP do do j = js, je; do i = is,ie btm_src(i,j) = (btm_flux(i,j)*dt) * GV%kg_m2_to_H - enddo; enddo + enddo ; enddo else !$OMP do do j = js, je; do i = is,ie btm_src(i,j) = btm_flux(i,j) - enddo; enddo + enddo ; enddo endif endif @@ -230,14 +230,17 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim real, intent(in ) :: dt !< Time-step over which forcing is applied (s) type(forcing), intent(in ) :: fluxes !< Surface fluxes container real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness in H units - real, intent(in ) :: evap_CFL_limit - real, intent(in ) :: minimum_forcing_depth + real, intent(in ) :: evap_CFL_limit !< Limit on the fraction of the + !! water that can be fluxed out of the top + !! layer in a timestep (nondim) + real, intent(in ) :: minimum_forcing_depth !< The smallest depth over + !! which fluxes can be applied, in m real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: in_flux_optional !< The total time-integrated !! amount of tracer that enters with freshwater - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: out_flux_optional ! The total time-integrated + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: out_flux_optional !< The total time-integrated !! amount of tracer that leaves with freshwater - !< Optional flag to determine whether h should be updated - logical, optional, intent(in) :: update_h_opt + logical, optional, intent(in) :: update_h_opt !< Optional flag to determine whether + !! h should be updated integer, parameter :: maxGroundings = 5 integer :: numberOfGroundings, iGround(maxGroundings), jGround(maxGroundings) @@ -271,7 +274,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim if (present(in_flux_optional)) then do j=js,je ; do i=is,ie in_flux(i,j) = in_flux_optional(i,j) - enddo; enddo + enddo ; enddo endif if (present(out_flux_optional)) then do j=js,je ; do i=is,ie diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 0a11de9c1e..8483bf2b6f 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -443,13 +443,12 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by !! a previous call to !! call_tracer_register. - logical, intent(in) :: debug !< Calculates checksums - real, optional,intent(in) :: evap_CFL_limit !< Limits how much water - !! can be fluxed out of the top layer - !! Stored previously in diabatic] CS. - real, optional,intent(in) :: minimum_forcing_depth !< The smallest depth - !! over which fluxes can be applied - !! Stored previously in diabatic CS. + logical, intent(in) :: debug !< If true calculate checksums + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of + !! the water that can be fluxed out + !! of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over + !! which fluxes can be applied, in m ! This subroutine calls all registered tracer column physics ! subroutines. @@ -596,36 +595,37 @@ end subroutine call_tracer_column_fns !> This subroutine calls all registered tracer packages to enable them to !! add to the surface state returned to the coupler. These routines are optional. subroutine call_tracer_stocks(h, stock_values, G, GV, CS, stock_names, stock_units, & - num_stocks, stock_index, got_min_max,global_min, global_max,xgmin, & - ygmin, zgmin, xgmax, ygmax, zgmax) + num_stocks, stock_index, got_min_max, global_min, global_max, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) real, dimension(NIMEM_,NJMEM_,NKMEM_), & intent(in) :: h !< Layer thicknesses, in H !! (usually m or kg m-2). - real, dimension(:), intent(out) :: stock_values + real, dimension(:), intent(out) :: stock_values !< The integrated amounts of a tracer + !! on the current PE, usually in kg x concentration. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to !! call_tracer_register. - character(len=*), dimension(:), optional, & - intent(out) :: stock_names !< Diagnostic names to use for each - !! stock. - character(len=*), dimension(:), optional, & - intent(out) :: stock_units !< Units to use in the metadata for - !! each stock. - integer, optional, & - intent(out) :: num_stocks !< The number of tracer stocks being - !! returned. - integer, optional, & - intent(in) :: stock_index !< The integer stock index from - !! stocks_constans_mod of the stock to be returned. If this is + character(len=*), dimension(:), & + optional, intent(out) :: stock_names !< Diagnostic names to use for each stock. + character(len=*), dimension(:), & + optional, intent(out) :: stock_units !< Units to use in the metadata for each stock. + integer, optional, intent(out) :: num_stocks !< The number of tracer stocks being returned. + integer, optional, intent(in) :: stock_index !< The integer stock index from + !! stocks_constants_mod of the stock to be returned. If this is !! present and greater than 0, only a single stock can be returned. - logical, dimension(:), optional, & - intent(inout) :: got_min_max - real, dimension(:), optional, & - intent(out) :: global_min, global_max - real, dimension(:), optional, & - intent(out) :: xgmin, ygmin, zgmin, xgmax, ygmax, zgmax + logical, dimension(:), & + optional, intent(inout) :: got_min_max !< Indicates whether the global min and + !! max are found for each tracer + real, dimension(:), optional, intent(out) :: global_min !< The global minimum of each tracer + real, dimension(:), optional, intent(out) :: global_max !< The global maximum of each tracer + real, dimension(:), optional, intent(out) :: xgmin !< The x-position of the global minimum + real, dimension(:), optional, intent(out) :: ygmin !< The y-position of the global minimum + real, dimension(:), optional, intent(out) :: zgmin !< The z-position of the global minimum + real, dimension(:), optional, intent(out) :: xgmax !< The x-position of the global maximum + real, dimension(:), optional, intent(out) :: ygmax !< The y-position of the global maximum + real, dimension(:), optional, intent(out) :: zgmax !< The z-position of the global maximum ! This subroutine calls all registered tracer packages to enable them to ! add to the surface state returned to the coupler. These routines are optional. @@ -707,8 +707,9 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, CS, stock_names, stock_uni call store_stocks("MOM_generic_tracer", ns, names, units, values, index, stock_values, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) nn=ns_tot-ns+1 - nn=MOM_generic_tracer_min_max(nn, got_min_max, global_min, global_max, xgmin, ygmin, zgmin, xgmax, ygmax, zgmax ,& - G, CS%MOM_generic_tracer_CSp,names, units) + nn=MOM_generic_tracer_min_max(nn, got_min_max, global_min, global_max, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax ,& + G, CS%MOM_generic_tracer_CSp,names, units) endif #endif @@ -735,16 +736,26 @@ end subroutine call_tracer_stocks !> This routine stores the stocks and does error handling for call_tracer_stocks. subroutine store_stocks(pkg_name, ns, names, units, values, index, stock_values, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) - character(len=*), intent(in) :: pkg_name - integer, intent(in) :: ns - character(len=*), dimension(:), intent(in) :: names, units - real, dimension(:), intent(in) :: values - integer, intent(in) :: index - real, dimension(:), intent(inout) :: stock_values - character(len=*), intent(inout) :: set_pkg_name - integer, intent(in) :: max_ns - integer, intent(inout) :: ns_tot - character(len=*), dimension(:), optional, intent(inout) :: stock_names, stock_units + character(len=*), intent(in) :: pkg_name !< The tracer package name + integer, intent(in) :: ns !< The number of stocks associated with this tracer package + character(len=*), dimension(:), & + intent(in) :: names !< Diagnostic names to use for each stock. + character(len=*), dimension(:), & + intent(in) :: units !< Units to use in the metadata for each stock. + real, dimension(:), intent(in) :: values !< The values of the tracer stocks + integer, intent(in) :: index !< The integer stock index from + !! stocks_constants_mod of the stock to be returned. If this is + !! present and greater than 0, only a single stock can be returned. + real, dimension(:), intent(inout) :: stock_values !< The master list of stock values + character(len=*), intent(inout) :: set_pkg_name !< The name of the last tracer package whose + !! stocks were stored for a specific index. This is + !! used to trigger an error if there are redundant stocks. + integer, intent(in) :: max_ns !< The maximum size of the master stock list + integer, intent(inout) :: ns_tot !< The total number of stocks in the master list + character(len=*), dimension(:), & + optional, intent(inout) :: stock_names !< Diagnostic names to use for each stock in the master list + character(len=*), dimension(:), & + optional, intent(inout) :: stock_units !< Units to use in the metadata for each stock in the master list ! This routine stores the stocks and does error handling for call_tracer_stocks. character(len=16) :: ind_text, ns_text, max_text @@ -830,7 +841,8 @@ subroutine call_tracer_surface_state(state, h, G, CS) end subroutine call_tracer_surface_state subroutine tracer_flow_control_end(CS) - type(tracer_flow_control_CS), pointer :: CS + type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a + !! previous call to call_tracer_register. if (CS%use_USER_tracer_example) & call USER_tracer_example_end(CS%USER_tracer_example_CSp) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 491803c4e5..bdadb4e4e0 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -723,7 +723,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & tmp = h_srt(i,k2-1,j) ; h_srt(i,k2-1,j) = h_srt(i,k2,j) ; h_srt(i,k2,j) = tmp enddo endif ; enddo - enddo; enddo + enddo ; enddo !$OMP do do j=js-1,je+1 max_srt(j) = 0 @@ -1478,7 +1478,7 @@ subroutine tracer_hor_diff_init(Time, G, param_file, diag, EOS, CS) end subroutine tracer_hor_diff_init subroutine tracer_hor_diff_end(CS) - type(tracer_hor_diff_CS), pointer :: CS + type(tracer_hor_diff_CS), pointer :: CS !< module control structure call neutral_diffusion_end(CS%neutral_diffusion_CSp) if (associated(CS)) deallocate(CS) diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 7fb6ff8028..58c8955234 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -98,12 +98,15 @@ module advection_test_tracer contains function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(advection_test_tracer_CS), pointer :: CS - type(tracer_registry_type), pointer :: tr_Reg - type(MOM_restart_CS), pointer :: restart_CS + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! This subroutine is used to register tracer fields and subroutines ! to be used with MOM. ! Arguments: HI - A horizontal index type structure. @@ -203,16 +206,23 @@ end function register_advection_test_tracer subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS, & sponge_CSp, diag_to_Z_CSp) - logical, intent(in) :: restart - type(time_type), target, intent(in) :: day + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in) :: diag - type(ocean_OBC_type), pointer :: OBC - type(advection_test_tracer_CS), pointer :: CS - type(sponge_CS), pointer :: sponge_CSp - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure + !! for diagnostics in depth space. ! This subroutine initializes the NTR tracer fields in tr(:,:,:,:) ! and it sets up the tracer output. @@ -307,14 +317,29 @@ end subroutine initialize_advection_test_tracer subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old, h_new, ea, eb - type(forcing), intent(in) :: fluxes - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(advection_test_tracer_CS), pointer :: CS - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! This is a simple example of a set of advected passive tracers. @@ -398,12 +423,15 @@ end subroutine advection_test_tracer_surface_state function advection_test_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(:), intent(out) :: stocks + real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(advection_test_tracer_CS), pointer :: CS - character(len=*), dimension(:), intent(out) :: names - character(len=*), dimension(:), intent(out) :: units - integer, optional, intent(in) :: stock_index + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< the coded index of a specific stock + !! being sought. integer :: advection_test_stock ! This function calculates the mass-weighted integral of all tracer stocks, ! returning the number of stocks it has calculated. If the stock_index @@ -449,7 +477,8 @@ function advection_test_stock(h, stocks, G, GV, CS, names, units, stock_index) end function advection_test_stock subroutine advection_test_tracer_end(CS) - type(advection_test_tracer_CS), pointer :: CS + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. integer :: m if (associated(CS)) then diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index f320bb5716..6cfa91049f 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -67,12 +67,15 @@ module boundary_impulse_tracer !> Read in runtime options and add boundary impulse tracer to tracer registry function register_boundary_impulse_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in ) :: HI + type(hor_index_type), intent(in ) :: HI !< A horizontal index type structure type(verticalGrid_type), intent(in ) :: GV !< The ocean's vertical grid structure type(param_file_type), intent(in ) :: param_file !< A structure to parse for run-time parameters - type(boundary_impulse_tracer_CS), pointer :: CS - type(tracer_registry_type), pointer :: tr_Reg - type(MOM_restart_CS), pointer :: restart_CS + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! This subroutine is used to register tracer fields and subroutines ! to be used with MOM. ! Arguments: HI - A horizontal index type structure. @@ -160,18 +163,25 @@ end function register_boundary_impulse_tracer !> Initialize tracer from restart or set to 1 at surface to initialize subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, h, diag, OBC, CS, & sponge_CSp, diag_to_Z_CSp, tv) - logical, intent(in ) :: restart - type(time_type), target, intent(in ) :: day - type(ocean_grid_type), intent(in ) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in ) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in ) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in ) :: diag - type(ocean_OBC_type), pointer, intent(inout) :: OBC - type(boundary_impulse_tracer_CS), pointer,intent(inout) :: CS - type(sponge_CS), pointer, intent(inout) :: sponge_CSp - type(diag_to_Z_CS), pointer, intent(inout) :: diag_to_Z_CSp - type(thermo_var_ptrs), intent(in ) :: tv !< A structure pointing to various - !! thermodynamic variables + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure + !! for diagnostics in depth space. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables ! This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) ! and it sets up the tracer output. @@ -226,19 +236,34 @@ subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, h, diag, OBC, end subroutine initialize_boundary_impulse_tracer ! Apply source or sink at boundary and do vertical diffusion -subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, tv, debug, & - evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in ) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in ) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in ) :: h_old, h_new, ea, eb - type(forcing), intent(in ) :: fluxes - real, intent(in ) :: dt !< The amount of time covered by this call, in s - type(boundary_impulse_tracer_CS), pointer :: CS - type(thermo_var_ptrs), intent(in ) :: tv !< A structure pointing to various - !! thermodynamic variables - logical, intent(in ) :: debug - real, optional, intent(in ) :: evap_CFL_limit - real, optional, intent(in ) :: minimum_forcing_depth +subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & + tv, debug, evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + logical, intent(in) :: debug !< If true calculate checksums + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. @@ -314,11 +339,16 @@ function boundary_impulse_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in ) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in ) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in ) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(:), intent( out) :: stocks - type(boundary_impulse_tracer_CS), pointer, intent(in ) :: CS - character(len=*), dimension(:), intent( out) :: names - character(len=*), dimension(:), intent( out) :: units - integer, optional, intent(in ) :: stock_index + real, dimension(:), intent( out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units. + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + character(len=*), dimension(:), intent( out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent( out) :: units !< The units of the stocks calculated. + integer, optional, intent(in ) :: stock_index !< The coded index of a specific stock + !! being sought. + integer :: boundary_impulse_stock !< Return value: the number of stocks calculated here. + ! This function calculates the mass-weighted integral of all tracer stocks, ! returning the number of stocks it has calculated. If the stock_index ! is present, only the stock corresponding to that coded index is returned. @@ -334,7 +364,7 @@ function boundary_impulse_stock(h, stocks, G, GV, CS, names, units, stock_index) ! (out) units - the units of the stocks calculated. ! (in,opt) stock_index - the coded index of a specific stock being sought. ! Return value: the number of stocks calculated here. - integer :: boundary_impulse_stock + integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -399,7 +429,8 @@ end subroutine boundary_impulse_tracer_surface_state ! Performs finalization of boundary impulse tracer subroutine boundary_impulse_tracer_end(CS) - type(boundary_impulse_tracer_CS), pointer :: CS + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. integer :: m if (associated(CS)) then diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index d2cc4dafbb..871b7cdc58 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -233,7 +233,7 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C z_bot = z_bot + h(i,j,k)*GV%H_to_m enddo endif - enddo; enddo + enddo ; enddo enddo end subroutine initialize_dye_tracer @@ -245,25 +245,29 @@ end subroutine initialize_dye_tracer !! h_new[k] = h_old[k] + ea[k] - eb[k-1] + eb[k] - ea[k+1] subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & evap_CFL_limit, minimum_forcing_depth) - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_old !< Layer thickness before entrainment, - !! in m or kg m-2. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_new !< Layer thickness after entrainment, - !! in m or kg m-2. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: ea !< an array to which the amount of - !! fluid entrained from the layer above during this - !! call will be added, in m or kg m-2. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: eb !< an array to which the amount of - !! fluid entrained from the layer below during this - !! call will be added, in m or kg m-2. - type(forcing), intent(in) :: fluxes !< A structure containing pointers to - !! any possible forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to register_dye_tracer. - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_dye_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified @@ -312,7 +316,7 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS z_bot = z_bot + h_new(i,j,k)*GV%H_to_m enddo endif - enddo; enddo + enddo ; enddo enddo end subroutine dye_tracer_column_physics @@ -399,7 +403,8 @@ end subroutine dye_tracer_surface_state !> Clean up any allocated memory after the run. subroutine regional_dyes_end(CS) - type(dye_tracer_CS), pointer :: CS + type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_dye_tracer. integer :: m if (associated(CS)) then diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index e65dcdfcf4..10d3d5108b 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -209,25 +209,29 @@ end subroutine initialize_dyed_obc_tracer !! h_new[k] = h_old[k] + ea[k] - eb[k-1] + eb[k] - ea[k+1] subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old !< Layer thickness before entrainment, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_new !< Layer thickness after entrainment, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: ea !< an array to which the amount of - !! fluid entrained from the layer above during this - !! call will be added, in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: eb !< an array to which the amount of - !! fluid entrained from the layer below during this - !! call will be added, in m or kg m-2. - type(forcing), intent(in) :: fluxes !< A structure containing pointers to - !! any possible forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to dyed_obc_register_tracer. - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to dyed_obc_register_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! Local variables real :: b1(SZI_(G)) ! b1 and c1 are variables used by the @@ -258,7 +262,8 @@ end subroutine dyed_obc_tracer_column_physics !> Clean up memory allocations, if any. subroutine dyed_obc_tracer_end(CS) - type(dyed_obc_tracer_CS), pointer :: CS + type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to dyed_obc_register_tracer. integer :: m if (associated(CS)) then @@ -271,7 +276,7 @@ end subroutine dyed_obc_tracer_end !> \namespace dyed_obc_tracer !! * !! By Kate Hedstrom, 2017, copied from DOME tracers and also * -!! dye_example. * +!! dye_example. * !! * !! This file contains an example of the code that is needed to set * !! up and use a set of dynamically passive tracers. These tracers * diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 0a0ad34b3f..c284a4d452 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -109,12 +109,15 @@ module ideal_age_example contains function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(ideal_age_tracer_CS), pointer :: CS - type(tracer_registry_type), pointer :: tr_Reg - type(MOM_restart_CS), pointer :: restart_CS + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! This subroutine is used to register tracer fields and subroutines ! to be used with MOM. ! Arguments: HI - A horizontal index type structure. @@ -239,16 +242,23 @@ end function register_ideal_age_tracer subroutine initialize_ideal_age_tracer(restart, day, G, GV, h, diag, OBC, CS, & sponge_CSp, diag_to_Z_CSp) - logical, intent(in) :: restart - type(time_type), target, intent(in) :: day + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in) :: diag - type(ocean_OBC_type), pointer :: OBC - type(ideal_age_tracer_CS), pointer :: CS - type(sponge_CS), pointer :: sponge_CSp - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure + !! for diagnostics in depth space. ! This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) ! and it sets up the tracer output. @@ -333,14 +343,29 @@ end subroutine initialize_ideal_age_tracer subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old, h_new, ea, eb - type(forcing), intent(in) :: fluxes - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(ideal_age_tracer_CS), pointer :: CS - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! This is a simple example of a set of advected passive tracers. @@ -422,13 +447,17 @@ end subroutine ideal_age_tracer_column_physics function ideal_age_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(:), intent(out) :: stocks + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(ideal_age_tracer_CS), pointer :: CS - character(len=*), dimension(:), intent(out) :: names - character(len=*), dimension(:), intent(out) :: units - integer, optional, intent(in) :: stock_index + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< the coded index of a specific stock + !! being sought. integer :: ideal_age_stock ! This function calculates the mass-weighted integral of all tracer stocks, ! returning the number of stocks it has calculated. If the stock_index @@ -508,7 +537,9 @@ subroutine ideal_age_tracer_surface_state(state, h, G, CS) end subroutine ideal_age_tracer_surface_state subroutine ideal_age_example_end(CS) - type(ideal_age_tracer_CS), pointer :: CS + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + integer :: m if (associated(CS)) then diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index b3f595f175..47edfac6e6 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -114,12 +114,15 @@ module oil_tracer contains function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(oil_tracer_CS), pointer :: CS - type(tracer_registry_type), pointer :: tr_Reg - type(MOM_restart_CS), pointer :: restart_CS + type(oil_tracer_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! This subroutine is used to register tracer fields and subroutines ! to be used with MOM. ! Arguments: HI - A horizontal index type structure. @@ -247,16 +250,23 @@ end function register_oil_tracer subroutine initialize_oil_tracer(restart, day, G, GV, h, diag, OBC, CS, & sponge_CSp, diag_to_Z_CSp) - logical, intent(in) :: restart - type(time_type), target, intent(in) :: day + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in) :: diag - type(ocean_OBC_type), pointer :: OBC - type(oil_tracer_CS), pointer :: CS - type(sponge_CS), pointer :: sponge_CSp - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_oil_tracer. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure + !! for diagnostics in depth space. ! This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) ! and it sets up the tracer output. @@ -301,7 +311,7 @@ subroutine initialize_oil_tracer(restart, day, G, GV, h, diag, OBC, CS, & CS%oil_source_i=i CS%oil_source_j=j endif - enddo; enddo + enddo ; enddo CS%Time => day CS%diag => diag @@ -351,15 +361,30 @@ end subroutine initialize_oil_tracer subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, tv, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old, h_new, ea, eb - type(forcing), intent(in) :: fluxes - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(oil_tracer_CS), pointer :: CS - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_oil_tracer. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! This is a simple example of a set of advected passive tracers. @@ -462,11 +487,14 @@ function oil_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(:), intent(out) :: stocks - type(oil_tracer_CS), pointer :: CS - character(len=*), dimension(:), intent(out) :: names - character(len=*), dimension(:), intent(out) :: units - integer, optional, intent(in) :: stock_index + real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units. + type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_oil_tracer. + character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< the coded index of a specific stock + !! being sought. integer :: oil_stock ! This function calculates the mass-weighted integral of all tracer stocks, ! returning the number of stocks it has calculated. If the stock_index @@ -546,7 +574,8 @@ subroutine oil_tracer_surface_state(state, h, G, CS) end subroutine oil_tracer_surface_state subroutine oil_tracer_end(CS) - type(oil_tracer_CS), pointer :: CS + type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_oil_tracer. integer :: m if (associated(CS)) then diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index 06d490c835..ec13de8df2 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -88,12 +88,15 @@ module pseudo_salt_tracer contains function register_pseudo_salt_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(pseudo_salt_tracer_CS), pointer :: CS - type(tracer_registry_type), pointer :: tr_Reg - type(MOM_restart_CS), pointer :: restart_CS + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! This subroutine is used to register tracer fields and subroutines ! to be used with MOM. ! Arguments: HI - A horizontal index type structure. @@ -149,16 +152,23 @@ end function register_pseudo_salt_tracer subroutine initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS, & sponge_CSp, diag_to_Z_CSp, tv) - logical, intent(in) :: restart - type(time_type), target, intent(in) :: day + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in) :: diag - type(ocean_OBC_type), pointer :: OBC - type(pseudo_salt_tracer_CS), pointer :: CS - type(sponge_CS), pointer :: sponge_CSp - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure + !! for diagnostics in depth space. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables ! This subroutine initializes the tracer fields in CS%ps(:,:,:). @@ -215,16 +225,31 @@ end subroutine initialize_pseudo_salt_tracer subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, tv, debug, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old, h_new, ea, eb - type(forcing), intent(in) :: fluxes - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(pseudo_salt_tracer_CS), pointer :: CS - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - logical, intent(in) :: debug - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + logical, intent(in) :: debug !< If true calculate checksums + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. @@ -303,12 +328,17 @@ function pseudo_salt_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(:), intent(out) :: stocks - type(pseudo_salt_tracer_CS), pointer :: CS - character(len=*), dimension(:), intent(out) :: names - character(len=*), dimension(:), intent(out) :: units - integer, optional, intent(in) :: stock_index - integer :: pseudo_salt_stock + real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units. + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer. + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< The coded index of a specific stock + !! being sought. + integer :: pseudo_salt_stock !< Return value: the number of + !! stocks calculated here. + ! This function calculates the mass-weighted integral of all tracer stocks, ! returning the number of stocks it has calculated. If the stock_index ! is present, only the stock corresponding to that coded index is returned. @@ -378,7 +408,8 @@ subroutine pseudo_salt_tracer_surface_state(state, h, G, CS) end subroutine pseudo_salt_tracer_surface_state subroutine pseudo_salt_tracer_end(CS) - type(pseudo_salt_tracer_CS), pointer :: CS + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer. integer :: m if (associated(CS)) then diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index 7035d72a26..c169ce768e 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -89,15 +89,15 @@ module USER_tracer_example !> This subroutine is used to register tracer fields and subroutines !! to be used with MOM. function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(USER_tracer_example_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control !! structure for the tracer advection and - !! diffusion module. - type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! Local variables character(len=80) :: name, longname @@ -174,13 +174,13 @@ end function USER_register_tracer_example subroutine USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS, & sponge_CSp, diag_to_Z_CSp) logical, intent(in) :: restart !< .true. if the fields have already - !! been read from a restart file. - type(time_type), target, intent(in) :: day !< Time of the start of the run. + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary @@ -298,23 +298,25 @@ end subroutine USER_initialize_tracer !! The arguments to this subroutine are redundant in that !! h_new[k] = h_old[k] + ea[k] - eb[k-1] + eb[k] - ea[k+1] subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old !< Layer thickness before entrainment, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_new !< Layer thickness after entrainment, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: ea !< an array to which the amount of - !! fluid entrained from the layer above during this - !! call will be added, in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: eb !< an array to which the amount of - !! fluid entrained from the layer below during this - !! call will be added, in m or kg m-2. - type(forcing), intent(in) :: fluxes !< A structure containing pointers to - !! any possible forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous - !! call to USER_register_tracer_example. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous + !! call to USER_register_tracer_example. ! Local variables real :: hold0(SZI_(G)) ! The original topmost layer thickness, @@ -402,12 +404,12 @@ function USER_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) !! tracer, in kg times concentration units. type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a !! previous call to register_USER_tracer. - character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. - character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. - integer, optional, intent(in) :: stock_index !< the coded index of a specific stock - !! being sought. + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< The coded index of a specific stock + !! being sought. integer :: USER_tracer_stock !< Return value: the number of - !! stocks calculated here. + !! stocks calculated here. ! Local variables integer :: i, j, k, is, ie, js, je, nz, m @@ -471,7 +473,8 @@ end subroutine USER_tracer_surface_state !> Clean up allocated memory at the end. subroutine USER_tracer_example_end(CS) - type(USER_tracer_example_CS), pointer :: CS + type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_USER_tracer. integer :: m if (associated(CS)) then diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 8e6443ae4a..b4d317d289 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -75,10 +75,10 @@ subroutine BFB_set_coord(Rlay, g_prime, GV, param_file, eqn_of_state) g_prime(k) = (Rlay(k) - Rlay(k-1))*GV%g_earth/GV%rho0 else g_prime(k) = GV%g_earth - end if + endif !Rlay(:) = 0.0 !g_prime(:) = 0.0 - end do + enddo if (first_call) call write_BFB_log(param_file) diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 7aa2943ff0..e3aa923179 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -202,12 +202,12 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, CS) ! density in kg m-3 that is being restored toward. if (G%geoLatT(i,j) < CS%lfrslat) then Temp_restore = CS%SST_s - else if (G%geoLatT(i,j) > CS%lfrnlat) then + elseif (G%geoLatT(i,j) > CS%lfrnlat) then Temp_restore = CS%SST_n else Temp_restore = (CS%SST_s - CS%SST_n)/(CS%lfrslat - CS%lfrnlat) * & (G%geoLatT(i,j) - CS%lfrslat) + CS%SST_s - end if + endif density_restore = Temp_restore*CS%drho_dt + CS%Rho0 diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 0e9a18ffad..3b30e2ee31 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -71,7 +71,7 @@ subroutine DOME2d_initialize_topography ( D, G, param_file, max_depth ) if ( x <= l1 ) then D(i,j) = bay_depth * max_depth - else if (( x > l1 ) .and. ( x < l2 )) then + elseif (( x > l1 ) .and. ( x < l2 )) then D(i,j) = bay_depth * max_depth + (1.0-bay_depth) * max_depth * & ( x - l1 ) / (l2 - l1) else @@ -453,7 +453,7 @@ subroutine DOME2d_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo - enddo; enddo + enddo ; enddo ! Store the grid on which the T/S sponge data will reside call initialize_ALE_sponge(Idamp, G, param_file, ACSp, h, nz) diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index b8d46798e4..34ef50b8cb 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -238,7 +238,7 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par do j=js,je ; do i=is,ie delta_h = G%bathyT(i,j) / dfloat(nz) h(i,j,:) = GV%m_to_H * delta_h - end do ; end do + enddo ; enddo case default call MOM_error(FATAL,"isomip_initialize: "// & @@ -570,7 +570,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, tv, PF, use_ALE, CSp, ACSp) do j=js,je ; do i=is,ie delta_h = G%bathyT(i,j) / dfloat(nz) h(i,j,:) = delta_h - end do ; end do + enddo ; enddo case default call MOM_error(FATAL,"ISOMIP_initialize_sponges: "// & diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index a41e3b55a2..c464a2b1f6 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -798,14 +798,14 @@ subroutine Surface_Bands_by_data_override(day_center,G,GV,CS) temp_x(i,j)=0.0 temp_y(i,j)=0.0 endif - enddo; enddo + enddo ; enddo ! Interpolate to u/v grids do j = G%jsc,G%jec ; do I = G%IscB,G%IecB CS%STKx0(I,j,b) = 0.5 * (temp_x(i,j) + temp_x(i+1,j)) - enddo; enddo + enddo ; enddo do j = G%JscB,G%JecB ; do i = G%isc,G%iec CS%STKy0(i,J,b) = 0.5 * (temp_y(i,j) + temp_y(i,j+1)) - enddo; enddo + enddo ; enddo ! Disperse into halo on u/v grids call pass_vector(CS%STKx0(:,:,b),CS%STKy0(:,:,b), G%Domain, To_ALL) enddo @@ -895,7 +895,7 @@ subroutine get_Langmuir_Number( LA, G, GV, HBL, USTAR, I, J, & if (.not.(WaveMethod==LF17)) then LA = max(0.1,sqrt(USTAR/(LA_STK+1.e-8))) - end if + endif if (LA_Misalignment) then WaveDirection = atan2(LA_STKy,LA_STKx) diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index 736e6d662b..83740a1d61 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -310,14 +310,14 @@ subroutine Phillips_initialize_topography(D, G, param_file, max_depth) D(i,j) = Htop*sin(PI*(G%geoLonT(i,j)-x1)/(x2-x1))**2 if (G%geoLatT(i,j)>y1 .and. G%geoLatT(i,j)x3 .and. G%geoLonT(i,j)x3 .and. G%geoLonT(i,j)y1 .and. G%geoLatT(i,j) 0. .and. x > (1. - east_sponge_width)) then + elseif (east_sponge_time_scale > 0. .and. x > (1. - east_sponge_width)) then dist = 1. - (1. - x) / east_sponge_width Idamp(i,j) = 1. / east_sponge_time_scale * max(0., min(1., dist)) endif diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index e2bc9b5869..b19afec76c 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -177,7 +177,7 @@ subroutine dumbbell_initialize_thickness ( h, G, GV, param_file, just_read_param do j=js,je ; do i=is,ie delta_h = G%bathyT(i,j) / dfloat(nz) h(i,j,:) = delta_h - end do ; end do + enddo ; enddo end select diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 2eeda73243..839918270d 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -162,7 +162,7 @@ subroutine dumbbell_buoyancy_forcing(state, fluxes, day, dt, G, CS) ((CS%S_restore(i,j) - state%SSS(i,j)) / & (0.5 * (CS%S_restore(i,j) + state%SSS(i,j)))) - end if + endif enddo ; enddo endif ! end RESTOREBUOY @@ -234,7 +234,7 @@ subroutine dumbbell_dynamic_forcing(state, fluxes, day, dt, G, CS) G%mask2dT(i,j) * sin(deg_rad*(rdays/CS%slp_period)) fluxes%p_surf_full(i,j) = CS%forcing_mask(i,j) * CS%slp_amplitude * & G%mask2dT(i,j) * sin(deg_rad*(rdays/CS%slp_period)) - enddo; enddo + enddo ; enddo @@ -339,7 +339,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, param_file, diag, CS) if ((x>0.25)) then CS%forcing_mask(i,j) = 1 CS%S_restore(i,j) = CS%S_surf + CS%S_range - else if ((x<-0.25)) then + elseif ((x<-0.25)) then CS%forcing_mask(i,j) = 1 CS%S_restore(i,j) = CS%S_surf - CS%S_range endif diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index 790185d0ee..017a36bc9a 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -178,7 +178,7 @@ subroutine seamount_initialize_thickness ( h, G, GV, param_file, just_read_param do j=js,je ; do i=is,ie delta_h = G%bathyT(i,j) / dfloat(nz) h(i,j,:) = GV%m_to_H * delta_h - end do ; end do + enddo ; enddo end select diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index a33718b243..14f31e6916 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -101,7 +101,7 @@ subroutine sloshing_initialize_thickness ( h, G, GV, param_file, just_read_param ! Define uniform interfaces do k = 0,nz z_unif(k+1) = -real(k)/real(nz) - end do + enddo ! 1. Define stratification n = 3 @@ -117,17 +117,17 @@ subroutine sloshing_initialize_thickness ( h, G, GV, param_file, just_read_param if ( x <= x1 ) then t = y1*x/x1 - else if ( (x > x1 ) .and. ( x < x2 )) then + elseif ( (x > x1 ) .and. ( x < x2 )) then t = y1 + (y2-y1) * (x-x1) / (x2-x1) else t = y2 + (1.0-y2) * (x-x2) / (1.0-x2) - end if + endif t = - z_unif(k) z_inter(k) = -t * G%max_depth - end do + enddo ! 2. Define displacement a0 = 75.0; ! Displacement amplitude (meters) @@ -140,15 +140,15 @@ subroutine sloshing_initialize_thickness ( h, G, GV, param_file, just_read_param if ( k == 1 ) then displ(k) = 0.0 - end if + endif if ( k == nz+1 ) then displ(k) = 0.0 - end if + endif z_inter(k) = z_inter(k) + displ(k) - end do + enddo ! 3. The last interface must coincide with the seabed z_inter(nz+1) = -G%bathyT(i,j) @@ -159,9 +159,9 @@ subroutine sloshing_initialize_thickness ( h, G, GV, param_file, just_read_param if ( z_inter(k) < (z_inter(k+1) + GV%Angstrom_Z) ) then z_inter(k) = z_inter(k+1) + GV%Angstrom_Z - end if + endif - end do + enddo ! 4. Define layers total_height = 0.0 @@ -169,7 +169,7 @@ subroutine sloshing_initialize_thickness ( h, G, GV, param_file, just_read_param h(i,j,k) = GV%m_to_H * (z_inter(k) - z_inter(k+1)) total_height = total_height + h(i,j,k) - end do + enddo enddo ; enddo @@ -234,7 +234,7 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file !S(:,:,1) = S_ref !do k = 2,G%ke ! S(:,:,k) = S(:,:,k-1) + delta_S - !end do + !enddo deltah = G%max_depth / nz do j=js,je ; do i=is,ie @@ -252,7 +252,7 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file T(:,:,1) = T_ref do k = 2,G%ke T(:,:,k) = T(:,:,k-1) + delta_T - end do + enddo kdelta = 2 T(:,:,G%ke/2 - (kdelta-1):G%ke/2 + kdelta) = 1.0 diff --git a/src/user/soliton_initialization.F90 b/src/user/soliton_initialization.F90 index 1d4981a003..c9e7eec40e 100644 --- a/src/user/soliton_initialization.F90 +++ b/src/user/soliton_initialization.F90 @@ -55,7 +55,7 @@ subroutine soliton_initialize_thickness(h, G, GV) val4 = val2*((2.0*val3/(1.0+(val3*val3)))**2) h(i,j,k) = GV%m_to_H * (0.25*val4 * (6.0*y*y+3.0) * exp(-0.5*y*y)) enddo - end do ; end do + enddo ; enddo end subroutine soliton_initialize_thickness