diff --git a/model/fv_regional_bc.F90 b/model/fv_regional_bc.F90 index 6467498b8..1e76a7eb0 100644 --- a/model/fv_regional_bc.F90 +++ b/model/fv_regional_bc.F90 @@ -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 @@ -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 ! !----------------------------------------------------------------------- @@ -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)) @@ -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. ! @@ -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 @@ -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 diff --git a/tools/external_ic.F90 b/tools/external_ic.F90 index 4c91a29d2..62ae168b0 100644 --- a/tools/external_ic.F90 +++ b/tools/external_ic.F90 @@ -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 @@ -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 @@ -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 & @@ -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)) @@ -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 @@ -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)) @@ -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)) diff --git a/tools/fv_io.F90 b/tools/fv_io.F90 index 639799bdc..4ec4f52b7 100644 --- a/tools/fv_io.F90 +++ b/tools/fv_io.F90 @@ -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, & @@ -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 @@ -288,7 +288,7 @@ 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, & @@ -296,7 +296,7 @@ subroutine fv_io_register_restart(Atm) 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) @@ -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 @@ -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