Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

DRAFT: fixes all read of the same data by having single reader broadcast #278

Open
wants to merge 2 commits into
base: main
Choose a base branch
from
Open

DRAFT: fixes all read of the same data by having single reader broadcast #278

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
c3286b4
fixes all read of the same data by having single reader broadcast
bensonr Aug 11, 2023
d01efc0
fixed some inconsistencies to satisfy interface standards
bensonr Aug 11, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
65 changes: 37 additions & 28 deletions model/fv_regional_bc.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -31,7 +31,7 @@ module fv_regional_mod
CENTER, CORNER, &
mpp_domains_set_stack_size, &
mpp_update_domains, mpp_get_neighbor_pe
use mpp_mod, only: FATAL, input_nml_file, &
use mpp_mod, only: FATAL, input_nml_file, mpp_broadcast, &
mpp_error ,mpp_pe, mpp_sync, &
mpp_npes, mpp_root_pe, mpp_gather, &
mpp_get_current_pelist, NOTE, NULL_PE
Expand Down Expand Up @@ -1380,14 +1380,16 @@ subroutine start_regional_restart(Atm &
!-----------------------------------------------------------------------
allocate(pes(mpp_npes()))
call mpp_get_current_pelist(pes)
if( open_file(Gfs_ctl, 'INPUT/gfs_ctrl.nc', "read", pelist=pes) ) then
if (mpp_pe() == pes(1)) then
if( open_file(Gfs_ctl, 'INPUT/gfs_ctrl.nc', "read", pelist=pes(1:1)) ) then
!--- read in the number of levsp
call get_dimension_size(Gfs_ctl, 'levsp', levsp)
call close_file(Gfs_ctl)
else
call mpp_error(FATAL,'==> Error in fv_regional::start_regional_restart file INPUT/gfs_ctl.nc does not exist')
call get_dimension_size(Gfs_ctl, 'levsp', levsp)
call close_file(Gfs_ctl)
else
call mpp_error(FATAL,'==> Error in fv_regional::start_regional_restart file INPUT/gfs_ctl.nc does not exist')
endif
endif

call mpp_broadcast(levsp, pes(1), pes)
levp = levsp-1
!
!-----------------------------------------------------------------------
Expand All @@ -1411,17 +1413,20 @@ subroutine start_regional_restart(Atm &
allocate (wk2(levp+1,2))
allocate (ak_in(levp+1)) !<-- Save the input vertical structure for
allocate (bk_in(levp+1)) ! remapping BC updates during the forecast.
if (Atm%flagstruct%hrrrv3_ic) then
if (open_file(Grid_input, 'INPUT/hrrr_ctrl.nc', "read", pelist=pes)) then
call read_data(Grid_input,'vcoord',wk2)
call close_file(Grid_input)
endif
else
if (open_file(Grid_input, 'INPUT/gfs_ctrl.nc', "read", pelist=pes)) then
call read_data(Grid_input,'vcoord',wk2)
call close_file(Grid_input)
if (mpp_pe() == pes(1)) then
if (Atm%flagstruct%hrrrv3_ic) then
if (open_file(Grid_input, 'INPUT/hrrr_ctrl.nc', "read", pelist=pes(1:1))) then
call read_data(Grid_input,'vcoord',wk2)
call close_file(Grid_input)
endif
else
if (open_file(Grid_input, 'INPUT/gfs_ctrl.nc', "read", pelist=pes(1:1))) then
call read_data(Grid_input,'vcoord',wk2)
call close_file(Grid_input)
endif
endif
endif
call mpp_broadcast(wk2, size(wk2), pes(1), pes)
deallocate(pes)
ak_in(1:levp+1) = wk2(1:levp+1,1)
ak_in(1) = max(1.e-9, ak_in(1))
Expand Down Expand Up @@ -4361,7 +4366,7 @@ subroutine regional_boundary_update(array &
!
integer,intent(in) :: is,ie,js,je & !<-- Compute limits
,isd,ied,jsd,jed & !<-- Memory limits
,it !<-- Acoustic step
,it !<-- Acoustic step
!
integer,intent(in),optional :: index4 !<-- Index for the 4-D tracer array.
!
Expand Down Expand Up @@ -6822,7 +6827,7 @@ subroutine get_data_source(data_source_fv3gfs,regional,directory)
logical, intent(in):: regional
logical, intent(out):: data_source_fv3gfs

character (len=80) :: source
character (len=80), dimension(1) :: source
logical :: lstatus
character(len=*), intent(in), optional :: directory
character(len=128) :: dir
Expand All @@ -6839,30 +6844,34 @@ subroutine get_data_source(data_source_fv3gfs,regional,directory)
allocate(pes(mpp_npes()))
call mpp_get_current_pelist(pes)

if (open_file(Gfs_data , trim(dir)//'/gfs_data.nc', "read", pelist=pes) .or. &
open_file(Gfs_data , trim(dir)//'/gfs_data.tile1.nc', "read", pelist=pes)) then
if (mpp_pe() == pes(1)) then
if (open_file(Gfs_data , trim(dir)//'/gfs_data.nc', "read", pelist=pes(1:1)) .or. &
open_file(Gfs_data , trim(dir)//'/gfs_data.tile1.nc', "read", pelist=pes(1:1))) then
lstatus = global_att_exists(Gfs_data, "source")
if(lstatus) call get_global_attribute(Gfs_data, "source", source)
call close_file(Gfs_data)
endif
endif

deallocate(pes)
if (.not. lstatus) then
if (mpp_pe() == 0) write(0,*) 'INPUT source not found in ', trim(dir), &
' status=', lstatus,' set source=No Source Attribute'
if (mpp_pe() == mpp_root_pe()) write(0,*) 'INPUT source not found in ', trim(dir), &
' status=', lstatus,' set source=No Source Attribute'
source='No Source Attribute'
endif
if (mpp_pe()==0) write(*,*) 'INPUT gfs_data source string=',source
if (mpp_pe()==mpp_root_pe()) write(*,*) 'INPUT gfs_data source string=',source

call mpp_broadcast(source, len(source), pes(1), pes)
deallocate(pes)

! Logical flag for fv3gfs nemsio/netcdf/grib2 --------
if ( trim(source)=='FV3GFS GAUSSIAN NEMSIO FILE' .or. &
trim(source)=='FV3GFS GAUSSIAN NETCDF FILE' .or. &
trim(source)=='FV3GFS GRIB2 FILE' ) then
if ( trim(source(1))=='FV3GFS GAUSSIAN NEMSIO FILE' .or. &
trim(source(1))=='FV3GFS GAUSSIAN NETCDF FILE' .or. &
trim(source(1))=='FV3GFS GRIB2 FILE' ) then
data_source_fv3gfs = .TRUE.
else
data_source_fv3gfs = .FALSE.
endif
if (mpp_pe()==0) write(*,*) 'data_source_fv3gfs=',data_source_fv3gfs
if (mpp_pe()==mpp_root_pe()) write(*,*) 'data_source_fv3gfs=',data_source_fv3gfs

end subroutine get_data_source

Expand Down
91 changes: 56 additions & 35 deletions tools/external_ic.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -34,7 +34,7 @@ module external_ic_mod
FmsNetcdfFile_t, FmsNetcdfDomainFile_t, read_restart, &
register_restart_field, register_axis, get_dimension_size, &
get_variable_dimension_names, get_variable_num_dimensions
use mpp_mod, only: mpp_error, FATAL, NOTE, WARNING, mpp_pe, mpp_root_pe
use mpp_mod, only: mpp_error, FATAL, NOTE, WARNING, mpp_pe, mpp_root_pe, mpp_broadcast
use mpp_mod, only: stdlog, input_nml_file, mpp_npes, mpp_get_current_pelist
use mpp_parameter_mod, only: AGRID_PARAM=>AGRID
use mpp_domains_mod, only: mpp_get_tile_id, domain2d, mpp_update_domains, NORTH, EAST
Expand Down Expand Up @@ -345,6 +345,7 @@ subroutine get_nggps_ic (Atm)
real(kind=R_GRID), dimension(3):: e1, e2, ex, ey
integer:: i,j,k,nts, ks, naxis_dims
integer:: liq_wat, ice_wat, rainwat, snowwat, graupel, tke, ntclamt
integer:: dum_i4(2) ! used for the broadcast of ntrac and levsp
namelist /external_ic_nml/ filtered_terrain, levp, gfs_dwinds, &
checker_tr, nt_checker

Expand Down Expand Up @@ -393,16 +394,22 @@ subroutine get_nggps_ic (Atm)

allocate(pes(mpp_npes()))
call mpp_get_current_pelist(pes)
if( open_file(Gfs_ctl, fn_gfs_ctl, "read", pelist=pes) ) then
if (mpp_pe() == pes(1)) then
if( open_file(Gfs_ctl, fn_gfs_ctl, "read", pelist=pes(1:1)) ) then
!--- read in the number of tracers in the NCEP NGGPS ICs
call read_data (Gfs_ctl, 'ntrac', ntrac)
call read_data (Gfs_ctl, 'ntrac', dum_i4(1))
!--- read in the number of levp
call get_dimension_size(Gfs_ctl, 'levsp', levsp)
call close_file(Gfs_ctl)
else
call mpp_error(FATAL,'==> Error in External_ic::get_nggps_ic: file '//trim(fn_gfs_ctl)//' for NGGPS IC does not exist')
call get_dimension_size(Gfs_ctl, 'levsp', dum_i4(2))
call close_file(Gfs_ctl)
else
call mpp_error(FATAL,'==> Error in External_ic::get_nggps_ic: file '//trim(fn_gfs_ctl)//' for NGGPS IC does not exist')
endif
endif
call mpp_broadcast(dum_i4, size(dum_i4), pes(1), pes)
deallocate(pes)
ntrac = dum_i4(1)
levsp = dum_i4(2)

call mpp_error(NOTE,'==> External_ic::get_nggps_ic: using control file '//trim(fn_gfs_ctl)//' for NGGPS IC')

if (ntrac > ntracers) call mpp_error(FATAL,'==> External_ic::get_nggps_ic: more NGGPS tracers &
Expand Down Expand Up @@ -730,14 +737,16 @@ subroutine read_gfs_ic()

allocate(pes(mpp_npes()))
call mpp_get_current_pelist(pes)
if( open_file(Gfs_ctl, fn_gfs_ctl, "read", pelist=pes) ) then
call read_data(Gfs_ctl,'vcoord',wk2)
ak(1:levp+1) = wk2(1:levp+1,1)
bk(1:levp+1) = wk2(1:levp+1,2)
deallocate (wk2)
call close_file(Gfs_ctl)
if (mpp_pe() == pes(1)) then
if( open_file(Gfs_ctl, fn_gfs_ctl, "read", pelist=pes(1:1)) ) then
call read_data(Gfs_ctl,'vcoord',wk2)
call close_file(Gfs_ctl)
endif
endif
deallocate(pes)
call mpp_broadcast(wk2, size(wk2), pes(1), pes)
ak(1:levp+1) = wk2(1:levp+1,1)
bk(1:levp+1) = wk2(1:levp+1,2)
deallocate (wk2, pes)

allocate (zh(is:ie,js:je,levp+1)) ! SJL
allocate (ps(is:ie,js:je))
Expand Down Expand Up @@ -866,6 +875,7 @@ subroutine get_hrrr_ic (Atm)
real(kind=R_GRID), dimension(3):: e1, e2, ex, ey
integer:: i,j,k,nts, ks
integer:: liq_wat, ice_wat, rainwat, snowwat, graupel, tke, ntclamt
integer:: dum_i4(2)
namelist /external_ic_nml/ filtered_terrain, levp, gfs_dwinds, &
checker_tr, nt_checker
! variables for reading the dimension from the hrrr_ctrl
Expand Down Expand Up @@ -905,29 +915,38 @@ subroutine get_hrrr_ic (Atm)

allocate(pes(mpp_npes()))
call mpp_get_current_pelist(pes)
if( open_file(Hrr_ctl, fn_hrr_ctl, "read", pelist=pes) ) then
if (mpp_pe() == pes(1)) then
if( open_file(Hrr_ctl, fn_hrr_ctl, "read", pelist=pes(1:1)) ) then
!--- read in the number of tracers in the HRRR ICs
call read_data (Hrr_ctl, 'ntrac', ntrac)
if (ntrac > ntracers) call mpp_error(FATAL,'==> External_ic::get_hrrr_ic: more HRRR tracers &
&than defined in field_table '//trim(fn_hrr_ctl)//' for HRRR IC')
call read_data (Hrr_ctl, 'ntrac', ntrac)
if (ntrac > ntracers) call mpp_error(FATAL,'==> External_ic::get_hrrr_ic: more HRRR tracers &
&than defined in field_table '//trim(fn_hrr_ctl)//' for HRRR IC')

!--- read in ak and bk from the HRRR control file using fms_io read_data ---
call get_dimension_size(Hrr_ctl, 'levsp', levsp)
call get_dimension_size(Hrr_ctl, 'levsp', levsp)

levp = levsp-1
levp = levsp-1

allocate (wk2(levp+1,2))
allocate (ak(levp+1))
allocate (bk(levp+1))
call read_data(Hrr_ctl,'vcoord',wk2)
ak(1:levp+1) = wk2(1:levp+1,1)
bk(1:levp+1) = wk2(1:levp+1,2)
deallocate (wk2)
call close_file(Hrr_ctl)
allocate (wk2(levp+1,2))
call read_data(Hrr_ctl,'vcoord',wk2)
call close_file(Hrr_ctl)
call mpp_broadcast(wk2, size(wk2), pes(1), pes)
else
call mpp_error(FATAL,'==> Error in External_ic::get_hrrr_ic: file '//trim(fn_hrr_ctl)//' for HRRR IC does not exist')
endif
else
call mpp_error(FATAL,'==> Error in External_ic::get_hrrr_ic: file '//trim(fn_hrr_ctl)//' for HRRR IC does not exist')
call mpp_broadcast(dum_i4, size(dum_i4), pes(1), pes)
ntrac = dum_i4(1)
levsp = dum_i4(2)
levp = levsp-1
allocate (wk2(levp+1,2))
call mpp_broadcast(wk2, size(wk2), pes(1), pes)
endif
deallocate(pes)
allocate (ak(levp+1))
allocate (bk(levp+1))
ak(1:levp+1) = wk2(1:levp+1,1)
bk(1:levp+1) = wk2(1:levp+1,2)
deallocate (wk2, pes)
call mpp_error(NOTE,'==> External_ic::get_hrrr_ic: using control file '//trim(fn_hrr_ctl)//' for HRRR IC')

allocate (zh(is:ie,js:je,levp+1))
Expand Down Expand Up @@ -1916,14 +1935,16 @@ subroutine get_ecmwf_ic( Atm )
allocate (bk_gfs(levp_gfs+1))
allocate(pes(mpp_npes()))
call mpp_get_current_pelist(pes)
if( open_file(Gfs_ctl, fn_gfs_ctl, "read", pelist=pes) ) then
call read_data(Gfs_ctl,'vcoord',wk2)
call close_file(Gfs_ctl)
if (mpp_pe() == pes(1)) then
if( open_file(Gfs_ctl, fn_gfs_ctl, "read", pelist=pes(1:1)) ) then
call read_data(Gfs_ctl,'vcoord',wk2)
call close_file(Gfs_ctl)
endif
endif
deallocate(pes)
call mpp_broadcast(wk2, size(wk2), pes(1), pes)
ak_gfs(1:levp_gfs+1) = wk2(1:levp_gfs+1,1)
bk_gfs(1:levp_gfs+1) = wk2(1:levp_gfs+1,2)
deallocate (wk2)
deallocate (wk2, pes)

if ( bk_gfs(1) < 1.E-9 ) ak_gfs(1) = max(1.e-9, ak_gfs(1))

Expand Down
41 changes: 25 additions & 16 deletions tools/fv_io.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -42,7 +42,7 @@ module fv_io_mod
variable_exists, read_data, set_filename_appendix
use mpp_mod, only: mpp_error, FATAL, NOTE, WARNING, mpp_root_pe, &
mpp_sync, mpp_pe, mpp_declare_pelist, mpp_get_current_pelist, &
mpp_npes
mpp_npes, mpp_broadcast
use mpp_domains_mod, only: domain2d, EAST, WEST, NORTH, CENTER, SOUTH, CORNER, &
mpp_get_compute_domain, mpp_get_data_domain, &
mpp_get_layout, mpp_get_ntile_count, &
Expand All @@ -61,7 +61,7 @@ module fv_io_mod
use fv_treat_da_inc_mod, only: read_da_inc
use mpp_parameter_mod, only: DGRID_NE
use fv_grid_utils_mod, only: cubed_a2d

implicit none
private

Expand Down Expand Up @@ -288,15 +288,15 @@ subroutine fv_io_register_restart(Atm)
call register_restart_field(Atm%Fv_restart_tile, 'v', Atm%v, &
dim_names_4d2, is_optional=.true.)
endif

!--- include agrid winds in restarts for use in data assimilation or for restarting
if (Atm%flagstruct%agrid_vel_rst .or. Atm%flagstruct%restart_from_agrid_winds) then
call register_restart_field(Atm%Fv_restart_tile, 'ua', Atm%ua, &
dim_names_4d3)
call register_restart_field(Atm%Fv_restart_tile, 'va', Atm%va, &
dim_names_4d3)
endif

if (.not. Atm%flagstruct%restart_from_agrid_winds) then
call register_restart_field(Atm%Fv_restart_tile, 'u', Atm%u, &
dim_names_4d)
Expand Down Expand Up @@ -466,15 +466,20 @@ subroutine fv_io_read_restart(fv_domain,Atm,prefix,directory)
allocate(pes(mpp_npes()))
call mpp_get_current_pelist(pes)

suffix = ''
fname = ''//trim(dir)//'/'//trim(pre)//'fv_core.res.nc'
Atm(1)%Fv_restart_is_open = open_file(Atm(1)%Fv_restart,fname,"read", is_restart=.true., pelist=pes)
if (Atm(1)%Fv_restart_is_open) then
call fv_io_register_restart(Atm(1))
call read_restart(Atm(1)%Fv_restart)
call close_file(Atm(1)%Fv_restart)
Atm(1)%Fv_restart_is_open = .false.
!--- single reader with a broadcast to all other members of the group pes
if (mpp_pe() == pes(1)) then
suffix = ''
fname = ''//trim(dir)//'/'//trim(pre)//'fv_core.res.nc'
Atm(1)%Fv_restart_is_open = open_file(Atm(1)%Fv_restart,fname,"read", is_restart=.true., pelist=pes(1:1))
if (Atm(1)%Fv_restart_is_open) then
call fv_io_register_restart(Atm(1))
call read_restart(Atm(1)%Fv_restart)
call close_file(Atm(1)%Fv_restart)
Atm(1)%Fv_restart_is_open = .false.
endif
endif
call mpp_broadcast(Atm(1)%ak, size(Atm(1)%ak), pes(1), pes)
call mpp_broadcast(Atm(1)%bk, size(Atm(1)%bk), pes(1), pes)
deallocate(pes)

if (Atm(1)%flagstruct%external_eta) then
Expand Down Expand Up @@ -681,11 +686,15 @@ subroutine remap_restart(Atm)
fname = 'INPUT/fv_core.res.nc'
allocate(pes(mpp_npes()))
call mpp_get_current_pelist(pes)
if (open_file(Fv_restart_r,fname,"read", is_restart=.true., pelist=pes)) then
call read_data(Fv_restart_r, 'ak', ak_r(:))
call read_data(Fv_restart_r, 'bk', bk_r(:))
call close_file(Fv_restart_r)
if (mpp_pe() == pes(1)) then
if (open_file(Fv_restart_r,fname,"read", is_restart=.true., pelist=pes(1:1))) then
call read_data(Fv_restart_r, 'ak', ak_r(:))
call read_data(Fv_restart_r, 'bk', bk_r(:))
call close_file(Fv_restart_r)
endif
endif
call mpp_broadcast(ak_r, size(ak_r), pes(1), pes)
call mpp_broadcast(bk_r, size(bk_r), pes(1), pes)
deallocate(pes)

! fix for single tile runs where you need fv_core.res.nc and fv_core.res.tile1.nc
Expand Down