From eacf2de41be760722bcd079a9d11c4eac61246d4 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 1 Sep 2021 10:38:02 -0400 Subject: [PATCH 1/4] Move to latest FMS in Baselibs --- CMakeLists.txt | 22 +++++++++--------- model/boundary.F90 | 38 ++++++++++++++++---------------- model/fv_control.F90 | 28 +++++++++++------------ model/mapz-driver/CMakeLists.txt | 6 ++--- tools/fv_diagnostics.F90 | 4 ++-- tools/fv_mp_mod.F90 | 4 ++-- 6 files changed, 51 insertions(+), 51 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 26e2a07df..835ae5996 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -60,23 +60,23 @@ else () INCLUDES ${INC_ESMF}) endif () -if (FV_PRECISION STREQUAL R4) -elseif (FV_PRECISION STREQUAL R4R8) # FV is R4 but FMS is R8 - get_target_property (extra_incs fms_r4 INCLUDE_DIRECTORIES) - target_include_directories(${this} PRIVATE - $ - ) -elseif (FV_PRECISION STREQUAL R8) -endif () +#if (FV_PRECISION STREQUAL R4) +#elseif (FV_PRECISION STREQUAL R4R8) # FV is R4 but FMS is R8 + #get_target_property (extra_incs fms_r4 INCLUDE_DIRECTORIES) + #target_include_directories(${this} PRIVATE + #$ + #) +#elseif (FV_PRECISION STREQUAL R8) +#endif () if (FV_PRECISION STREQUAL R4) target_compile_definitions (${this} PRIVATE -DSINGLE_FV -DOVERLOAD_R4) - target_link_libraries (${this} PUBLIC fms_r4) + target_link_libraries (${this} PUBLIC FMS::FMS) elseif (FV_PRECISION STREQUAL R4R8) # FV is R4 but FMS is R8 target_compile_definitions (${this} PRIVATE -DSINGLE_FV -DOVERLOAD_R4) - target_link_libraries (${this} PUBLIC fms_r8) + target_link_libraries (${this} PUBLIC FMS::FMS) elseif (FV_PRECISION STREQUAL R8) - target_link_libraries (${this} PUBLIC fms_r8) + target_link_libraries (${this} PUBLIC FMS::FMS) string(REPLACE " " ";" tmp ${FREAL8}) foreach(flag ${tmp}) target_compile_options (${this} PRIVATE $<$:${flag}>) diff --git a/model/boundary.F90 b/model/boundary.F90 index 49c882bf6..4c5179a02 100644 --- a/model/boundary.F90 +++ b/model/boundary.F90 @@ -631,13 +631,13 @@ subroutine nested_grid_BC_mpp(var_nest, var_coarse, nest_domain, ind, wt, istag, end if call mpp_get_C2F_index(nest_domain, isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c, & - WEST, position=position) + WEST, nest_level=0, position=position) call mpp_get_C2F_index(nest_domain, ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c, & - EAST, position=position) + EAST, nest_level=0, position=position) call mpp_get_C2F_index(nest_domain, iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c, & - SOUTH, position=position) + SOUTH, nest_level=0, position=position) call mpp_get_C2F_index(nest_domain, isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c, & - NORTH, position=position) + NORTH, nest_level=0, position=position) if( iew_c .GE. isw_c .AND. jew_c .GE. jsw_c ) then allocate(wbuffer(isw_c:iew_c, jsw_c:jew_c,npz)) @@ -669,7 +669,7 @@ subroutine nested_grid_BC_mpp(var_nest, var_coarse, nest_domain, ind, wt, istag, call timing_on ('COMM_TOTAL') - call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, position=position) + call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, nest_level=0, position=position) call timing_off('COMM_TOTAL') if (process) then @@ -820,7 +820,7 @@ subroutine nested_grid_BC_mpp_send(var_coarse, nest_domain, istag, jstag) call timing_on ('COMM_TOTAL') - call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, position=position) + call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, nest_level=0, position=position) call timing_off('COMM_TOTAL') @@ -884,13 +884,13 @@ subroutine nested_grid_BC_2D_mpp(var_nest, var_coarse, nest_domain, ind, wt, ist end if call mpp_get_C2F_index(nest_domain, isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c, & - WEST, position=position) + WEST, nest_level=0, position=position) call mpp_get_C2F_index(nest_domain, ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c, & - EAST, position=position) + EAST, nest_level=0, position=position) call mpp_get_C2F_index(nest_domain, iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c, & - SOUTH, position=position) + SOUTH, nest_level=0, position=position) call mpp_get_C2F_index(nest_domain, isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c, & - NORTH, position=position) + NORTH, nest_level=0, position=position) if( iew_c .GE. isw_c .AND. jew_c .GE. jsw_c ) then allocate(wbuffer(isw_c:iew_c, jsw_c:jew_c)) @@ -921,7 +921,7 @@ subroutine nested_grid_BC_2D_mpp(var_nest, var_coarse, nest_domain, ind, wt, ist nbuffer = 0 call timing_on ('COMM_TOTAL') - call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, position=position) + call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, nest_level=0, position=position) call timing_off('COMM_TOTAL') if (process) then @@ -1330,7 +1330,7 @@ subroutine nested_grid_BC_send(var_coarse, nest_domain, istag, jstag) end if call timing_on ('COMM_TOTAL') - call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, position=position) + call mpp_update_nest_fine(var_coarse, nest_domain, wbuffer, sbuffer, ebuffer, nbuffer, nest_level=0, position=position) call timing_off('COMM_TOTAL') end subroutine nested_grid_BC_send @@ -1369,13 +1369,13 @@ subroutine nested_grid_BC_recv(nest_domain, istag, jstag, npz, & if (.not. allocated(nest_BC_buffers%west_t1) ) then call mpp_get_C2F_index(nest_domain, isw_f, iew_f, jsw_f, jew_f, isw_c, iew_c, jsw_c, jew_c, & - WEST, position=position) + WEST, nest_level=0, position=position) call mpp_get_C2F_index(nest_domain, ise_f, iee_f, jse_f, jee_f, ise_c, iee_c, jse_c, jee_c, & - EAST, position=position) + EAST, nest_level=0, position=position) call mpp_get_C2F_index(nest_domain, iss_f, ies_f, jss_f, jes_f, iss_c, ies_c, jss_c, jes_c, & - SOUTH, position=position) + SOUTH, nest_level=0, position=position) call mpp_get_C2F_index(nest_domain, isn_f, ien_f, jsn_f, jen_f, isn_c, ien_c, jsn_c, jen_c, & - NORTH, position=position) + NORTH, nest_level=0, position=position) if( iew_c .GE. isw_c .AND. jew_c .GE. jsw_c ) then If (.not. allocated(nest_BC_buffers%west_t1)) allocate(nest_BC_buffers%west_t1(isw_c:iew_c, jsw_c:jew_c,npz)) @@ -1437,7 +1437,7 @@ subroutine nested_grid_BC_recv(nest_domain, istag, jstag, npz, & endif call timing_on ('COMM_TOTAL') - call mpp_update_nest_fine(var_coarse_dummy, nest_domain, nest_BC_buffers%west_t1, nest_BC_buffers%south_t1, nest_BC_buffers%east_t1, nest_BC_buffers%north_t1, position=position) + call mpp_update_nest_fine(var_coarse_dummy, nest_domain, nest_BC_buffers%west_t1, nest_BC_buffers%south_t1, nest_BC_buffers%east_t1, nest_BC_buffers%north_t1, nest_level=0, position=position) call timing_off('COMM_TOTAL') end subroutine nested_grid_BC_recv @@ -1871,7 +1871,7 @@ subroutine update_coarse_grid_mpp(var_coarse, var_nest, nest_domain, ind_update, position = CENTER end if - call mpp_get_F2C_index(nest_domain, is_c, ie_c, js_c, je_c, is_f, ie_f, js_f, je_f, position=position) + call mpp_get_F2C_index(nest_domain, is_c, ie_c, js_c, je_c, is_f, ie_f, js_f, je_f, nest_level=0, position=position) if (ie_f > is_f .and. je_f > js_f) then allocate(nest_dat (is_f:ie_f, js_f:je_f,npz)) else @@ -1950,7 +1950,7 @@ subroutine update_coarse_grid_mpp(var_coarse, var_nest, nest_domain, ind_update, endif call timing_on('COMM_TOTAL') - call mpp_update_nest_coarse(var_nest_send, nest_domain, nest_dat, position=position) + call mpp_update_nest_coarse(var_nest_send, nest_domain, nest_dat, nest_level=0, position=position) call timing_off('COMM_TOTAL') s = r/2 !rounds down (since r > 0) diff --git a/model/fv_control.F90 b/model/fv_control.F90 index 4d94e6364..c0d2f1a3d 100644 --- a/model/fv_control.F90 +++ b/model/fv_control.F90 @@ -89,7 +89,7 @@ module fv_control_mod ! mpp_send, mpp_sync, mpp_transmit, mpp_set_current_pelist, mpp_declare_pelist, ! mpp_root_pe, mpp_recv, mpp_sync_self, mpp_broadcast, read_input_nml, ! FATAL, mpp_error, mpp_pe, stdlog, mpp_npes, mpp_get_current_pelist, -! input_nml_file, get_unit, WARNING, read_ascii_file, INPUT_STR_LENGTH +! input_nml_file, get_unit, WARNING, read_ascii_file ! ! ! mpp_domains_mod @@ -121,7 +121,7 @@ module fv_control_mod use mpp_mod, only: FATAL, mpp_error, mpp_pe, stdlog, & mpp_npes, mpp_get_current_pelist, & input_nml_file, get_unit, WARNING, & - read_ascii_file, INPUT_STR_LENGTH + read_ascii_file use mpp_domains_mod, only: mpp_get_data_domain, mpp_get_compute_domain use tracer_manager_mod, only: tm_get_number_tracers => get_number_tracers, & tm_get_tracer_index => get_tracer_index, & @@ -970,18 +970,18 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) !Pelist needs to be set to ALL (which should have been done !in broadcast_domains) to get this to work - call mpp_define_nest_domains(Atm(n)%neststruct%nest_domain, Atm(n)%domain, Atm(parent_grid_num)%domain, & - 7, parent_tile, & - 1, npx-1, 1, npy-1, & !Grid cells, not points - ioffset, ioffset + (npx-1)/refinement - 1, & - joffset, joffset + (npy-1)/refinement - 1, & - (/ (i,i=0,mpp_npes()-1) /), extra_halo = 0, name="nest_domain") !What pelist to use? - call mpp_define_nest_domains(Atm(n)%neststruct%nest_domain, Atm(n)%domain, Atm(parent_grid_num)%domain, & - 7, parent_tile, & - 1, npx-1, 1, npy-1, & !Grid cells, not points - ioffset, ioffset + (npx-1)/refinement - 1, & - joffset, joffset + (npy-1)/refinement - 1, & - (/ (i,i=0,mpp_npes()-1) /), extra_halo = 0, name="nest_domain") !What pelist to use? + !call mpp_define_nest_domains(Atm(n)%neststruct%nest_domain, Atm(n)%domain, Atm(parent_grid_num)%domain, & + !7, parent_tile, & + !1, npx-1, 1, npy-1, & !Grid cells, not points + !ioffset, ioffset + (npx-1)/refinement - 1, & + !joffset, joffset + (npy-1)/refinement - 1, & + !(/ (i,i=0,mpp_npes()-1) /), extra_halo = 0, name="nest_domain") !What pelist to use? + !call mpp_define_nest_domains(Atm(n)%neststruct%nest_domain, Atm(n)%domain, Atm(parent_grid_num)%domain, & + !7, parent_tile, & + !1, npx-1, 1, npy-1, & !Grid cells, not points + !ioffset, ioffset + (npx-1)/refinement - 1, & + !joffset, joffset + (npy-1)/refinement - 1, & + !(/ (i,i=0,mpp_npes()-1) /), extra_halo = 0, name="nest_domain") !What pelist to use? ! (/ (i,i=0,mpp_npes()-1) /), extra_halo = 2, name="nest_domain_for_BC") !What pelist to use? Atm(parent_grid_num)%neststruct%child_grids(n) = .true. diff --git a/model/mapz-driver/CMakeLists.txt b/model/mapz-driver/CMakeLists.txt index 3aced14f5..246e36661 100644 --- a/model/mapz-driver/CMakeLists.txt +++ b/model/mapz-driver/CMakeLists.txt @@ -23,11 +23,11 @@ set(srcs main.F90) if (FV_PRECISION STREQUAL R4) - set(FMS fms_r4) + set(FMS FMS::FMS) elseif (FV_PRECISION STREQUAL R4R8) # FV is R4 but FMS is R8 - set(FMS fms_r8) + set(FMS FMS::FMS) elseif (FV_PRECISION STREQUAL R8) - set(FMS fms_r8) + set(FMS FMS::FMS) endif () ecbuild_add_executable( diff --git a/tools/fv_diagnostics.F90 b/tools/fv_diagnostics.F90 index a4d92f69e..c22b93d2d 100644 --- a/tools/fv_diagnostics.F90 +++ b/tools/fv_diagnostics.F90 @@ -51,7 +51,7 @@ module fv_diagnostics_mod ! ! ! fms_io_mod -! set_domain, nullify_domain, write_version_number +! set_domain, nullify_domain ! ! ! fv_arrays_mod @@ -119,7 +119,7 @@ module fv_diagnostics_mod use constants_mod, only: grav, rdgas, rvgas, pi=>pi_8, radius, kappa, WTMAIR, WTMCO2, & omega, hlv, cp_air, cp_vapor use fms_mod, only: write_version_number - use fms_io_mod, only: set_domain, nullify_domain, write_version_number + use fms_io_mod, only: set_domain, nullify_domain use time_manager_mod, only: time_type, get_date, get_time use mpp_domains_mod, only: domain2d, mpp_update_domains, DGRID_NE use diag_manager_mod, only: diag_axis_init, register_diag_field, & diff --git a/tools/fv_mp_mod.F90 b/tools/fv_mp_mod.F90 index 10da29b7d..2f0b9c100 100644 --- a/tools/fv_mp_mod.F90 +++ b/tools/fv_mp_mod.F90 @@ -46,7 +46,7 @@ module fv_mp_mod ! ! mpp_mod ! FATAL, MPP_DEBUG, NOTE, MPP_CLOCK_SYNC,MPP_CLOCK_DETAILED, WARNING, -! mpp_pe, mpp_npes, mpp_node, mpp_root_pe, mpp_error, mpp_set_warn_level, +! mpp_pe, mpp_npes, mpp_root_pe, mpp_error, mpp_set_warn_level, ! mpp_declare_pelist, mpp_set_current_pelist, mpp_sync, mpp_clock_begin, ! mpp_clock_end, mpp_clock_id,mpp_chksum, stdout, stderr, mpp_broadcast, ! mpp_send, mpp_recv, mpp_sync_self, EVENT_RECV, mpp_gather,mpp_get_current_pelist, @@ -72,7 +72,7 @@ module fv_mp_mod ! !USES: use fms_mod, only : fms_init, fms_end use mpp_mod, only : FATAL, MPP_DEBUG, NOTE, MPP_CLOCK_SYNC,MPP_CLOCK_DETAILED, WARNING - use mpp_mod, only : mpp_pe, mpp_npes, mpp_node, mpp_root_pe, mpp_error, mpp_set_warn_level + use mpp_mod, only : mpp_pe, mpp_npes, mpp_root_pe, mpp_error, mpp_set_warn_level use mpp_mod, only : mpp_declare_pelist, mpp_set_current_pelist, mpp_sync use mpp_mod, only : mpp_clock_begin, mpp_clock_end, mpp_clock_id use mpp_mod, only : mpp_chksum, stdout, stderr, mpp_broadcast From e2f2887377006a44ff6ffe2b99481c30e3d14fd3 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 1 Sep 2021 16:49:28 -0400 Subject: [PATCH 2/4] Updates to use CMake built FMS and mom6 dev/gfdl --- CMakeLists.txt | 22 +++++++++++----------- model/mapz-driver/CMakeLists.txt | 6 +++--- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 835ae5996..bcc6b5ec1 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -60,23 +60,23 @@ else () INCLUDES ${INC_ESMF}) endif () -#if (FV_PRECISION STREQUAL R4) -#elseif (FV_PRECISION STREQUAL R4R8) # FV is R4 but FMS is R8 - #get_target_property (extra_incs fms_r4 INCLUDE_DIRECTORIES) - #target_include_directories(${this} PRIVATE - #$ - #) -#elseif (FV_PRECISION STREQUAL R8) -#endif () +if (FV_PRECISION STREQUAL R4) +elseif (FV_PRECISION STREQUAL R4R8) # FV is R4 but FMS is R8 + get_target_property (extra_incs FMS::fms_r4 INCLUDE_DIRECTORIES) + target_include_directories(${this} PRIVATE + $ + ) +elseif (FV_PRECISION STREQUAL R8) +endif () if (FV_PRECISION STREQUAL R4) target_compile_definitions (${this} PRIVATE -DSINGLE_FV -DOVERLOAD_R4) - target_link_libraries (${this} PUBLIC FMS::FMS) + target_link_libraries (${this} PUBLIC FMS::fms_r4) elseif (FV_PRECISION STREQUAL R4R8) # FV is R4 but FMS is R8 target_compile_definitions (${this} PRIVATE -DSINGLE_FV -DOVERLOAD_R4) - target_link_libraries (${this} PUBLIC FMS::FMS) + target_link_libraries (${this} PUBLIC FMS::fms_r8) elseif (FV_PRECISION STREQUAL R8) - target_link_libraries (${this} PUBLIC FMS::FMS) + target_link_libraries (${this} PUBLIC FMS::fms_r8) string(REPLACE " " ";" tmp ${FREAL8}) foreach(flag ${tmp}) target_compile_options (${this} PRIVATE $<$:${flag}>) diff --git a/model/mapz-driver/CMakeLists.txt b/model/mapz-driver/CMakeLists.txt index 246e36661..0c029127a 100644 --- a/model/mapz-driver/CMakeLists.txt +++ b/model/mapz-driver/CMakeLists.txt @@ -23,11 +23,11 @@ set(srcs main.F90) if (FV_PRECISION STREQUAL R4) - set(FMS FMS::FMS) + set(FMS FMS::fms_r4) elseif (FV_PRECISION STREQUAL R4R8) # FV is R4 but FMS is R8 - set(FMS FMS::FMS) + set(FMS FMS::fms_r8) elseif (FV_PRECISION STREQUAL R8) - set(FMS FMS::FMS) + set(FMS FMS::fms_r8) endif () ecbuild_add_executable( From e270da3f8dc4415fdb9023950a29076d0ef744d6 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 25 Jan 2022 10:02:58 -0500 Subject: [PATCH 3/4] Updates for fms build --- CMakeLists.txt | 8 ++++---- model/mapz-driver/CMakeLists.txt | 6 +++--- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index bcc6b5ec1..26e2a07df 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -62,7 +62,7 @@ endif () if (FV_PRECISION STREQUAL R4) elseif (FV_PRECISION STREQUAL R4R8) # FV is R4 but FMS is R8 - get_target_property (extra_incs FMS::fms_r4 INCLUDE_DIRECTORIES) + get_target_property (extra_incs fms_r4 INCLUDE_DIRECTORIES) target_include_directories(${this} PRIVATE $ ) @@ -71,12 +71,12 @@ endif () if (FV_PRECISION STREQUAL R4) target_compile_definitions (${this} PRIVATE -DSINGLE_FV -DOVERLOAD_R4) - target_link_libraries (${this} PUBLIC FMS::fms_r4) + target_link_libraries (${this} PUBLIC fms_r4) elseif (FV_PRECISION STREQUAL R4R8) # FV is R4 but FMS is R8 target_compile_definitions (${this} PRIVATE -DSINGLE_FV -DOVERLOAD_R4) - target_link_libraries (${this} PUBLIC FMS::fms_r8) + target_link_libraries (${this} PUBLIC fms_r8) elseif (FV_PRECISION STREQUAL R8) - target_link_libraries (${this} PUBLIC FMS::fms_r8) + target_link_libraries (${this} PUBLIC fms_r8) string(REPLACE " " ";" tmp ${FREAL8}) foreach(flag ${tmp}) target_compile_options (${this} PRIVATE $<$:${flag}>) diff --git a/model/mapz-driver/CMakeLists.txt b/model/mapz-driver/CMakeLists.txt index 0c029127a..40f1efc4a 100644 --- a/model/mapz-driver/CMakeLists.txt +++ b/model/mapz-driver/CMakeLists.txt @@ -23,11 +23,11 @@ set(srcs main.F90) if (FV_PRECISION STREQUAL R4) - set(FMS FMS::fms_r4) + set(FMS fms_r4) elseif (FV_PRECISION STREQUAL R4R8) # FV is R4 but FMS is R8 - set(FMS FMS::fms_r8) + set(FMS fms_r8) elseif (FV_PRECISION STREQUAL R8) - set(FMS FMS::fms_r8) + set(FMS fms_r8) endif () ecbuild_add_executable( From b1743174e9e99d0c30dd4b0c5191d19dfb493edd Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 6 Dec 2023 08:16:18 -0500 Subject: [PATCH 4/4] in FMS 2023.04, sst_ncep is now r8 which conflicts with a pmaxmin call --- tools/fv_nudge.F90 | 291 +++++++++++++++++++++++---------------------- 1 file changed, 146 insertions(+), 145 deletions(-) diff --git a/tools/fv_nudge.F90 b/tools/fv_nudge.F90 index fcbac9121..8e15a065d 100644 --- a/tools/fv_nudge.F90 +++ b/tools/fv_nudge.F90 @@ -1,21 +1,21 @@ !*********************************************************************** -!* GNU Lesser General Public License +!* GNU Lesser General Public License !* !* This file is part of the FV3 dynamical core. !* -!* The FV3 dynamical core is free software: you can redistribute it +!* The FV3 dynamical core is free software: you can redistribute it !* and/or modify it under the terms of the !* GNU Lesser General Public License as published by the -!* Free Software Foundation, either version 3 of the License, or +!* Free Software Foundation, either version 3 of the License, or !* (at your option) any later version. !* -!* The FV3 dynamical core is distributed in the hope that it will be -!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty -!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANYWARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. !* See the GNU General Public License for more details. !* !* You should have received a copy of the GNU Lesser General Public -!* License along with the FV3 dynamical core. +!* License along with the FV3 dynamical core. !* If not, see . !*********************************************************************** #ifdef OVERLOAD_R4 @@ -49,7 +49,7 @@ module fv_nwp_nudge_mod ! ! ! fms_mod -! write_version_number, open_namelist_file, check_nml_error, +! write_version_number, open_namelist_file, check_nml_error, ! file_exist, close_file ! ! @@ -83,7 +83,7 @@ module fv_nwp_nudge_mod ! ! ! sim_nc_mod -! open_ncfile, close_ncfile, get_ncdim1, get_var1_double, +! open_ncfile, close_ncfile, get_ncdim1, get_var1_double, ! get_var3_r4, get_var1_real ! ! @@ -148,7 +148,7 @@ module fv_nwp_nudge_mod real :: time_nudge = 0. integer :: time_interval = 6*3600 !< dataset time interval (seconds) ! ---> h1g, enhance the max. analysis data files, 2012-10-22 -! integer, parameter :: nfile_max = 125 +! integer, parameter :: nfile_max = 125 integer, parameter :: nfile_max = 29280 !< maximum: 20-year analysis data, 4*366*20=29280 ! <--- h1g, 2012-10-22 integer :: nfile @@ -170,20 +170,20 @@ module fv_nwp_nudge_mod ! ---> h1g, add the list of input NCEP analysis data files, 2012-10-22 character(len=128):: input_fname_list ="" !< a file lists the input NCEP analysis data character(len=128):: analysis_file_first ="" !< the first NCEP analysis file to be used for nudging, - !! by default, the first file in the "input_fname_list" - character(len=128):: analysis_file_last="" !< the last NCEP analysis file to be used for nudging + !! by default, the first file in the "input_fname_list" + character(len=128):: analysis_file_last="" !< the last NCEP analysis file to be used for nudging !! by default, the last file in the "input_fname_list" - real :: P_relax = 30.E2 !< from P_relax upwards, nudging is reduced linearly + real :: P_relax = 30.E2 !< from P_relax upwards, nudging is reduced linearly !! proportional to pfull/P_relax - real :: P_norelax = 0.0 !< from P_norelax upwards, no nudging + real :: P_norelax = 0.0 !< from P_norelax upwards, no nudging ! <--- h1g, 2012-10-22 character(len=128):: file_names(nfile_max) character(len=128):: track_file_name integer :: nfile_total = 0 !< =5 for 1-day (if datasets are 6-hr apart) - real :: p_wvp = 100.E2 !< cutoff level for specific humidity nudging + real :: p_wvp = 100.E2 !< cutoff level for specific humidity nudging integer :: kord_data = 8 real :: mask_fac = 0.25 !< [0,1] 0: no mask; 1: full strength @@ -195,8 +195,8 @@ module fv_nwp_nudge_mod logical :: conserve_mom = .true. logical :: conserve_hgt = .true. logical :: tc_mask = .false. - logical :: strong_mask = .false. - logical :: ibtrack = .true. + logical :: strong_mask = .false. + logical :: ibtrack = .true. logical :: nudge_debug = .false. logical :: do_ps_bias = .false. logical :: nudge_ps = .false. @@ -208,30 +208,30 @@ module fv_nwp_nudge_mod logical :: print_end_breed = .true. logical :: print_end_nudge = .true. -!Nudging time-scales (seconds): +!Nudging time-scales (seconds): !note, however, the effective time-scale is 2X smaller (stronger) due ! to the use of the time-varying weighting factor real :: tau_ps = 21600. !< 1-day real :: tau_q = 86400. !< 1-day real :: tau_winds = 21600. !< 6-hr - real :: tau_virt = 43200. + real :: tau_virt = 43200. real :: tau_hght = 43200. real :: q_min = 1.E-8 integer :: jbeg, jend - integer :: nf_uv = 0 - integer :: nf_ps = 0 - integer :: nf_t = 2 - integer :: nf_ht = 1 + integer :: nf_uv = 0 + integer :: nf_ps = 0 + integer :: nf_t = 2 + integer :: nf_ht = 1 ! starting layer (top layer is sponge layer and is skipped) - integer :: kstart = 2 + integer :: kstart = 2 ! skip "kbot" layers - integer :: kbot_winds = 0 - integer :: kbot_t = 0 - integer :: kbot_q = 0 + integer :: kbot_winds = 0 + integer :: kbot_t = 0 + integer :: kbot_q = 0 logical :: analysis_time !-- Tropical cyclones -------------------------------------------------------------------- @@ -242,7 +242,7 @@ module fv_nwp_nudge_mod real :: grid_size = 28.E3 real :: tau_vt_slp = 1200. real :: tau_vt_wind = 1200. - real :: tau_vt_rad = 4.0 + real :: tau_vt_rad = 4.0 real :: pt_lim = 0.2 real :: slp_env = 101010. !< storm environment pressure (pa) @@ -257,7 +257,7 @@ module fv_nwp_nudge_mod real :: r_inc = 25.E3 real, parameter:: del_r = 50.E3 real:: elapsed_time = 0.0 - real:: nudged_time = 1.E12 !< seconds + real:: nudged_time = 1.E12 !< seconds ! usage example: set to 43200. to do inline vortex breeding ! for only the first 12 hours ! In addition, specify only 3 analysis files (12 hours) @@ -290,10 +290,10 @@ module fv_nwp_nudge_mod kbot_t, kbot_q, p_wvp, time_varying, time_interval, use_pt_inc, pt_lim, & tau_vt_rad, r_lo, r_hi, use_high_top, add_bg_wind, conserve_mom, conserve_hgt, & min_nobs, min_mslp, nudged_time, r_fac, r_min, r_inc, ibtrack, track_file_name, file_names, & - input_fname_list, analysis_file_first, analysis_file_last, P_relax, P_norelax !h1g, add 3 namelist variables, 2012-20-22 + input_fname_list, analysis_file_first, analysis_file_last, P_relax, P_norelax !h1g, add 3 namelist variables, 2012-20-22 contains - + !>@brief Ths subroutine 'fv_nwp_nudge' computes and returns time tendencies for nudging to analysis. !>@details This nudging is typically applied to fv_update_phys. subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt, zvir, ptop, & @@ -347,14 +347,14 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt real, pointer, dimension(:,:) :: sina_u, sina_v real, pointer, dimension(:,:,:) :: sin_sg real(kind=R_GRID), pointer, dimension(:,:,:) :: vlon, vlat - + real, pointer, dimension(:,:) :: dx, dy, rdxc, rdyc real(kind=R_GRID), pointer :: da_min logical, pointer :: nested, sw_corner, se_corner, nw_corner, ne_corner - if ( .not. module_is_initialized ) then + if ( .not. module_is_initialized ) then call mpp_error(FATAL,'==> Error from fv_nwp_nudge: module not initialized') endif agrid => gridstruct%agrid_64 @@ -379,7 +379,7 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt se_corner => gridstruct%se_corner nw_corner => gridstruct%nw_corner ne_corner => gridstruct%ne_corner - + if ( no_obs ) then #ifndef DYCORE_SOLO forecast_mode = .true. @@ -405,7 +405,7 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt do k=1,npz press(k) = 0.5*(ak(k) + ak(k+1)) + 0.5*(bk(k)+bk(k+1))*1.E5 if ( press(k) < P_relax ) then - profile(k) = max(0.01, press(k)/P_relax) + profile(k) = max(0.01, press(k)/P_relax) endif ! above P_norelax, no nudging. added by h1g @@ -418,17 +418,17 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt !$OMP parallel do default(none) shared(npz,press,prof_t) do k=1,npz if ( press(k) < 10.E2 ) then - prof_t(k) = max(0.01, press(k)/10.E2) + prof_t(k) = max(0.01, press(k)/10.E2) endif enddo prof_t(1) = 0. - + ! Water vapor: prof_q(:) = 1. !$OMP parallel do default(none) shared(npz,press,prof_q) do k=1,npz if ( press(k) < 300.E2 ) then - prof_q(k) = max(0., press(k)/300.E2) + prof_q(k) = max(0., press(k)/300.E2) endif enddo prof_q(1) = 0. @@ -440,7 +440,7 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt ptmp = ak(k+1) + bk(k+1)*1.E5 if ( ptmp > p_trop ) then k_trop = k - exit + exit endif enddo endif @@ -490,7 +490,7 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt do j=js,je do i=is,ie - if ( abs(ps(i,j)-ps_obs(i,j)) > 2.e2 ) then + if ( abs(ps(i,j)-ps_obs(i,j)) > 2.e2 ) then ps_fac(i,j) = 2.e2 / abs(ps(i,j)-ps_obs(i,j)) else ps_fac(i,j) = 1. @@ -500,7 +500,7 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt if( analysis_time ) then !------------------------------------------- -! Compute RMSE, bias, and correlation of SLP +! Compute RMSE, bias, and correlation of SLP !------------------------------------------- do j=js,je do i=is,ie @@ -529,7 +529,7 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt endif enddo enddo - + call rmse_bias(m_err, rms, bias, area) call corr(slp_m, slp_n, co, area) @@ -736,8 +736,8 @@ subroutine fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt nullify(area) nullify(rarea) - nullify(vlon) - nullify(vlat) + nullify(vlon) + nullify(vlat) nullify(sina_u) nullify(sina_v) nullify(sin_sg) @@ -867,7 +867,7 @@ subroutine ps_nudging(dt, factor, npz, ak, bk, ps_obs, mask, tm, ps, phis, delp, ps(i,j) = ak(1) enddo enddo - + rdt = dt / (tau_ps/factor + dt) do k=1,npz dbk = rdt*(bk(k+1) - bk(k)) @@ -939,14 +939,14 @@ subroutine ps_bias_correction ( ps_dt, is, ie, js, je, isd, ied, jsd, jed, area if(master .and. nudge_debug) write(*,*) 'Significant PS bias=', -bias endif - if ( bias > 0. ) then + if ( bias > 0. ) then psum = 0. do j=js,je do i=is,ie if ( ps_dt(i,j) > 0. ) then psum = psum + area(i,j) endif - enddo + enddo enddo call mp_reduce_sum( psum ) @@ -957,7 +957,7 @@ subroutine ps_bias_correction ( ps_dt, is, ie, js, je, isd, ied, jsd, jed, area if ( ps_dt(i,j) > 0.0 ) then ps_dt(i,j) = max(0.0, ps_dt(i,j) - bias) endif - enddo + enddo enddo else psum = 0. @@ -966,18 +966,18 @@ subroutine ps_bias_correction ( ps_dt, is, ie, js, je, isd, ied, jsd, jed, area if ( ps_dt(i,j) < 0. ) then psum = psum + area(i,j) endif - enddo + enddo enddo call mp_reduce_sum( psum ) - bias = bias * total_area / psum + bias = bias * total_area / psum do j=js,je do i=is,ie if ( ps_dt(i,j) < 0.0 ) then ps_dt(i,j) = min(0.0, ps_dt(i,j) - bias) endif - enddo + enddo enddo endif @@ -1128,12 +1128,12 @@ subroutine get_obs(Time, dt, zvir, ak, bk, ps, ts, ps_obs, delp, pt, nwat, q, u_ ps_obs(:,:) = alpha*ps_dat(:,:,1) + beta*ps_dat(:,:,2) !--------------------------------- -!*** nudge & update ps & delp here +!*** nudge & update ps & delp here !--------------------------------- if (nudge_ps) then allocate ( wt(is:ie,js:je,km) ) - wt(:,:,:) = alpha*t_dat(:,:,:,1) + beta*t_dat(:,:,:,2) + wt(:,:,:) = alpha*t_dat(:,:,:,1) + beta*t_dat(:,:,:,2) ! Needs gz3 for ps_nudging call get_int_hght(npz, ak, bk, ps(is:ie,js:je), delp, ps_obs(is:ie,js:je), wt) do j=js,je @@ -1141,7 +1141,7 @@ subroutine get_obs(Time, dt, zvir, ak, bk, ps, ts, ps_obs, delp, pt, nwat, q, u_ tm(i,j) = wt(i,j,km) enddo enddo - deallocate ( wt ) + deallocate ( wt ) allocate ( uu(isd:ied,jsd:jed,npz) ) allocate ( vv(isd:ied,jsd:jed,npz) ) @@ -1151,13 +1151,13 @@ subroutine get_obs(Time, dt, zvir, ak, bk, ps, ts, ps_obs, delp, pt, nwat, q, u_ do k=1,npz do j=js,je do i=is,ie - u_dt(i,j,k) = u_dt(i,j,k) + (uu(i,j,k) - ua(i,j,k)) / dt - v_dt(i,j,k) = v_dt(i,j,k) + (vv(i,j,k) - va(i,j,k)) / dt + u_dt(i,j,k) = u_dt(i,j,k) + (uu(i,j,k) - ua(i,j,k)) / dt + v_dt(i,j,k) = v_dt(i,j,k) + (vv(i,j,k) - va(i,j,k)) / dt enddo enddo enddo - deallocate (uu ) - deallocate (vv ) + deallocate (uu ) + deallocate (vv ) endif allocate ( ut(is:ie,js:je,npz) ) @@ -1190,8 +1190,8 @@ subroutine get_obs(Time, dt, zvir, ak, bk, ps, ts, ps_obs, delp, pt, nwat, q, u_ t_obs(:,:,:) = t_obs(:,:,:) + beta*ut(:,:,:) q_obs(:,:,:) = q_obs(:,:,:) + beta*vt(:,:,:) - deallocate ( ut ) - deallocate ( vt ) + deallocate ( ut ) + deallocate ( vt ) end subroutine get_obs @@ -1201,7 +1201,7 @@ subroutine fv_nwp_nudge_init(time, axes, npz, zvir, ak, bk, ts, phis, gridstruct character(len=17) :: mod_name = 'fv_nudge' type(time_type), intent(in):: time integer, intent(in):: axes(4) - integer, intent(in):: npz !< vertical dimension + integer, intent(in):: npz !< vertical dimension real, intent(in):: zvir type(fv_grid_bounds_type), intent(IN) :: bd real, intent(in), dimension(bd%isd:bd%ied,bd%jsd:bd%jed):: phis @@ -1228,7 +1228,7 @@ subroutine fv_nwp_nudge_init(time, axes, npz, zvir, ak, bk, ts, phis, gridstruct ie = bd%ie js = bd%js je = bd%je - + isd = bd%isd ied = bd%ied jsd = bd%jsd @@ -1236,7 +1236,7 @@ subroutine fv_nwp_nudge_init(time, axes, npz, zvir, ak, bk, ts, phis, gridstruct agrid => gridstruct%agrid - + master = is_master() do_adiabatic_init = .false. deg2rad = pi/180. @@ -1279,23 +1279,23 @@ subroutine fv_nwp_nudge_init(time, axes, npz, zvir, ak, bk, ts, phis, gridstruct do while ( io .eq. 0 ) read ( input_fname_unit, '(a)', iostat = io, end = 101 ) fname_tmp - if( trim(fname_tmp) .ne. "" ) then ! escape any empty record + if( trim(fname_tmp) .ne. "" ) then ! escape any empty record if ( trim(fname_tmp) == trim(analysis_file_last) ) then nt = nt + 1 file_names(nt) = 'INPUT/'//trim(fname_tmp) if(master .and. nudge_debug) write(*,*) 'From NCEP file list, last file: ', nt, file_names(nt) nt = 0 goto 101 ! read last analysis data and then close file - endif ! trim(fname_tmp) == trim(analysis_file_last) + endif ! trim(fname_tmp) == trim(analysis_file_last) if ( trim(analysis_file_first) == "" ) then nt = nt + 1 - file_names(nt) = 'INPUT/'//trim(fname_tmp) + file_names(nt) = 'INPUT/'//trim(fname_tmp) if(master .and. nudge_debug) then - if( nt .eq. 1 ) then - write(*,*) 'From NCEP file list, first file: ', nt, file_names(nt),trim(analysis_file_first) + if( nt .eq. 1 ) then + write(*,*) 'From NCEP file list, first file: ', nt, file_names(nt),trim(analysis_file_first) else - write(*,*) 'From NCEP file list: ', nt, file_names(nt) + write(*,*) 'From NCEP file list: ', nt, file_names(nt) endif ! nt .eq. 1 endif ! master .and. nudge_debug else @@ -1303,15 +1303,15 @@ subroutine fv_nwp_nudge_init(time, axes, npz, zvir, ak, bk, ts, phis, gridstruct nt = nt + 1 file_names(nt) = 'INPUT/'//trim(fname_tmp) if(master .and. nudge_debug) then - if( nt .eq. 1 ) then - write(*,*) 'From NCEP file list, first file: ', nt, file_names(nt),trim(analysis_file_first) + if( nt .eq. 1 ) then + write(*,*) 'From NCEP file list, first file: ', nt, file_names(nt),trim(analysis_file_first) else - write(*,*) 'From NCEP file list: ', nt, file_names(nt) + write(*,*) 'From NCEP file list: ', nt, file_names(nt) endif ! nt .eq. 1 endif ! master .and. nudge_debug - endif ! trim(fname_tmp) == trim(analysis_file_first) .or. nt > 0 - endif ! trim(analysis_file_first) == "" - endif ! trim(fname_tmp) .ne. "" + endif ! trim(fname_tmp) == trim(analysis_file_first) .or. nt > 0 + endif ! trim(analysis_file_first) == "" + endif ! trim(fname_tmp) .ne. "" end do ! io .eq. 0 101 close( input_fname_unit ) endif @@ -1362,7 +1362,7 @@ subroutine fv_nwp_nudge_init(time, axes, npz, zvir, ak, bk, ts, phis, gridstruct do j=1,jm lat(j) = lat(j) * deg2rad enddo - + allocate ( ak0(km+1) ) allocate ( bk0(km+1) ) @@ -1374,7 +1374,7 @@ subroutine fv_nwp_nudge_init(time, axes, npz, zvir, ak, bk, ts, phis, gridstruct ! Note: definition of NCEP hybrid is p(k) = a(k)*1.E5 + b(k)*ps ak0(:) = ak0(:) * 1.E5 -! Limiter to prevent NAN at top during remapping +! Limiter to prevent NAN at top during remapping if ( bk0(1) < 1.E-9 ) ak0(1) = max(1.e-9, ak0(1)) if ( master ) then @@ -1397,7 +1397,7 @@ subroutine fv_nwp_nudge_init(time, axes, npz, zvir, ak, bk, ts, phis, gridstruct do j=js,je do i=is,ie j1 = jdc(i,j) - jbeg = min(jbeg, j1) + jbeg = min(jbeg, j1) jend = max(jend, j1+1) enddo enddo @@ -1420,7 +1420,7 @@ subroutine fv_nwp_nudge_init(time, axes, npz, zvir, ak, bk, ts, phis, gridstruct module_is_initialized = .true. - + nullify(agrid) end subroutine fv_nwp_nudge_init @@ -1451,9 +1451,9 @@ subroutine get_ncep_analysis ( ps, u, v, t, q, zvir, ts, nfile, fname, bd ) call mpp_error(FATAL,'==> Error from get_ncep_analysis: file not found') else call open_ncfile( fname, ncid ) ! open the file - if(master) write(*,*) 'Reading NCEP anlysis file:', fname + if(master) write(*,*) 'Reading NCEP anlysis file:', fname endif - + if ( read_ts ) then ! read skin temperature; could be used for SST allocate ( wk1(im,jm) ) @@ -1463,7 +1463,7 @@ subroutine get_ncep_analysis ( ps, u, v, t, q, zvir, ts, nfile, fname, bd ) if ( .not. land_ts ) then allocate ( wk0(im,jm) ) ! Read NCEP ORO (1; land; 0: ocean; 2: sea_ice) - + ! ---> h1g, read either 'ORO' or 'LAND', 2016-08-10 status = nf_inq_varid (ncid, 'ORO', var3id) if (status .eq. NF_NOERR) then @@ -1472,12 +1472,12 @@ subroutine get_ncep_analysis ( ps, u, v, t, q, zvir, ts, nfile, fname, bd ) else !there is no 'ORO' status = nf_inq_varid (ncid, 'LAND', var3id) if (status .eq. NF_NOERR) then - call get_var3_r4( ncid, 'LAND', 1,im, 1,jm, 1,1, wk0 ) + call get_var3_r4( ncid, 'LAND', 1,im, 1,jm, 1,1, wk0 ) else - call mpp_error(FATAL,'Neither ORO nor LAND exists in re-analysis data') + call mpp_error(FATAL,'Neither ORO nor LAND exists in re-analysis data') endif - endif -! <--- h1g, 2016-08-10 + endif +! <--- h1g, 2016-08-10 do j=1,jm tmean = 0. @@ -1489,7 +1489,7 @@ subroutine get_ncep_analysis ( ps, u, v, t, q, zvir, ts, nfile, fname, bd ) endif enddo !------------------------------------------------------- -! Replace TS over interior land with zonal mean SST/Ice +! Replace TS over interior land with zonal mean SST/Ice !------------------------------------------------------- if ( npt /= 0 ) then tmean= tmean / real(npt) @@ -1513,7 +1513,7 @@ subroutine get_ncep_analysis ( ps, u, v, t, q, zvir, ts, nfile, fname, bd ) enddo endif enddo - deallocate ( wk0 ) + deallocate ( wk0 ) endif ! land_ts do j=js,je @@ -1530,10 +1530,11 @@ subroutine get_ncep_analysis ( ps, u, v, t, q, zvir, ts, nfile, fname, bd ) #ifndef DYCORE_SOLO ! Perform interp to FMS SST format/grid call ncep2fms( wk1 ) - if(master) call pmaxmin( 'SST_ncep', sst_ncep, i_sst, j_sst, 1.) + ! sst_ncep is now r8_kind in FMS but pmaxmin expects real + if(master) call pmaxmin( 'SST_ncep', real(sst_ncep), i_sst, j_sst, 1.) ! if(nfile/=1 .and. master) call pmaxmin( 'SST_anom', sst_anom, i_sst, j_sst, 1.) #endif - deallocate ( wk1 ) + deallocate ( wk1 ) if (master) write(*,*) 'Done processing NCEP SST' endif ! read_ts @@ -1567,10 +1568,10 @@ subroutine get_ncep_analysis ( ps, u, v, t, q, zvir, ts, nfile, fname, bd ) call get_var3_r4( ncid, 'PHI', 1,im, jbeg,jend, 1,1, wk2 ) wk2 = wk2 * grav ! convert unit from geopotential meter (m) to geopotential height (m2/s2) else - call mpp_error(FATAL,'Neither PHIS nor PHI exists in re-analysis data') + call mpp_error(FATAL,'Neither PHIS nor PHI exists in re-analysis data') endif - endif -! <--- h1g, 2016-08-10 + endif +! <--- h1g, 2016-08-10 do j=js,je @@ -1666,7 +1667,7 @@ subroutine get_ncep_analysis ( ps, u, v, t, q, zvir, ts, nfile, fname, bd ) ! endif - deallocate ( wk3 ) + deallocate ( wk3 ) ! nfile = nfile + 1 @@ -1773,8 +1774,8 @@ subroutine ncep2fms( sst ) ! lon: 0.5, 1.5, ..., 359.5 ! lat: -89.5, -88.5, ... , 88.5, 89.5 - delx = 360./real(i_sst) - dely = 180./real(j_sst) + delx = 360./real(i_sst) + dely = 180./real(j_sst) jt = 1 do 5000 j=1,j_sst @@ -1853,7 +1854,7 @@ subroutine get_int_hght(npz, ak, bk, ps, delp, ps0, tv) do i=is,ie pn0(i,k) = log( ak0(k) + bk0(k)*ps0(i,j) ) enddo - enddo + enddo do i=is,ie gz3(i,j,km+1) = gz0(i,j) ! Data Surface geopotential enddo @@ -1897,7 +1898,7 @@ subroutine remap_tq( npz, ak, bk, ps, delp, t, q, & pe0(i,k) = ak0(k) + bk0(k)*ps0(i,j) pn0(i,k) = log(pe0(i,k)) enddo - enddo + enddo !------ ! Model !------ @@ -2042,11 +2043,11 @@ subroutine fv_nwp_nudge_end deallocate ( ak0 ) deallocate ( bk0 ) - deallocate ( lat ) - deallocate ( lon ) + deallocate ( lat ) + deallocate ( lon ) - deallocate ( gz3 ) - deallocate ( gz0 ) + deallocate ( gz3 ) + deallocate ( gz0 ) end subroutine fv_nwp_nudge_end @@ -2081,7 +2082,7 @@ subroutine get_tc_mask(time, mask, agrid) do j=js, je do i=is, ie dist = great_circle_dist(pos, agrid(i,j,1:2), radius) - if( dist < 6.*r_vor ) then + if( dist < 6.*r_vor ) then mask(i,j) = mask(i,j) * ( 1. - mask_fac*exp(-(0.5*dist/r_vor)**2)*min(1.,(slp_env-slp_o)/10.E2) ) endif enddo ! i-loop @@ -2115,7 +2116,7 @@ subroutine breed_slp_inline(nstep, dt, npz, ak, bk, phis, pe, pk, peln, pkz, del real, intent(inout):: pk(is:ie,js:je, npz+1) !< pe**kappa real, intent(inout):: pe(is-1:ie+1, npz+1,js-1:je+1) !< edge pressure (pascal) - real, intent(inout):: pkz(is:ie,js:je,npz) + real, intent(inout):: pkz(is:ie,js:je,npz) real, intent(out):: peln(is:ie,npz+1,js:je) !< ln(pe) type(fv_grid_type), target :: gridstruct @@ -2155,7 +2156,7 @@ subroutine breed_slp_inline(nstep, dt, npz, ak, bk, phis, pe, pk, peln, pkz, del ! Advance (local) time call get_date(fv_time, year, month, day, hour, minute, second) if ( year /= year_track_data ) then - if (master) write(*,*) 'Warning: The year in storm track data is not the same as model year' + if (master) write(*,*) 'Warning: The year in storm track data is not the same as model year' return endif time = fv_time ! fv_time is the time at past time step (set in fv_diag) @@ -2271,7 +2272,7 @@ subroutine breed_slp_inline(nstep, dt, npz, ak, bk, phis, pe, pk, peln, pkz, del else ! Lower top for vrotex breeding if ( slp_o > 1000.E2 ) then - pbtop = 900.E2 + pbtop = 900.E2 else pbtop = max(500.E2, 900.E2-5.*(1000.E2-slp_o)) ! mp48 endif @@ -2305,10 +2306,10 @@ subroutine breed_slp_inline(nstep, dt, npz, ak, bk, phis, pe, pk, peln, pkz, del a_sum = 0. do j=js, je do i=is, ie - if( dist(i,j)<(r_vor+del_r) .and. dist(i,j)>r_vor .and. phis(i,j)<250.*grav ) then + if( dist(i,j)<(r_vor+del_r) .and. dist(i,j)>r_vor .and. phis(i,j)<250.*grav ) then p_count = p_count + 1. - p_sum = p_sum + slp(i,j)*area(i,j) - a_sum = a_sum + area(i,j) + p_sum = p_sum + slp(i,j)*area(i,j) + a_sum = a_sum + area(i,j) endif enddo enddo @@ -2380,7 +2381,7 @@ subroutine breed_slp_inline(nstep, dt, npz, ak, bk, phis, pe, pk, peln, pkz, del p_hi = p_env - (p_env-slp_o) * exp( -r_hi*f1**2 ) ! upper bound p_lo = p_env - (p_env-slp_o) * exp( -r_lo*f1**2 ) ! lower bound - if ( ps(i,j) > p_hi .and. tm(i,j) < tm_max ) then + if ( ps(i,j) > p_hi .and. tm(i,j) < tm_max ) then ! do nothing if lowest layer is too hot ! Under-development: relx = relx0*exp( -tau_vt_rad*f1**2 ) @@ -2397,7 +2398,7 @@ subroutine breed_slp_inline(nstep, dt, npz, ak, bk, phis, pe, pk, peln, pkz, del delps = relx*(slp(i,j) - p_lo) ! Note: slp is used here else goto 400 ! do nothing; proceed to next storm - endif + endif #ifdef SIM_TEST pbreed = ak(1) @@ -2439,7 +2440,7 @@ subroutine breed_slp_inline(nstep, dt, npz, ak, bk, phis, pe, pk, peln, pkz, del #endif endif -400 continue +400 continue enddo ! end i-loop enddo ! end j-loop @@ -2453,7 +2454,7 @@ subroutine breed_slp_inline(nstep, dt, npz, ak, bk, phis, pe, pk, peln, pkz, del do j=js, je do i=is, ie if( dist(i,j)r2 ) then - p_sum = p_sum + area(i,j) + p_sum = p_sum + area(i,j) endif enddo enddo @@ -2565,7 +2566,7 @@ subroutine breed_slp_inline(nstep, dt, npz, ak, bk, phis, pe, pk, peln, pkz, del nullify(agrid) nullify(area) - + end subroutine breed_slp_inline !>@brief The subroutine 'breed_srf_w10' performs vortex breeding by nudging 10-m winds. @@ -2606,17 +2607,17 @@ subroutine breed_srf_w10(time, dt, npz, ak, bk, ps, phis, slp, delp, u, v, grids real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, vlon, vlat dx => gridstruct%dx - dy => gridstruct%dy - rdxa => gridstruct%rdxa - rdya => gridstruct%rdya - a11 => gridstruct%a11 - a21 => gridstruct%a21 - a12 => gridstruct%a12 - a22 => gridstruct%a22 - area => gridstruct%area + dy => gridstruct%dy + rdxa => gridstruct%rdxa + rdya => gridstruct%rdya + a11 => gridstruct%a11 + a21 => gridstruct%a21 + a12 => gridstruct%a12 + a22 => gridstruct%a22 + area => gridstruct%area agrid => gridstruct%agrid_64 - vlon => gridstruct%vlon - vlat => gridstruct%vlat + vlon => gridstruct%vlon + vlat => gridstruct%vlat if ( nstorms==0 ) then @@ -2673,7 +2674,7 @@ subroutine breed_srf_w10(time, dt, npz, ak, bk, ps, phis, slp, delp, u, v, grids time_tc(1,n), pos(1), pos(2), w10_o, slp_o, r_vor, p_env) if ( slp_o<90000. .or. slp_o>slp_env .or. abs(pos(2))*rad2deg>35. ) goto 3000 ! next storm - + do j=js, je do i=is, ie @@ -2728,7 +2729,7 @@ subroutine breed_srf_w10(time, dt, npz, ak, bk, ps, phis, slp, delp, u, v, grids if( r_max<0. ) call mpp_error(FATAL,'==> Error in r_max') ! --------------------------------------------------- -! Determine surface wind speed and radius for nudging +! Determine surface wind speed and radius for nudging ! --------------------------------------------------- ! Compute surface roughness z0 from w10, based on Eq (4) & (5) from Moon et al. 2007 @@ -2818,7 +2819,7 @@ subroutine breed_srf_w10(time, dt, npz, ak, bk, ps, phis, slp, delp, u, v, grids us(i,j) = relx*(ut-us(i,j)) vs(i,j) = relx*(vt-vs(i,j)) endif -400 continue +400 continue enddo ! end i-loop enddo ! end j-loop #else @@ -2839,7 +2840,7 @@ subroutine breed_srf_w10(time, dt, npz, ak, bk, ps, phis, slp, delp, u, v, grids us(i,j) = relx*(ut-us(i,j)) vs(i,j) = relx*(vt-vs(i,j)) endif -400 continue +400 continue enddo ! end i-loop enddo ! end j-loop #endif @@ -2920,7 +2921,7 @@ subroutine breed_srf_winds(time, dt, npz, u_obs, v_obs, ak, bk, ps, phis, delp, time_tc(1,n), pos(1), pos(2), w10_o, slp_o, r_vor, p_env) if ( slp_o<90000. .or. slp_o>slp_env .or. abs(pos(2))*rad2deg>35. ) goto 3000 ! next storm - + do j=js, je do i=is, ie @@ -2976,7 +2977,7 @@ subroutine breed_srf_winds(time, dt, npz, u_obs, v_obs, ak, bk, ps, phis, delp, if( r_max<0. ) call mpp_error(FATAL,'==> Error in r_max') ! --------------------------------------------------- -! Determine surface wind speed and radius for nudging +! Determine surface wind speed and radius for nudging ! --------------------------------------------------- ! Compute surface roughness z0 from w10, based on Eq (4) & (5) from Moon et al. 2007 @@ -3071,7 +3072,7 @@ subroutine breed_srf_winds(time, dt, npz, u_obs, v_obs, ak, bk, ps, phis, delp, ua(i,j,k) = ua(i,j,k) + relx*(ut-ua(i,j,k)) va(i,j,k) = va(i,j,k) + relx*(vt-va(i,j,k)) endif -400 continue +400 continue enddo ! end i-loop enddo ! end j-loop @@ -3117,12 +3118,12 @@ subroutine get_slp_obs(time, nobs, lon_obs, lat_obs, w10, mslp, slp_out, r_out, real(KIND=4), intent(in):: w10(nobs) !< observed 10-m widn speed real(KIND=4), intent(in):: mslp(nobs) !< observed SLP in pa real(KIND=4), intent(in):: slp_out(nobs) !< slp at r_out - real(KIND=4), intent(in):: r_out(nobs) + real(KIND=4), intent(in):: r_out(nobs) real(KIND=4), intent(in):: time_obs(nobs) real, optional, intent(in):: stime real, optional, intent(out):: fact ! Output - real(kind=R_GRID), intent(out):: x_o , y_o !< position of the storm center + real(kind=R_GRID), intent(out):: x_o , y_o !< position of the storm center real, intent(out):: w10_o !< 10-m wind speed real, intent(out):: slp_o !< Observed sea-level-pressure (pa) real, intent(out):: r_vor, p_vor @@ -3148,7 +3149,7 @@ subroutine get_slp_obs(time, nobs, lon_obs, lat_obs, w10, mslp, slp_out, r_out, call get_date(time, year, month, day, hour, minute, second) if ( year /= year_track_data ) then - if (master) write(*,*) 'Warning: The year in storm track data is not the same as model year' + if (master) write(*,*) 'Warning: The year in storm track data is not the same as model year' return endif @@ -3249,7 +3250,7 @@ subroutine slp_obs_init call mpp_error(FATAL,'==> Error in reading best track data') endif - do while ( ts_name=='start' ) + do while ( ts_name=='start' ) nstorms = nstorms + 1 nobs_tc(nstorms) = nobs ! observation count for this storm @@ -3299,7 +3300,7 @@ subroutine slp_obs_init y_obs(nobs,nstorms) = lat_deg * deg2rad if ( GMT == 'GMT' ) then ! Transfrom x from (-180 , 180) to (0, 360) then to radian - if ( lon_deg < 0 ) then + if ( lon_deg < 0 ) then x_obs(nobs,nstorms) = (360.+lon_deg) * deg2rad else x_obs(nobs,nstorms) = (360.-lon_deg) * deg2rad @@ -3315,7 +3316,7 @@ subroutine slp_obs_init close(unit) - if(master) then + if(master) then write(*,*) 'TC vortex breeding: total storms=', nstorms if ( nstorms/=0 ) then do n=1,nstorms @@ -3344,7 +3345,7 @@ real function calday(year, month, day, hour, minute, sec) if( month /= 1 ) then do m=1, month-1 - if( m==2 .and. leap_year(year) ) then + if( m==2 .and. leap_year(year) ) then ds = ds + 29 else ds = ds + days(m) @@ -3370,7 +3371,7 @@ logical function leap_year(ny) ! ! No leap years prior to 0000 ! - parameter ( ny00 = 0000 ) !< The threshold for starting leap-year + parameter ( ny00 = 0000 ) !< The threshold for starting leap-year if( ny >= ny00 ) then if( mod(ny,100) == 0. .and. mod(ny,400) == 0. ) then @@ -3473,7 +3474,7 @@ end subroutine del2_uv !>@brief The subroutine 'del2_scalar' filters the physics tendency. subroutine del2_scalar(qdt, cd, kmd, nmax, bd, npx, npy, gridstruct, domain) integer, intent(in):: kmd - integer, intent(in):: nmax !< must be no greater than 3 + integer, intent(in):: nmax !< must be no greater than 3 real, intent(in):: cd !< cd = K * da_min; 0 < K < 0.25 type(fv_grid_bounds_type), intent(IN) :: bd real, intent(inout):: qdt(is:ie,js:je,kmd) @@ -3489,7 +3490,7 @@ subroutine del2_scalar(qdt, cd, kmd, nmax, bd, npx, npy, gridstruct, domain) real, pointer, dimension(:,:) :: rarea, area real, pointer, dimension(:,:) :: sina_u, sina_v real, pointer, dimension(:,:,:) :: sin_sg - + real, pointer, dimension(:,:) :: dx, dy, rdxc, rdyc real(kind=R_GRID), pointer :: da_min @@ -3515,7 +3516,7 @@ subroutine del2_scalar(qdt, cd, kmd, nmax, bd, npx, npy, gridstruct, domain) se_corner => gridstruct%se_corner nw_corner => gridstruct%nw_corner ne_corner => gridstruct%ne_corner - + ntimes = min(3, nmax) damp = cd * da_min @@ -3550,7 +3551,7 @@ subroutine del2_scalar(qdt, cd, kmd, nmax, bd, npx, npy, gridstruct, domain) enddo if (is == 1) fx(i,j) = dy(is,j)*(q(is-1,j,k)-q(is,j,k))*rdxc(is,j)* & 0.5*(sin_sg(1,j,1) + sin_sg(0,j,3)) - if (ie+1 == npx) fx(i,j) = dy(ie+1,j)*(q(ie,j,k)-q(ie+1,j,k))*rdxc(ie+1,j)* & + if (ie+1 == npx) fx(i,j) = dy(ie+1,j)*(q(ie,j,k)-q(ie+1,j,k))*rdxc(ie+1,j)* & 0.5*(sin_sg(npx,j,1) + sin_sg(npx-1,j,3)) enddo @@ -3628,7 +3629,7 @@ subroutine corr(a, b, co, area) call std(a, m_a, std_a, area) call std(b, m_b, std_b, area) -! Compute correlation: +! Compute correlation: co = 0. do j=js,je do i=is,ie @@ -3656,7 +3657,7 @@ subroutine std(a, mean, stdv, area) enddo enddo call mp_reduce_sum(mean) - mean = mean / total_area + mean = mean / total_area stdv = 0. do j=js,je