diff --git a/canopy_air/canopy_air.F90 b/canopy_air/canopy_air.F90 index 394232c8..440d7678 100644 --- a/canopy_air/canopy_air.F90 +++ b/canopy_air/canopy_air.F90 @@ -23,14 +23,9 @@ module canopy_air_mod #include "../shared/debug.inc" -#ifdef INTERNAL_FILE_NML +use fms_mod, only : error_mesg, FATAL, NOTE, & + check_nml_error, mpp_pe, mpp_root_pe, stdlog, string use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif - -use fms_mod, only : error_mesg, FATAL, NOTE, file_exist, & - close_file, check_nml_error, mpp_pe, mpp_root_pe, stdlog, string use constants_mod, only : VONKARM use sphum_mod, only : qscomp use field_manager_mod, only : parse, MODEL_ATMOS, MODEL_LAND @@ -102,21 +97,8 @@ subroutine read_cana_namelist() call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml=cana_nml, iostat=io) - ierr = check_nml_error(io, 'cana_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=cana_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'cana_nml') - enddo -10 continue - call close_file (unit) - endif -#endif + read (input_nml_file, nml=cana_nml, iostat=io) + ierr = check_nml_error(io, 'cana_nml') if (mpp_pe() == mpp_root_pe()) then unit = stdlog() write (unit, nml=cana_nml) @@ -130,7 +112,7 @@ subroutine cana_init() ! ---- local vars ---------------------------------------------------------- type(land_tile_enum_type) :: ce ! tile list enumerator type(land_tile_type), pointer :: tile ! pointer to current tile - character(*), parameter :: restart_file_name='INPUT/cana.res.nc' + character(*), parameter :: restart_file_name='INPUT/cana.nc' type(land_restart_type) :: restart logical :: restart_exists @@ -237,7 +219,7 @@ subroutine save_cana_restart (tile_dim_length, timestamp) call error_mesg('cana_end','writing NetCDF restart',NOTE) ! Note that filename is updated for tile & rank numbers during file creation - filename = trim(timestamp)//'cana.res.nc' + filename = 'RESTART/'//trim(timestamp)//'cana.nc' call init_land_restart(restart, filename, cana_tile_exists, tile_dim_length) ! write temperature diff --git a/glacier/glac_tile.F90 b/glacier/glac_tile.F90 index 1a17df4c..38c511d9 100644 --- a/glacier/glac_tile.F90 +++ b/glacier/glac_tile.F90 @@ -19,13 +19,8 @@ module glac_tile_mod #include -#ifdef INTERNAL_FILE_NML +use fms_mod, only : check_nml_error, stdlog use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif - -use fms_mod, only : file_exist, check_nml_error, close_file, stdlog use constants_mod, only : pi, tfreeze, hlf use land_constants_mod, only : NBANDS use land_io_mod, only : init_cover_field @@ -231,21 +226,8 @@ subroutine read_glac_data_namelist(glac_n_lev, glac_dz) call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml=glac_data_nml, iostat=io) - ierr = check_nml_error(io, 'glac_data_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=glac_data_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'glac_data_nml') - enddo -10 continue - call close_file (unit) - endif -#endif + read (input_nml_file, nml=glac_data_nml, iostat=io) + ierr = check_nml_error(io, 'glac_data_nml') unit=stdlog() write (unit, nml=glac_data_nml) diff --git a/glacier/glacier.F90 b/glacier/glacier.F90 index c3c047f9..e7b34fb5 100644 --- a/glacier/glacier.F90 +++ b/glacier/glacier.F90 @@ -21,15 +21,9 @@ ! ============================================================================ module glacier_mod -#ifdef INTERNAL_FILE_NML -use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif - -use fms_mod, only : error_mesg, file_exist, check_nml_error, stdlog, close_file, & +use fms_mod, only : error_mesg, check_nml_error, stdlog, & mpp_pe, mpp_root_pe, FATAL, NOTE - +use mpp_mod, only: input_nml_file use time_manager_mod, only: time_type_to_real use diag_manager_mod, only: diag_axis_init use constants_mod, only: tfreeze, hlv, hlf, dens_h2o @@ -107,21 +101,8 @@ subroutine read_glac_namelist() call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml=glac_nml, iostat=io) - ierr = check_nml_error(io, 'glac_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=glac_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'glac_nml') - enddo -10 continue - call close_file (unit) - endif -#endif + read (input_nml_file, nml=glac_nml, iostat=io) + ierr = check_nml_error(io, 'glac_nml') if (mpp_pe() == mpp_root_pe()) then unit = stdlog() write (unit, nml=glac_nml) @@ -147,7 +128,7 @@ subroutine glac_init (id_ug) type(land_tile_type), pointer :: tile ! pointer to current tile type(land_restart_type) :: restart logical :: restart_exists - character(*), parameter :: restart_file_name='INPUT/glac.res.nc' + character(*), parameter :: restart_file_name='INPUT/glac.nc' module_is_initialized = .TRUE. delta_time = time_type_to_real(lnd%dt_fast) @@ -222,14 +203,14 @@ subroutine save_glac_restart (tile_dim_length, timestamp) call error_mesg('glac_end','writing NetCDF restart',NOTE) ! must set domain so that io_domain is available ! Note that filename is updated for tile & rank numbers during file creation - filename = trim(timestamp)//'glac.res.nc' + filename = 'RESTART/'//trim(timestamp)//'glac.nc' call init_land_restart(restart, filename, glac_tile_exists, tile_dim_length) - call add_restart_axis(restart,'zfull',zfull(1:num_l),'Z','m','full level',sense=-1) + call add_restart_axis(restart,'zfull',zfull(1:num_l),.false.,"Z",'m','full level') ! Output data provides signature - call add_tile_data(restart,'temp', 'zfull', glac_temp_ptr, longname='glacier temperature', units='degrees_K') - call add_tile_data(restart,'wl', 'zfull', glac_wl_ptr, longname='liquid water content', units='kg/m2') - call add_tile_data(restart,'ws', 'zfull', glac_ws_ptr, longname='solid water content', units='kg/m2') + call add_tile_data(restart,'temp', 'zfull ', glac_temp_ptr, longname='glacier temperature', units='degrees_K') + call add_tile_data(restart,'wl', 'zfull ', glac_wl_ptr, longname='liquid water content', units='kg/m2') + call add_tile_data(restart,'ws', 'zfull ', glac_ws_ptr, longname='solid water content', units='kg/m2') ! save performs io domain aggregation through mpp_io as with regular domain data call save_land_restart(restart) diff --git a/lake/lake.F90 b/lake/lake.F90 index f307a088..904a8425 100644 --- a/lake/lake.F90 +++ b/lake/lake.F90 @@ -21,14 +21,12 @@ ! ============================================================================ module lake_mod -#ifdef INTERNAL_FILE_NML use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif - -use fms_mod, only : error_mesg, file_exist, read_data, check_nml_error, & - stdlog, close_file, mpp_pe, mpp_root_pe, FATAL, NOTE, lowercase +use mpp_domains_mod, only: domain2d, domainug, mpp_get_compute_domain, mpp_pass_sg_to_ug +use fms_mod, only : error_mesg, check_nml_error, & + stdlog, mpp_pe, mpp_root_pe, FATAL, NOTE, lowercase +use fms2_io_mod, only: open_file, close_file, read_data, register_field, FmsNetcdfDomainFile_t, & + ®ister_axis, get_variable_num_dimensions, get_variable_dimension_names use time_manager_mod, only: time_type_to_real use diag_manager_mod, only: diag_axis_init use constants_mod, only: tfreeze, hlv, hlf, dens_h2o, grav, vonkarm, rdgas @@ -133,7 +131,7 @@ module lake_mod ! ============================================================================ subroutine read_lake_namelist() ! ---- local vars - integer :: unit ! unit for namelist i/o + integer :: file_unit ! unit for namelist i/o integer :: io ! i/o status for the namelist integer :: ierr ! error code, returned by i/o routines integer :: l @@ -142,24 +140,12 @@ subroutine read_lake_namelist() call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml=lake_nml, iostat=io) - ierr = check_nml_error(io, 'lake_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=lake_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'lake_nml') - enddo -10 continue - call close_file (unit) - endif -#endif + read (input_nml_file, nml=lake_nml, iostat=io) + ierr = check_nml_error(io, 'lake_nml') + if (mpp_pe() == mpp_root_pe()) then - unit=stdlog() - write(unit, nml=lake_nml) + file_unit=stdlog() + write(file_unit, nml=lake_nml) endif ! ---- set up vertical discretization @@ -206,6 +192,9 @@ subroutine lake_init_predefined(id_ug) integer :: i, g, l logical :: river_data_exist character(*), parameter :: restart_file_name = 'INPUT/lake.res.nc' + character(len=30), allocatable :: dimnames(:) !< Array of dimension names + type(FmsNetcdfDomainFile_t) :: fileobj !< Domain decomposed fileobj + integer :: ndims !< Number of dimensions module_is_initialized = .TRUE. delta_time = time_type_to_real(lnd%dt_fast) @@ -217,26 +206,35 @@ subroutine lake_init_predefined(id_ug) bufferc(:) = 0 buffert(:) = 0 - river_data_exist = file_exist('INPUT/river_data.nc', lnd%sg_domain) + river_data_exist = open_file(fileobj, 'INPUT/river_data.nc', "read", lnd%sg_domain) if (river_data_exist) then call error_mesg('lake_init', 'reading lake information from river data file', NOTE) else call error_mesg('lake_init', 'river data file not present: lake fraction is set to zero', NOTE) endif + if (river_data_exist) then + !< Register the domain decomposed dimensions + ndims = get_variable_num_dimensions(fileobj, "connected_to_next") + allocate(dimnames(ndims)) + call get_variable_dimension_names(fileobj,"connected_to_next" , dimnames) + call register_axis(fileobj, dimnames(1), "x") + call register_axis(fileobj, dimnames(2), "y") + endif + IF (LARGE_DYN_SMALL_STAT) THEN - if(river_data_exist) call read_data('INPUT/river_data.nc', 'connected_to_next', bufferc(:), lnd%sg_domain) + if(river_data_exist) call SG_to_UG_read_data(fileobj, 'connected_to_next', bufferc(:), lnd%ug_domain, lnd%sg_domain, dimnames) - if(river_data_exist) call read_data('INPUT/river_data.nc', 'whole_lake_area', buffer(:), lnd%sg_domain) + if(river_data_exist) call SG_to_UG_read_data(fileobj, 'whole_lake_area', buffer(:), lnd%ug_domain, lnd%sg_domain, dimnames) - if(river_data_exist) call read_data('INPUT/river_data.nc', 'lake_depth_sill', buffer(:), lnd%sg_domain) + if(river_data_exist) call SG_to_UG_read_data(fileobj, 'lake_depth_sill', buffer(:), lnd%ug_domain, lnd%sg_domain, dimnames) buffer = min(buffer, lake_depth_max) buffer = max(buffer, lake_depth_min) ! lake_tau is just used here as a flag for 'large lakes' ! sill width of -1 is a flag saying not to allow transient storage - if(river_data_exist) call read_data('INPUT/river_data.nc', 'lake_tau', buffert(:), lnd%sg_domain) + if(river_data_exist) call SG_to_UG_read_data(fileobj, 'lake_tau', buffert(:), lnd%ug_domain, lnd%sg_domain, dimnames) buffer = -1. !where (bufferc.gt.0.5) buffer = lake_width_inside_lake where (bufferc.lt.0.5 .and. buffert.gt.1.) buffer = large_lake_sill_width @@ -252,29 +250,33 @@ subroutine lake_init_predefined(id_ug) buffer = 1.e8 if (max_plain_slope.gt.0. .and. river_data_exist) & - call read_data('INPUT/river_data.nc', 'max_slope_to_next', buffer(:), lnd%sg_domain) - if(river_data_exist) call read_data('INPUT/river_data.nc', 'travel', buffert(:), lnd%sg_domain) + call SG_to_UG_read_data(fileobj, 'max_slope_to_next', buffer(:), lnd%ug_domain, lnd%sg_domain, dimnames) + if(river_data_exist) call SG_to_UG_read_data(fileobj, 'travel', buffert(:), lnd%ug_domain, lnd%sg_domain, dimnames) bufferc = 0. where (buffer.lt.max_plain_slope .and. buffert.gt.1.5) bufferc = 1. bufferc = 0 where (buffer.lt.max_plain_slope .and. buffert.lt.1.5) bufferc = 1. ELSE - if(river_data_exist) call read_data('INPUT/river_data.nc', 'whole_lake_area', bufferc(:), lnd%sg_domain) + if(river_data_exist) call SG_to_UG_read_data(fileobj, 'whole_lake_area', bufferc(:), lnd%ug_domain, lnd%sg_domain, dimnames) - if(river_data_exist) call read_data('INPUT/river_data.nc', 'lake_depth_sill', buffer(:), lnd%sg_domain) + if(river_data_exist) call SG_to_UG_read_data(fileobj, 'lake_depth_sill', buffer(:), lnd%ug_domain, lnd%sg_domain, dimnames) where (bufferc.eq.0.) buffer = 0. where (bufferc.gt.0..and.bufferc.lt.2.e10) buffer = max(2., 2.5e-4*sqrt(bufferc)) buffer = 4. * buffer where (bufferc.gt.2.e10) buffer = min(buffer, 60.) - if(river_data_exist) call read_data('INPUT/river_data.nc', 'connected_to_next', bufferc(:), lnd%sg_domain) + if(river_data_exist) call SG_to_UG_read_data(fileobj, 'connected_to_next', bufferc(:), lnd%ug_domain, lnd%sg_domain, dimnames) where (bufferc.gt.0.5) buffer=lake_width_inside_lake if (make_all_lakes_wide) buffer = lake_width_inside_lake ENDIF deallocate (buffer, bufferc, buffert) + if (river_data_exist) then + deallocate(dimnames) + call close_file(fileobj) + endif ! -------- initialize lake state -------- te = tail_elmt (land_tile_map) @@ -332,7 +334,10 @@ subroutine lake_init (id_ug) real, allocatable :: buffer(:),bufferc(:),buffert(:) integer :: i, g, l logical :: river_data_exist - character(*), parameter :: restart_file_name = 'INPUT/lake.res.nc' + character(*), parameter :: restart_file_name = 'INPUT/lake.nc' + character(len=30), allocatable :: dimnames(:) !< Array of dimension names + type(FmsNetcdfDomainFile_t) :: fileobj !< Domain decomposed fileobj + integer :: ndims !< Number of dimensions module_is_initialized = .TRUE. delta_time = time_type_to_real(lnd%dt_fast) @@ -344,33 +349,42 @@ subroutine lake_init (id_ug) bufferc(:) = 0 buffert(:) = 0 - river_data_exist = file_exist('INPUT/river_data.nc', lnd%sg_domain) + river_data_exist =open_file(fileobj, 'INPUT/river_data.nc', "read", lnd%sg_domain) if (river_data_exist) then call error_mesg('lake_init', 'reading lake information from river data file', NOTE) else call error_mesg('lake_init', 'river data file not present: lake fraction is set to zero', NOTE) endif + if (river_data_exist) then + !< Register the domain decomposed dimensions + ndims = get_variable_num_dimensions(fileobj, "connected_to_next") + allocate(dimnames(ndims)) + call get_variable_dimension_names(fileobj,"connected_to_next" , dimnames) + call register_axis(fileobj, dimnames(1), "x") + call register_axis(fileobj, dimnames(2), "y") + endif + IF (LARGE_DYN_SMALL_STAT) THEN - if (river_data_exist) call read_data('INPUT/river_data.nc', 'connected_to_next', & - bufferc(:), lnd%sg_domain, lnd%ug_domain) + if (river_data_exist) call SG_to_UG_read_data(fileobj, 'connected_to_next', & + bufferc(:), lnd%ug_domain, lnd%sg_domain, dimnames) call put_to_tiles_r0d_fptr(bufferc, land_tile_map, lake_connected_to_next_ptr) - if (river_data_exist) call read_data('INPUT/river_data.nc', 'whole_lake_area', & - buffer(:), lnd%sg_domain, lnd%ug_domain) + if (river_data_exist) call SG_to_UG_read_data(fileobj, 'whole_lake_area', & + buffer(:), lnd%ug_domain, lnd%sg_domain, dimnames) call put_to_tiles_r0d_fptr(buffer, land_tile_map, lake_whole_area_ptr) - if (river_data_exist) call read_data('INPUT/river_data.nc', 'lake_depth_sill', & - buffer(:), lnd%sg_domain, lnd%ug_domain) + if (river_data_exist) call SG_to_UG_read_data(fileobj, 'lake_depth_sill', & + buffer(:), lnd%ug_domain, lnd%sg_domain, dimnames) buffer = min(buffer, lake_depth_max) buffer = max(buffer, lake_depth_min) call put_to_tiles_r0d_fptr(buffer, land_tile_map, lake_depth_sill_ptr) ! lake_tau is just used here as a flag for 'large lakes' ! sill width of -1 is a flag saying not to allow transient storage - if (river_data_exist) call read_data('INPUT/river_data.nc', 'lake_tau', & - buffert(:), lnd%sg_domain, lnd%ug_domain) + if (river_data_exist) call SG_to_UG_read_data(fileobj, 'lake_tau', & + buffert(:), lnd%ug_domain, lnd%sg_domain, dimnames) buffer = -1. !where (bufferc.gt.0.5) buffer = lake_width_inside_lake where (bufferc.lt.0.5 .and. buffert.gt.1.) buffer = large_lake_sill_width @@ -387,10 +401,10 @@ subroutine lake_init (id_ug) buffer = 1.e8 if (river_data_exist .and. max_plain_slope.gt.0.) & - call read_data('INPUT/river_data.nc', 'max_slope_to_next', buffer(:), & - lnd%sg_domain, lnd%ug_domain) - if (river_data_exist) call read_data('INPUT/river_data.nc', 'travel', buffert(:), & - lnd%sg_domain, lnd%ug_domain) + call SG_to_UG_read_data(fileobj, 'max_slope_to_next', buffer(:), & + lnd%ug_domain, lnd%sg_domain, dimnames) + if (river_data_exist) call SG_to_UG_read_data(fileobj, 'travel', buffert(:), & + lnd%ug_domain, lnd%sg_domain, dimnames) bufferc = 0. where (buffer.lt.max_plain_slope .and. buffert.gt.1.5) bufferc = 1. call put_to_tiles_r0d_fptr(bufferc, land_tile_map, lake_backwater_ptr) @@ -400,10 +414,10 @@ subroutine lake_init (id_ug) ELSE if (river_data_exist) then - call read_data('INPUT/river_data.nc', 'whole_lake_area', bufferc(:), & - lnd%sg_domain, lnd%ug_domain) - call read_data('INPUT/river_data.nc', 'lake_depth_sill', buffer(:), & - lnd%sg_domain, lnd%ug_domain) + call SG_to_UG_read_data(fileobj, 'whole_lake_area', bufferc(:), & + lnd%ug_domain, lnd%sg_domain, dimnames) + call SG_to_UG_read_data(fileobj, 'lake_depth_sill', buffer(:), & + lnd%ug_domain, lnd%sg_domain, dimnames) endif where (bufferc.eq.0.) buffer = 0. where (bufferc.gt.0..and.bufferc.lt.2.e10) buffer = max(2., 2.5e-4*sqrt(bufferc)) @@ -412,8 +426,8 @@ subroutine lake_init (id_ug) buffer = 4. * buffer where (bufferc.gt.2.e10) buffer = min(buffer, 60.) - if (river_data_exist) call read_data('INPUT/river_data.nc', 'connected_to_next', & - bufferc(:), lnd%sg_domain, lnd%ug_domain) + if (river_data_exist) call SG_to_UG_read_data(fileobj, 'connected_to_next', & + bufferc(:), lnd%ug_domain, lnd%sg_domain, dimnames) call put_to_tiles_r0d_fptr(bufferc, land_tile_map, lake_connected_to_next_ptr) where (bufferc.gt.0.5) buffer=lake_width_inside_lake @@ -422,6 +436,10 @@ subroutine lake_init (id_ug) ENDIF deallocate (buffer, bufferc, buffert) + if (river_data_exist) then + deallocate(dimnames) + call close_file(fileobj) + endif ! -------- initialize lake state -------- ce = first_elmt(land_tile_map) @@ -482,15 +500,15 @@ subroutine save_lake_restart (tile_dim_length, timestamp) call error_mesg('lake_end','writing NetCDF restart',NOTE) ! must set domain so that io_domain is available ! Note that filename is updated for tile & rank numbers during file creation - filename = trim(timestamp)//'lake.res.nc' + filename = 'RESTART/'//trim(timestamp)//'lake.nc' call init_land_restart(restart, filename, lake_tile_exists, tile_dim_length) - call add_restart_axis(restart,'zfull',zfull(1:num_l),'Z','m','full level',sense=-1) + call add_restart_axis(restart,'zfull',zfull(1:num_l),.false.,"Z",'m','full level') ! write out fields - call add_tile_data(restart,'dz', 'zfull', lake_dz_ptr, 'layer thickness','m') - call add_tile_data(restart,'temp', 'zfull', lake_temp_ptr, 'lake temperature','degrees_K') - call add_tile_data(restart,'wl', 'zfull', lake_wl_ptr, 'liquid water content','kg/m2') - call add_tile_data(restart,'ws', 'zfull', lake_ws_ptr, 'solid water content','kg/m2') + call add_tile_data(restart,'dz', 'zfull ', lake_dz_ptr, 'layer thickness','m') + call add_tile_data(restart,'temp', 'zfull ', lake_temp_ptr, 'lake temperature','degrees_K') + call add_tile_data(restart,'wl', 'zfull ', lake_wl_ptr, 'liquid water content','kg/m2') + call add_tile_data(restart,'ws', 'zfull ', lake_ws_ptr, 'solid water content','kg/m2') ! save performs io domain aggregation through mpp_io as with regular domain data call save_land_restart(restart) @@ -1049,7 +1067,7 @@ subroutine lake_diag_init(id_ug) ! ---- local vars integer :: axes(2) - integer :: id_zhalf, id_zfull + integer :: id_zhalf, id_zfull, id_nv ! define vertical axis id_zhalf = diag_axis_init ( & @@ -1057,6 +1075,7 @@ subroutine lake_diag_init(id_ug) id_zfull = diag_axis_init ( & 'zfull_lake', zfull(1:num_l), 'meters', 'z', 'full level', -1, set_name='lake', & edges=id_zhalf ) + id_nv = diag_axis_init('nv', (/1.,2./), 'none', 'N', 'vertex number', set_name='nv') ! define array of axis indices axes = (/id_ug,id_zfull/) @@ -1089,7 +1108,7 @@ subroutine lake_diag_init(id_ug) lnd%time, 'temperature', 'degK', missing_value=-100.0 ) id_K_z = register_tiled_diag_field ( module_name, 'lake_K_z', axes, & lnd%time, 'vertical diffusivity', 'm2/s', missing_value=-100.0 ) - id_evap = register_tiled_diag_field ( module_name, 'lake_evap', axes(1:2), & + id_evap = register_tiled_diag_field ( module_name, 'lake_evap', axes(1:1), & lnd%time, 'lake evap', 'kg/(m2 s)', missing_value=-100.0 ) call add_tiled_static_field_alias (id_silld, module_name, 'sill_depth', & @@ -1208,6 +1227,28 @@ subroutine lake_backwater_1_ptr(tile, ptr) endif end subroutine lake_backwater_1_ptr +subroutine SG_to_UG_read_data(fileobj, varname, UG_data, UG_domain, SG_domain, dimnames) +type(FmsNetcdfDomainFile_t), intent(inout) :: fileobj !< Domain decomposed fileobj +character(len=*), intent(in) :: varname !< Variname name +real, intent(inout) :: UG_data(:) !< Buffer with data on the unstructured grid +type(domainug), intent(in) :: UG_domain !< Unstructured domain +type(domain2d), intent(in) :: SG_domain !< Structured doman +character(len=30), intent(in) :: dimnames(:) !< Array of dimension names for that variable + +integer :: is, ie, js, je +real, allocatable :: SG_data(:,:) + +call mpp_get_compute_domain(SG_domain, is, ie, js, je) +allocate(SG_data(is:ie,js:je)) + +call register_field(fileobj, varname, "double", dimnames) +call read_data(fileobj, varname, SG_data) +call mpp_pass_SG_to_UG(UG_domain, SG_data, UG_data) + +deallocate(SG_data) + +end subroutine SG_to_UG_read_data + end module lake_mod diff --git a/lake/lake_tile.F90 b/lake/lake_tile.F90 index efd537ad..da2c41e7 100644 --- a/lake/lake_tile.F90 +++ b/lake/lake_tile.F90 @@ -22,13 +22,10 @@ module lake_tile_mod use mpp_domains_mod, only : & domain2d, mpp_get_compute_domain, mpp_pass_sg_to_ug -#ifdef INTERNAL_FILE_NML use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif - -use fms_mod, only : file_exist, check_nml_error, read_data, close_file, stdlog +use fms_mod, only: check_nml_error, stdlog +use fms2_io_mod, only: open_file, close_file, read_data, register_axis, register_field, FmsNetcdfDomainFile_t, & + & get_variable_num_dimensions, get_variable_dimension_names use constants_mod, only : PI, tfreeze, hlf use land_constants_mod, only : NBANDS use land_data_mod, only : lnd, log_version @@ -259,31 +256,19 @@ module lake_tile_mod subroutine read_lake_data_namelist(lake_n_lev) integer, intent(out) :: lake_n_lev ! ---- local vars - integer :: unit ! unit for namelist i/o integer :: io ! i/o status for the namelist integer :: ierr ! error code, returned by i/o routines integer :: i real :: z + integer :: logunit call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml=lake_data_nml, iostat=io) - ierr = check_nml_error(io, 'lake_data_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=lake_data_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'lake_data_nml') - enddo -10 continue - call close_file (unit) - endif -#endif - unit=stdlog() - write(unit, nml=lake_data_nml) + read (input_nml_file, nml=lake_data_nml, iostat=io) + ierr = check_nml_error(io, 'lake_data_nml') + + logunit=stdlog() + write(logunit, nml=lake_data_nml) ! initialize global module data here @@ -541,14 +526,24 @@ function lake_cover_cold_start(land_mask, lonb, latb, domain) result (lake_frac) real, pointer :: lake_frac (:,:) ! output: map of lake fractional coverage type(domain2d), intent(in) :: domain real :: lake_frac_sg(lnd%is:lnd%ie,lnd%js:lnd%je) + + character(len=30), allocatable :: dimnames(:) !< Array of dimension names + type(FmsNetcdfDomainFile_t) :: fileobj !< Domain decomposed fileobj + integer :: ndims !< Number of dimensions + allocate( lake_frac(size(land_mask(:)),n_dim_lake_types)) if (trim(lake_to_use)=='from-rivers') then lake_frac = 0.0 - if (file_exist('INPUT/river_data.nc', domain)) then - call read_data('INPUT/river_data.nc', 'lake_frac', lake_frac_sg, & - domain=domain) + if (open_file(fileobj, 'INPUT/river_data.nc', 'read', domain)) then + ndims = get_variable_num_dimensions(fileobj, "lake_frac") + allocate(dimnames(ndims)) + call get_variable_dimension_names(fileobj,"lake_frac" , dimnames) + call register_axis(fileobj, dimnames(1), "x") + call register_axis(fileobj, dimnames(2), "y") + call read_data(fileobj, 'lake_frac', lake_frac_sg) call mpp_pass_sg_to_ug(lnd%ug_domain, lake_frac_sg, lake_frac(:,1)) + call close_file(fileobj) endif ! make sure 'missing values' don't get into the result where (lake_frac < 0) lake_frac = 0 diff --git a/land_chksum.F90 b/land_chksum.F90 new file mode 100644 index 00000000..6a45ca4e --- /dev/null +++ b/land_chksum.F90 @@ -0,0 +1,135 @@ +module land_chksum_mod + +#include + +use iso_fortran_env +use mpp_mod, only : mpp_chksum, mpp_npes, mpp_get_current_pelist +use netcdf, only: NF90_FILL_DOUBLE, NF90_FILL_INT + +implicit none +private + +public :: get_land_chksum + +interface get_land_chksum + module procedure get_land_chksum_is + module procedure get_land_chksum_i0d + module procedure get_land_chksum_i1d + module procedure get_land_chksum_r0d + module procedure get_land_chksum_r1d + module procedure get_land_chksum_r2d +end interface get_land_chksum + +contains + +subroutine get_land_chksum_is(variable_data, chksum) + character(len=32), intent(out) :: chksum !< Checksum value converted to a string + integer, intent(in) :: variable_data !< Input variable data + + integer, allocatable :: all_pe(:) !< Array with the pelist + integer(LONG_KIND) :: chksum_val !< Checksum value + + ! Create a vector of pes + allocate(all_pe(mpp_npes())) + call mpp_get_current_pelist(all_pe) + + chksum_val = variable_data !mpp_chksum(variable_data, all_pe) + + ! Convert to string + chksum = "" + write(chksum, "(Z16)") chksum_val + + deallocate(all_pe) +end subroutine get_land_chksum_is + +subroutine get_land_chksum_i0d(variable_data, chksum) + character(len=32), intent(out) :: chksum + integer, pointer, intent(in) :: variable_data(:) + + integer, allocatable :: all_pe(:) + integer(LONG_KIND) :: chksum_val + + ! Create a vector of pes + allocate(all_pe(mpp_npes())) + call mpp_get_current_pelist(all_pe) + + chksum_val = mpp_chksum(variable_data, all_pe, mask_val=NF90_FILL_INT) + + ! Convert to string + chksum = "" + write(chksum, "(Z16)") chksum_val +end subroutine get_land_chksum_i0d + +subroutine get_land_chksum_i1d(variable_data, chksum) + character(len=32), intent(out) :: chksum + integer, pointer, intent(in) :: variable_data(:,:) + + integer, allocatable :: all_pe(:) + integer(LONG_KIND) :: chksum_val + + ! Create a vector of pes + allocate(all_pe(mpp_npes())) + call mpp_get_current_pelist(all_pe) + + chksum_val = mpp_chksum(variable_data, all_pe, mask_val=NF90_FILL_INT) + + ! Convert to string + chksum = "" + write(chksum, "(Z16)") chksum_val +end subroutine get_land_chksum_i1d + +subroutine get_land_chksum_r0d(variable_data, chksum) + character(len=32), intent(out) :: chksum + real, pointer, intent(in) :: variable_data(:) + + integer, allocatable :: all_pe(:) + integer(LONG_KIND) :: chksum_val + + ! Create a vector of pes + allocate(all_pe(mpp_npes())) + call mpp_get_current_pelist(all_pe) + + chksum_val = mpp_chksum(variable_data, all_pe, mask_val=NF90_FILL_DOUBLE) + + ! Convert to string + chksum = "" + write(chksum, "(Z16)") chksum_val +end subroutine get_land_chksum_r0d + +subroutine get_land_chksum_r1d(variable_data, chksum) + character(len=32), intent(out) :: chksum + real, pointer, intent(in) :: variable_data(:,:) + + integer, allocatable :: all_pe(:) + integer(LONG_KIND) :: chksum_val + + ! Create a vector of pes + allocate(all_pe(mpp_npes())) + call mpp_get_current_pelist(all_pe) + + chksum_val = mpp_chksum(variable_data, all_pe, mask_val=NF90_FILL_DOUBLE) + + ! Convert to string + chksum = "" + write(chksum, "(Z16)") chksum_val +end subroutine get_land_chksum_r1d + +subroutine get_land_chksum_r2d(variable_data, chksum) + character(len=32), intent(out) :: chksum + real, pointer, intent(in) :: variable_data(:,:,:) + + integer, allocatable :: all_pe(:) + integer(LONG_KIND) :: chksum_val + + ! Create a vector of pes + allocate(all_pe(mpp_npes())) + call mpp_get_current_pelist(all_pe) + + chksum_val = mpp_chksum(variable_data, all_pe, mask_val=NF90_FILL_DOUBLE) + + ! Convert to string + chksum = "" + write(chksum, "(Z16)") chksum_val +end subroutine get_land_chksum_r2d + +end module diff --git a/land_data.F90 b/land_data.F90 index 7a3b711d..ace00695 100644 --- a/land_data.F90 +++ b/land_data.F90 @@ -29,14 +29,15 @@ module land_data_mod mpp_get_ug_compute_domain, mpp_get_ug_domain_grid_index, mpp_pass_sg_to_ug, & mpp_pass_ug_to_sg, mpp_get_io_domain_UG_layout use fms_mod , only : write_version_number, mpp_npes, stdout, & - file_exist, error_mesg, FATAL, read_data -use fms_io_mod , only : parse_mask_table + error_mesg, FATAL use time_manager_mod , only : time_type -use grid_mod , only : get_grid_ntiles, get_grid_size, get_grid_cell_vertices, & +use grid2_mod , only : get_grid_ntiles, get_grid_size, get_grid_cell_vertices, & get_grid_cell_centers, get_grid_cell_area, get_grid_comp_area, & define_cube_mosaic use horiz_interp_mod, only : horiz_interp_type, horiz_interp +use fms2_io_mod, only: close_file, file_exists, FmsNetcdfFile_t, open_file, read_data, parse_mask_table + implicit none private @@ -258,7 +259,7 @@ subroutine land_data_init(layout, io_layout, time, dt_fast, dt_slow, mask_table, mask_table_exist = .false. outunit = stdout() - if(file_exist(mask_table)) then + if(file_exists(mask_table)) then mask_table_exist = .true. write(outunit, *) '==> NOTE from land_data_init: reading maskmap information from '//trim(mask_table) if(layout(1) == 0 .OR. layout(2) == 0 ) call error_mesg('land_model_init', & @@ -354,18 +355,23 @@ subroutine set_land_state_ug(npes_io_group, ntiles, nlon, nlat) real, allocatable :: lnd_area(:,:,:) integer :: i, j, n, l, nland, ug_io_layout + type(FmsNetcdfFile_t) :: fileobj + logical :: exists + ! On root pe reading the land_area to decide number of land points. allocate(num_lnd(ntiles)) - if(file_exist('INPUT/land_domain.nc', no_domain=.true.)) then + exists = open_file(fileobj, "INPUT/land_domain.nc", "read") + if (exists) then write(stdout(),*)'set_land_state_ug: reading land information from "INPUT/land_domain.nc" '// & 'to use number of land tiles per grid cell for efficient domain decomposition.' - call read_data('INPUT/land_domain.nc', 'nland_face', num_lnd, no_domain=.true.) + call read_data(fileobj, "nland_face", num_lnd) nland = sum(num_lnd) allocate(grid_index(nland)) allocate(ntiles_grid(nland)) - call read_data('INPUT/land_domain.nc', 'grid_index', grid_index, no_domain=.true.) - call read_data('INPUT/land_domain.nc', 'grid_ntile', ntiles_grid, no_domain=.true.) + call read_data(fileobj, "grid_index", grid_index) + call read_data(fileobj, "grid_ntile", ntiles_grid) + call close_file(fileobj) grid_index = grid_index + 1 else write(stdout(),*)'set_land_state_ug: read land/sea mask from grid file: '// & @@ -415,8 +421,16 @@ subroutine set_land_state_ug(npes_io_group, ntiles, nlon, nlat) ug_io_layout = mpp_get_io_domain_UG_layout(lnd%ug_domain) lnd%append_io_id = (ug_io_layout>1) - ! get the domain information for unstructure domain - call mpp_get_UG_compute_domain(lnd%ug_domain, lnd%ls,lnd%le) + ! get the domain information for unstructured domain. + ! NOTE that lnd%ls is always set to 1. This a work around (apparent) compiler issue, + ! when with multiple openmp threads *and* debug flags Intel compilers (15 and 16) report + ! index errors, as if global land_tile_map array started from 1 instead of lnd%ls + ! + ! This problem does not occur with other compilation flags (e.g. prod, or prod-openmp are + ! both fine). Nevertheless, to address this issue we now start all our lnd%ls:lnd%le + ! arrays at index 1. + lnd%ls = 1 + call mpp_get_UG_compute_domain(lnd%ug_domain, size=lnd%le) !--- get the i,j index of each unstructure grid. allocate(grid_index(lnd%ls:lnd%le)) diff --git a/land_model.F90 b/land_model.F90 index a029cc44..cf9a21fb 100644 --- a/land_model.F90 +++ b/land_model.F90 @@ -30,16 +30,9 @@ module land_model_mod use mpp_domains_mod, only : domain2d, mpp_get_ntile_count, mpp_pass_SG_to_UG, mpp_pass_ug_to_sg, & mpp_get_UG_domain_tile_pe_inf, mpp_get_UG_domain_ntiles -#ifdef INTERNAL_FILE_NML -use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif - -use mpp_mod, only : mpp_max, mpp_sum, mpp_chksum, MPP_FILL_INT, MPP_FILL_DOUBLE -use fms_io_mod, only : restart_file_type, free_restart_type +use mpp_mod, only : mpp_max, mpp_sum, mpp_chksum, MPP_FILL_INT, MPP_FILL_DOUBLE, input_nml_file use fms_mod, only : error_mesg, FATAL, WARNING, NOTE, mpp_pe, & - mpp_root_pe, file_exist, check_nml_error, close_file, & + mpp_root_pe, check_nml_error, & stdlog, stderr, mpp_clock_id, mpp_clock_begin, mpp_clock_end, string, & stdout, CLOCK_FLAG_DEFAULT, CLOCK_COMPONENT, CLOCK_ROUTINE use field_manager_mod, only : MODEL_LAND, MODEL_ATMOS @@ -93,7 +86,7 @@ module land_model_mod use land_numerics_mod, only : ludcmp, lubksb, & horiz_remap_type, horiz_remap_new, horiz_remap, horiz_remap_del, & horiz_remap_print -use land_io_mod, only : read_land_io_namelist, input_buf_size, new_land_io +use land_io_mod, only : read_land_io_namelist, input_buf_size use land_tile_mod, only : land_tile_map, land_tile_type, land_tile_list_type, & land_tile_enum_type, new_land_tile, insert, nitems, & first_elmt, get_tile_tags, land_tile_carbon, land_tile_heat, & @@ -101,11 +94,10 @@ module land_model_mod tile_exists_func, loop_over_tiles use land_data_mod, only : land_data_type, atmos_land_boundary_type, & land_data_init, land_data_end, lnd, log_version -use nf_utils_mod, only : nfu_inq_var, nfu_inq_dim, nfu_get_var use land_tile_io_mod, only: land_restart_type, & init_land_restart, open_land_restart, save_land_restart, free_land_restart, & add_tile_data, add_int_tile_data, get_tile_data, & - field_exists, print_netcdf_error + field_exists use land_tile_diag_mod, only : tile_diag_init, tile_diag_end, & set_default_diag_filter, get_area_id, & register_tiled_diag_field, register_tiled_area_fields, & @@ -129,13 +121,13 @@ module land_model_mod use predefined_tiles_mod, only: land_cover_cold_start_0d_predefined_tiles,& open_database_predefined_tiles,& close_database_predefined_tiles - -use fms_io_mod, only: fms_io_unstructured_read use mpp_domains_mod, only: domainUG use mpp_domains_mod, only: mpp_get_UG_compute_domain use mpp_domains_mod, only: mpp_get_UG_domain_grid_index use diag_axis_mod, only: diag_axis_add_attribute +use fms2_io_mod, only: read_data + implicit none private @@ -300,7 +292,7 @@ module land_model_mod id_vegn_tran_dir, id_vegn_tran_dif, id_vegn_tran_lw, & id_vegn_sctr_dir, & id_subs_refl_dir, id_subs_refl_dif, id_subs_emis, id_grnd_T, & - id_water_cons, id_carbon_cons, id_DOCrunf + id_water_cons, id_carbon_cons, id_DOCrunf, id_snow_subs_T ! diagnostic ids for canopy air tracers (moist mass ratio) integer, allocatable :: id_cana_tr(:) ! diag IDs of CMOR variables @@ -325,10 +317,6 @@ module land_model_mod ! ---- global clock IDs integer :: landClock, landFastClock, landSlowClock -! ==== NetCDF declarations =================================================== -include 'netcdf.inc' -#define __NF_ASRT__(x) call print_netcdf_error((x),__FILE__,__LINE__) - contains @@ -366,7 +354,7 @@ subroutine land_model_init & integer :: ico2_atm ! index of CO2 tracer in the atmos, or NO_TRACER type(land_restart_type) :: restart - character(*), parameter :: restart_file_name='INPUT/land.res.nc' + character(*), parameter :: restart_file_name='INPUT/land.nc' logical :: restart_exists ! IDs of local clocks @@ -387,25 +375,11 @@ subroutine land_model_init & call mpp_clock_begin(landInitClock) ! [2] read land model namelist -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml=land_model_nml, iostat=io) - ierr = check_nml_error(io, 'land_model_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file ( ) - ierr = 1; - do while (ierr /= 0) - read (unit, nml=land_model_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'land_model_nml') - enddo -10 continue - call close_file (unit) - endif -#endif + read (input_nml_file, nml=land_model_nml, iostat=io) + ierr = check_nml_error(io, 'land_model_nml') if (mpp_pe() == mpp_root_pe()) then unit = stdlog() write (unit, nml=land_model_nml) - call close_file (unit) endif ! initialize astronomy, in case it is not initialized, e.g. when using atmos_null @@ -645,18 +619,18 @@ subroutine land_model_restart(timestamp) if(trim(timestamp)/='') timestamp_=trim(timestamp)//'.' endif ! Note that filename is updated for tile & rank numbers during file creation - filename = trim(timestamp_)//'land.res.nc' + filename = 'RESTART/'//trim(timestamp_)//'land.nc' call init_land_restart(restart, filename, land_tile_exists, tile_dim_length) ! [4] write data fields ! write fractions and tile tags - call add_tile_data(restart,'frac',land_frac_ptr,'fractional area of tile') - call add_int_tile_data(restart,'glac',glac_tag_ptr,'tag of glacier tiles') - call add_int_tile_data(restart,'lake',lake_tag_ptr,'tag of lake tiles') - call add_int_tile_data(restart,'soil',soil_tag_ptr,'tag of soil tiles') - call add_int_tile_data(restart,'vegn',vegn_tag_ptr,'tag of vegetation tiles') + call add_tile_data(restart,'frac',land_frac_ptr,'fractional area of tile', units="none") + call add_int_tile_data(restart,'glac',glac_tag_ptr,'tag of glacier tiles', units="none") + call add_int_tile_data(restart,'lake',lake_tag_ptr,'tag of lake tiles', units="none") + call add_int_tile_data(restart,'soil',soil_tag_ptr,'tag of soil tiles', units="none") + call add_int_tile_data(restart,'vegn',vegn_tag_ptr,'tag of vegetation tiles', units="none") ! write the upward long-wave flux - call add_tile_data(restart,'lwup',land_lwup_ptr,'upward long-wave flux') + call add_tile_data(restart,'lwup',land_lwup_ptr,'upward long-wave flux', 'none') ! write energy residuals call add_tile_data(restart,'e_res_1',land_e_res_1_ptr,& 'energy residual in canopy air energy balance equation', 'W/m2') @@ -974,11 +948,7 @@ end subroutine land_cover_cold_start_0d ! ============================================================================ subroutine land_cover_warm_start(restart) type(land_restart_type), intent(in) :: restart - if (new_land_io) then - call land_cover_warm_start_new(restart) - else - call land_cover_warm_start_orig(restart) - endif + call land_cover_warm_start_new(restart) end subroutine land_cover_warm_start ! ============================================================================ @@ -996,11 +966,11 @@ subroutine land_cover_warm_start_new (restart) ntiles = size(restart%tidx) allocate(glac(ntiles), lake(ntiles), soil(ntiles), vegn(ntiles), frac(ntiles)) - call fms_io_unstructured_read(restart%basename, "frac", frac, lnd%ug_domain, timelevel=1) - call fms_io_unstructured_read(restart%basename, "glac", glac, lnd%ug_domain, timelevel=1) - call fms_io_unstructured_read(restart%basename, "lake", lake, lnd%ug_domain, timelevel=1) - call fms_io_unstructured_read(restart%basename, "soil", soil, lnd%ug_domain, timelevel=1) - call fms_io_unstructured_read(restart%basename, "vegn", vegn, lnd%ug_domain, timelevel=1) + call read_data(restart%rhandle, "frac", frac) + call read_data(restart%rhandle, "glac", glac) + call read_data(restart%rhandle, "lake", lake) + call read_data(restart%rhandle, "soil", soil) + call read_data(restart%rhandle, "vegn", vegn) npts = lnd%nlon*lnd%nlat ! create tiles @@ -1019,73 +989,6 @@ subroutine land_cover_warm_start_new (restart) end subroutine land_cover_warm_start_new -! ============================================================================ -! reads the land restart file and restores the tiling structure from this file -subroutine land_cover_warm_start_orig (restart) - type(land_restart_type), intent(in) :: restart - - ! ---- local vars - integer, allocatable :: idx(:) ! compressed tile index - integer, allocatable :: glac(:), lake(:), soil(:), snow(:), cana(:), vegn(:) ! tile tags - real, allocatable :: frac(:) ! fraction of land covered by tile - integer :: ncid ! unit number of the input file - integer :: ntiles ! total number of land tiles in the input file - integer :: bufsize ! size of the input buffer - integer :: dimids(1) ! id of tile dimension - character(NF_MAX_NAME) :: tile_dim_name ! name of the tile dimension and respective variable - integer :: k,it,npts,g,l - type(land_tile_type), pointer :: tile; - integer :: start, count ! slab for reading - ! netcdf variable IDs - integer :: id_idx, id_frac, id_glac, id_lake, id_soil, id_vegn - - __NF_ASRT__(nf_open(restart%filename,NF_NOWRITE,ncid)) - ! allocate the input data - __NF_ASRT__(nfu_inq_var(ncid,'frac',id=id_frac,varsize=ntiles,dimids=dimids)) - ! allocate input buffers for compression index and the variable - bufsize=min(input_buf_size,ntiles) - allocate(idx (bufsize), glac(bufsize), lake(bufsize), soil(bufsize), & - snow(bufsize), cana(bufsize), vegn(bufsize), frac(bufsize) ) - ! get the name of the fist (and only) dimension of the variable 'frac' -- this - ! is supposed to be the compressed dimension, and associated variable will - ! hold the compressed indices - __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),name=tile_dim_name)) - __NF_ASRT__(nfu_inq_var(ncid,tile_dim_name,id=id_idx)) - ! get the IDs of the variables to read - __NF_ASRT__(nfu_inq_var(ncid,'glac',id=id_glac)) - __NF_ASRT__(nfu_inq_var(ncid,'lake',id=id_lake)) - __NF_ASRT__(nfu_inq_var(ncid,'soil',id=id_soil)) - __NF_ASRT__(nfu_inq_var(ncid,'vegn',id=id_vegn)) - - npts = lnd%nlon*lnd%nlat - do start = 1,ntiles,bufsize - count = min(bufsize,ntiles-start+1) - ! read the compressed tile indices - __NF_ASRT__(nf_get_vara_int(ncid,id_idx,(/start/),(/count/),idx)) - ! read input data -- fractions and tags - __NF_ASRT__(nf_get_vara_double(ncid,id_frac,(/start,1/),(/count,1/),frac)) - __NF_ASRT__(nf_get_vara_int(ncid,id_glac,(/start,1/),(/count,1/),glac)) - __NF_ASRT__(nf_get_vara_int(ncid,id_lake,(/start,1/),(/count,1/),lake)) - __NF_ASRT__(nf_get_vara_int(ncid,id_soil,(/start,1/),(/count,1/),soil)) - __NF_ASRT__(nf_get_vara_int(ncid,id_vegn,(/start,1/),(/count,1/),vegn)) - ! create tiles - do it = 1,count - k = idx(it) - if (k<0) cycle ! skip negative indices - g = modulo(k,npts)+1 - if (glnd%ge) cycle ! skip points outside of domain - l = lnd%l_index(g) - ! the size of the tile set at the point (i,j) must be equal to k - tile=>new_land_tile(frac=frac(it),& - glac=glac(it),lake=lake(it),soil=soil(it),vegn=vegn(it)) - call insert(tile,land_tile_map(l)) - enddo - enddo - __NF_ASRT__(nf_close(ncid)) - deallocate(idx, glac, lake, soil, snow, cana, vegn, frac) -end subroutine - - ! ============================================================================ subroutine update_land_model_fast ( cplr2land, land2cplr ) type(atmos_land_boundary_type), intent(in) :: cplr2land @@ -1340,7 +1243,8 @@ subroutine update_land_model_fast_0d(tile, l, k, land2cplr, & ) type (land_tile_type), pointer :: tile type(land_data_type), intent(inout) :: land2cplr - integer, intent(in) :: l,k ! coordinates + integer, intent(in) :: l ! grid cell index in unstructured grid + integer, intent(in) :: k ! tile index with in grid cell real, intent(in) :: & precip_l, precip_s, & ! liquid and solid precipitation, kg/(m2 s) atmos_T, & ! incoming precipitation temperature (despite its name), deg K @@ -2625,7 +2529,7 @@ subroutine update_land_bc_fast (tile, l ,k, land2cplr, is_init) ', face='//trim(string(face))//')',FATAL) endif - call snow_radiation ( tile%snow%T(1), cosz, associated(tile%glac), snow_refl_dir, snow_refl_dif, snow_refl_lw, snow_emis) + call snow_radiation ( tile%snow%T(1), cosz, associated(tile%glac), l, snow_refl_dir, snow_refl_dif, snow_refl_lw, snow_emis) call snow_get_depth_area ( tile%snow, snow_depth, snow_area ) call snow_roughness ( tile%snow, snow_z0s, snow_z0m ) @@ -2786,6 +2690,7 @@ subroutine update_land_bc_fast (tile, l ,k, land2cplr, is_init) call send_tile_data(id_subs_refl_dir, subs_refl_dir, tile%diag) call send_tile_data(id_subs_refl_dif, subs_refl_dif, tile%diag) call send_tile_data(id_grnd_T, land_grnd_T(tile), tile%diag) + call send_tile_data(id_snow_subs_T, snow_subs_T(tile), tile%diag) ! CMOR variables call send_tile_data(id_snd, max(snow_depth,0.0), tile%diag) call send_tile_data(id_snc, snow_area*100, tile%diag) @@ -2860,6 +2765,17 @@ real function land_grnd_T(tile) if (snow_active(tile%snow)) land_grnd_T = tile%snow%T(1) end function land_grnd_T +! ============================================================================ +real function snow_subs_T(tile) + type(land_tile_type), intent(in) :: tile + + if (associated(tile%glac)) snow_subs_T = tile%glac%T(1) + if (associated(tile%lake)) snow_subs_T = tile%lake%T(1) + if (associated(tile%soil)) snow_subs_T = tile%soil%T(1) + + if (snow_active(tile%snow)) snow_subs_T = tile%snow%T(2) +end function snow_subs_T + ! ============================================================================ subroutine Lnd_stock_pe(bnd,index,value) @@ -3412,6 +3328,8 @@ subroutine land_diag_init(clonb, clatb, clon, clat, time, domain, id_band, id_ug 'substrate emissivity for long-wave radiation',missing_value=-1.0) id_grnd_T = register_tiled_diag_field ( module_name, 'Tgrnd', axes, time, & 'ground surface temperature', 'degK', missing_value=-1.0 ) + id_snow_subs_T = register_tiled_diag_field ( module_name, 'T_snow_subs', axes, time, & + 'sub-surface snow temperature', 'degK', missing_value=-1.0 ) id_water_cons = register_tiled_diag_field ( module_name, 'water_cons', axes, time, & 'water non-conservation in update_land_model_fast_0d', 'kg/(m2 s)', missing_value=-1.0 ) diff --git a/land_tracers/land_dust.F90 b/land_tracers/land_dust.F90 index ed962e0b..7de8190d 100644 --- a/land_tracers/land_dust.F90 +++ b/land_tracers/land_dust.F90 @@ -20,17 +20,12 @@ module land_dust_mod #include "../shared/debug.inc" -#ifdef INTERNAL_FILE_NML -use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif - use constants_mod, only: PI, rdgas, GRAV, PSTD_MKS, DENS_H2O use land_constants_mod, only : d608, kBoltz -use fms_mod, only : error_mesg, FATAL, NOTE, file_exist, & - close_file, check_nml_error, mpp_pe, mpp_root_pe, stdlog, stdout, string, lowercase +use fms_mod, only : error_mesg, FATAL, NOTE, & + check_nml_error, mpp_pe, mpp_root_pe, stdlog, stdout, string, lowercase +use mpp_mod, only: input_nml_file use time_manager_mod, only: time_type, time_type_to_real use diag_manager_mod, only : register_static_field, & send_data @@ -50,6 +45,7 @@ module land_dust_mod use land_debug_mod, only : is_watch_point, check_conservation use table_printer_mod +use fms2_io_mod, only: close_file, FmsNetcdfFile_t, open_file implicit none ; private @@ -142,6 +138,8 @@ subroutine land_dust_init (id_ug, mask) character(1024) :: parameters real :: value ! temporary storage for parsing input type(table_printer_type) :: table + type(FmsNetcdfFile_t) :: fileobj + logical :: exists ! log module version call log_version(version, module_name, & @@ -150,21 +148,8 @@ subroutine land_dust_init (id_ug, mask) outunit = stdout() ! read namelist -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml=land_dust_nml, iostat=io) - ierr = check_nml_error(io, 'land_dust_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=land_dust_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'land_dust_nml') - enddo -10 continue - call close_file (unit) - endif -#endif + read (input_nml_file, nml=land_dust_nml, iostat=io) + ierr = check_nml_error(io, 'land_dust_nml') if (mpp_pe() == mpp_root_pe()) then unit = stdlog() write (unit, nml=land_dust_nml) @@ -253,7 +238,12 @@ subroutine land_dust_init (id_ug, mask) ! read dust source field allocate(dust_source(lnd%ls:lnd%le)) - call read_field( input_file_name, input_field_name, dust_source, interp='bilinear' ) + exists = open_file(fileobj, input_file_name, "read") + if (.not. exists) then + call error_mesg("land_dust_init", trim(input_file_name)//" does not exist.", fatal) + endif + call read_field( fileobj, input_field_name, dust_source, interp='bilinear' ) + call close_file(fileobj) ! set the default sub-sampling filter for the fields below call set_default_diag_filter('soil') diff --git a/river/river.F90 b/river/river.F90 index e3392e78..450b47aa 100644 --- a/river/river.F90 +++ b/river/river.F90 @@ -40,25 +40,26 @@ module river_mod ! ! -#ifdef INTERNAL_FILE_NML - use mpp_mod, only: input_nml_file -#else - use fms_mod, only: open_namelist_file -#endif - - use mpp_mod, only : CLOCK_SUBCOMPONENT, CLOCK_ROUTINE + use mpp_mod, only : CLOCK_SUBCOMPONENT, CLOCK_ROUTINE, input_nml_file use mpp_mod, only : mpp_error, FATAL, WARNING, NOTE, stdout, stdlog use mpp_mod, only : mpp_pe, mpp_chksum, mpp_max use mpp_mod, only : mpp_clock_id, mpp_clock_begin, mpp_clock_end, MPP_CLOCK_DETAILED use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, mpp_get_global_domain use mpp_domains_mod, only : mpp_get_data_domain, mpp_update_domains, mpp_get_ntile_count use mpp_domains_mod, only : domainUG, mpp_get_UG_compute_domain, mpp_pass_ug_to_sg - use mpp_domains_mod, only : mpp_pass_sg_to_ug - use fms_mod, only : check_nml_error, string - use fms_mod, only : close_file, file_exist, field_size, read_data, write_data - use fms_mod, only : field_exist, CLOCK_FLAG_DEFAULT - use fms_io_mod, only : get_mosaic_tile_file, get_instance_filename - use fms_io_mod, only : restart_file_type, register_restart_field, restore_state, save_restart, free_restart_type + use mpp_domains_mod, only : mpp_pass_sg_to_ug, mpp_get_tile_id + use fms_mod, only : check_nml_error, string, get_unit + use fms_mod, only : CLOCK_FLAG_DEFAULT, error_mesg + + +!New imports --- + use fms2_io_mod, only: FmsNetcdfDomainFile_t, open_file, register_axis, & + register_restart_field, variable_exists, register_field, & + read_restart, write_restart, close_file, register_variable_attribute, write_data, & + get_global_io_domain_indices, FmsNetcdfFile_t, & + get_variable_size, read_data, get_variable_num_dimensions, unlimited +!------- + use diag_manager_mod, only : diag_axis_init, register_diag_field, register_static_field, send_data, diag_field_add_attribute use time_manager_mod, only : time_type, increment_time, get_time use data_override_mod, only : data_override @@ -74,7 +75,6 @@ module river_mod use field_manager_mod, only: fm_field_name_len, fm_string_len, & fm_type_name_len, fm_path_name_len, fm_dump_list, fm_get_length, & fm_get_current_list, fm_loop_over_list, fm_change_list - use land_io_mod, only : new_land_io use fm_util_mod, only : fm_util_get_real, fm_util_get_logical, fm_util_get_string use tracer_manager_mod, only : NO_TRACER use table_printer_mod @@ -187,6 +187,8 @@ module river_mod end type type(tracer_data_type), allocatable :: trdata(:) ! common tracer data +character(len=8),parameter :: river_res_xdim = "xaxis_1" +character(len=8),parameter :: river_res_ydim = "yaxis_1" contains @@ -212,7 +214,9 @@ subroutine river_init( land_lon, land_lat, time, dt_fast, land_domain, land_UG_d type(Leo_Mad_trios) :: DHG_coef ! downstream equation coefficients type(Leo_Mad_trios) :: AAS_exp ! at-a-station equation exponents - type(restart_file_type) :: river_restart + type(FmsNetcdfDomainFile_t) :: river_restart + logical :: exists + type(FmsNetcdfFile_t) :: river_input riverclock = mpp_clock_id('update_river' , CLOCK_FLAG_DEFAULT, CLOCK_SUBCOMPONENT) slowclock = mpp_clock_id('update_river_slow' , CLOCK_FLAG_DEFAULT, CLOCK_ROUTINE) @@ -221,21 +225,8 @@ subroutine river_init( land_lon, land_lat, time, dt_fast, land_domain, land_UG_d diagclock = mpp_clock_id('river diag' , CLOCK_FLAG_DEFAULT, CLOCK_ROUTINE) !--- read namelist ------------------------------------------------- -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml=river_nml, iostat=io_status) - ierr = check_nml_error(io_status, 'river_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=river_nml, iostat=io_status, end=10) - ierr = check_nml_error(io_status,'river_nml') - enddo -10 continue - call close_file (unit) - endif -#endif + read (input_nml_file, nml=river_nml, iostat=io_status) + ierr = check_nml_error(io_status, 'river_nml') !--- write version and namelist info to logfile -------------------- call log_version(version, module_name, & @@ -357,78 +348,51 @@ subroutine river_init( land_lon, land_lat, time, dt_fast, land_domain, land_UG_d call river_diag_init (id_lon, id_lat) !--- read restart file - call get_instance_filename('INPUT/river.res.nc', filename) - call get_mosaic_tile_file(trim(filename), filename, .false., domain) - - if(file_exist(trim(filename),domain) ) then + filename = 'INPUT/river.nc' + exists = open_file(river_restart, filename, "read", domain, & + is_restart=.true.) + if (exists) then call mpp_error(NOTE, 'river_init : Read restart files '//trim(filename)) - if(new_land_io) then - id_restart = register_restart_field(river_restart,'river.res.nc','storage', River%storage, domain) - id_restart = register_restart_field(river_restart,'river.res.nc','discharge2ocean', discharge2ocean_next, domain) - if (field_exist(filename,'discharge2ocean_c',domain)) then - id_restart = register_restart_field(river_restart,'river.res.nc','discharge2ocean_c',discharge2ocean_next_c, domain) - id_restart = register_restart_field(river_restart,'river.res.nc','storage_c', River%storage_c, domain) - else - do i_species = 1, num_species - if (field_exist(filename,'disch2ocn_'//trdata(i_species)%name,domain)) then - id_restart = register_restart_field(river_restart,'river.res.nc','disch2ocn_'//trdata(i_species)%name, & - discharge2ocean_next_c(:,:,i_species),domain) + call register_axis(river_restart, river_res_xdim, "x") + call register_axis(river_restart, river_res_ydim, "y") + call register_restart_field(river_restart, "storage", river%storage) + call register_restart_field(river_restart, "discharge2ocean", & + discharge2ocean_next) + if (variable_exists(river_restart, "discharge2ocean_c")) then + call register_restart_field(river_restart, "discharge2ocean_c", discharge2ocean_next_c) + call register_restart_field(river_restart, "storage_c", river%storage_c) + else + do i_species = 1, num_species + if (variable_exists(river_restart, "disch2ocn_"//trdata(i_species)%name)) then + call register_restart_field(river_restart, "disch2ocn_"//trdata(i_species)%name, & + discharge2ocean_next_c(:,:,i_species)) else - call mpp_error(WARNING, 'river_init: disch2ocn_'//trim(trdata(i_species)%name)//' does not exist in '//trim(filename)) + call mpp_error(WARNING, "river_init: disch2ocn_"//trim(trdata(i_species)%name)//" does not exist in "//trim(filename)) endif - if (field_exist(filename,'storage_'//trdata(i_species)%name,domain)) then - id_restart = register_restart_field(river_restart,'river.res.nc','storage_'//trdata(i_species)%name, & - River%storage_c(:,:,i_species),domain) + if (variable_exists(river_restart, "storage_"//trdata(i_species)%name)) then + call register_restart_field(river_restart, "storage_"//trdata(i_species)%name, & + river%storage_c(:,:,i_species)) else - call mpp_error(WARNING, 'river_init: storage_'//trim(trdata(i_species)%name)//' does not exist in '//trim(filename)) + call mpp_error(WARNING, "river_init: storage_"//trim(trdata(i_species)%name)//" does not exist in "//trim(filename)) endif - enddo - endif - id_restart = register_restart_field(river_restart,'river.res.nc','Omean', River%outflowmean, domain) - if (field_exist(filename,'depth',domain)) then - id_restart = register_restart_field(river_restart,'river.res.nc','depth', River%depth, domain, mandatory=.false.) - endif - call restore_state(river_restart) - call free_restart_type(river_restart) - else - call read_data(filename,'storage', River%storage, domain) - call read_data(filename,'discharge2ocean', discharge2ocean_next, domain) - if (field_exist(filename,'discharge2ocean_c',domain)) then - call read_data(filename,'discharge2ocean_c',discharge2ocean_next_c, domain) - call read_data(filename,'storage_c', River%storage_c, domain) - else - ! NOTE that the base name of the discharge field was deliberately made - ! different from the name of the older 3D tracer array, to avoid conflicts - ! with a tracer is called "C" - do i_species = 1, num_species - if (field_exist(filename,'disch2ocn_'//trdata(i_species)%name,domain)) then - call read_data(filename,'disch2ocn_'//trdata(i_species)%name,discharge2ocean_next_c(:,:,i_species), domain) - else - call mpp_error(WARNING, 'river_init: disch2ocn_'//trim(trdata(i_species)%name)//' does not exist in '//trim(filename)) - endif - if (field_exist(filename,'storage_'//trdata(i_species)%name,domain)) then - call read_data(filename,'storage_'//trdata(i_species)%name,River%storage_c(:,:,i_species), domain) - else - call mpp_error(WARNING, 'river_init: storage_'//trim(trdata(i_species)%name)//' does not exist in '//trim(filename)) - endif - enddo - endif - call read_data(filename,'Omean', River%outflowmean, domain) - if (field_exist(filename,'depth',domain)) then - ! call mpp_error(WARNING, 'river_init : Reading field "depth" from '//trim(filename)) - call read_data(filename,'depth', River%depth, domain) - else - ! call mpp_error(WARNING, 'river_init : "depth" is not present in '//trim(filename)) - endif + enddo + endif + call register_restart_field(river_restart, "Omean", river%outflowmean) + if (variable_exists(river_restart, "depth")) then + call register_restart_field(river_restart, "depth", river%depth) endif + call read_restart(river_restart) + call close_file(river_restart) else call mpp_error(NOTE, 'river_init : cold start, set data to 0') River%storage = 0.0 River%storage_c = 0.0 discharge2ocean_next = 0.0 discharge2ocean_next_c = 0.0 - if(file_exist(river_Omean_file)) then - call read_data(river_Omean_file, 'Omean', River%outflowmean, domain) + exists = open_file(river_input, river_Omean_file, "read") + if (exists) then + call read_data(river_restart, 'Omean', River%outflowmean) + call close_file(river_input) else River%outflowmean = CONST_OMEAN end if @@ -1042,57 +1006,94 @@ end subroutine river_end subroutine save_river_restart(timestamp) character(*), intent(in) :: timestamp - character(len=128) :: filename - integer :: tr, id_restart - type(restart_file_type) :: river_restart + type(FmsNetcdfDomainFile_t) :: river_restart + logical :: s + integer :: tr + integer :: starting, ending, i - if(.not.do_rivers) return ! do nothing further if rivers are turned off - if(new_land_io) then - id_restart = register_restart_field(river_restart,trim(timestamp)//'river.res.nc','storage', River%storage, domain) - id_restart = register_restart_field(river_restart,trim(timestamp)//'river.res.nc','discharge2ocean', discharge2ocean_next, domain) - do tr = 1, num_species - id_restart = register_restart_field(river_restart,trim(timestamp)//'river.res.nc','storage_'//trdata(tr)%name, & - River%storage_c(:,:,tr),domain) - id_restart = register_restart_field(river_restart,trim(timestamp)//'river.res.nc','disch2ocn_'//trdata(tr)%name, & - discharge2ocean_next_c(:,:,tr),domain) - enddo - id_restart = register_restart_field(river_restart,trim(timestamp)//'river.res.nc','Omean', River%outflowmean, domain) - id_restart = register_restart_field(river_restart,trim(timestamp)//'river.res.nc','depth', River%depth, domain, mandatory=.false.) - call save_restart(river_restart) - call free_restart_type(river_restart) - else + if (.not. do_rivers) return ! do nothing further if rivers are turned off + s = open_file(river_restart, 'RESTART/'//trim(timestamp)//"river.nc", & + "overwrite", domain, is_restart=.true.) - filename = 'RESTART/'//trim(timestamp)//'river.res.nc' + call register_axis(river_restart, river_res_xdim, "x") + call register_axis(river_restart, river_res_ydim, "y") + call register_axis(river_restart, "Time", unlimited) - call write_data(filename,'storage', River%storage(isc:iec,jsc:jec), domain) - call write_data(filename,'discharge2ocean', discharge2ocean_next(isc:iec,jsc:jec), domain) + !< Add the axis as variables so the combiner can work correctly. + call register_field(river_restart, river_res_xdim, "double", (/river_res_xdim/)) + call register_field(river_restart, river_res_ydim, "double", (/river_res_ydim/)) - !--- write out tracer data - do tr = 1, num_species - call write_data(filename,'storage_'//trdata(tr)%name,River%storage_c(isc:iec,jsc:jec,tr), domain) - call write_data(filename,'disch2ocn_'//trdata(tr)%name,discharge2ocean_next_c(isc:iec,jsc:jec,tr), domain) - end do - call write_data(filename,'Omean', River%outflowmean, domain) - call write_data(filename,'depth', River%depth, domain) - endif + call register_restart_field(river_restart, "storage", river%storage, (/river_res_xdim, river_res_ydim, "Time"/)) + call register_restart_field(river_restart, "discharge2ocean", discharge2ocean_next, (/river_res_xdim, river_res_ydim, "Time"/)) + + do tr = 1, num_species + call register_restart_field(river_restart, "storage_"//trdata(tr)%name, river%storage_c(:,:,tr), (/river_res_xdim, river_res_ydim, "Time"/)) + call register_restart_field(river_restart, "disch2ocn_"//trdata(tr)%name, discharge2ocean_next_c(:,:,tr), (/river_res_xdim, river_res_ydim, "Time"/)) + enddo + + call register_restart_field(river_restart, "Omean", river%outflowmean, (/river_res_xdim, river_res_ydim, "Time"/)) + call register_restart_field(river_restart, "depth", river%depth, (/river_res_xdim, river_res_ydim, "Time"/)) + + call write_restart(river_restart) + call add_domain_dimension_data(river_restart) + call close_file(river_restart) end subroutine save_river_restart + + !>@brief Register the axis data as a variable in the netcdf file and add some dummy data. + !! This is needed so the combiner can work correctly when the io_layout is not 1,1 + subroutine add_domain_dimension_data(fileobj) + type(FmsNetcdfDomainFile_t) :: fileobj !< Fms2io domain decomposed fileobj + integer, dimension(:), allocatable :: buffer !< Buffer with axis data + integer :: is, ie !< Starting and Ending indices for data + + call get_global_io_domain_indices(fileobj, "xaxis_1", is, ie, indices=buffer) + call write_data(fileobj, "xaxis_1", buffer) + deallocate(buffer) + + call get_global_io_domain_indices(fileobj, "yaxis_1", is, ie, indices=buffer) + call write_data(fileobj, "yaxis_1", buffer) + deallocate(buffer) + + end subroutine add_domain_dimension_data !##################################################################### subroutine get_river_data(land_lon, land_lat, land_frac) real, intent(in) :: land_lon(isc:,jsc:) ! geographical lontitude of cell center real, intent(in) :: land_lat(isc:,jsc:) ! geographical lattitude of cell center real, intent(in) :: land_frac(isc:,jsc:) ! land area fraction of land grid. - integer :: ni, nj, i, j, siz(4), ntiles + integer :: ni, nj, i, j, ntiles real, dimension(:,:), allocatable :: xt, yt, frac, glon, glat, lake_frac integer :: nerrors ! number of errors detected during initialization + type(FmsNetcdfFile_t) :: fileobj + logical :: exists + integer, dimension(:), allocatable :: siz + integer :: isize, jsize + integer :: ndims, L + integer, dimension(1) :: tile_id + ntiles = mpp_get_ntile_count(domain) + tile_id = mpp_get_tile_id(domain) + + if (ntiles>1) then !If there are more than 1 tile add .tilex. to the name + L = len(trim(river_src_file)) + write(river_src_file, '(a,a,i1,a)') trim(river_src_file(1:L-2)), 'tile', tile_id(1), '.nc' + endif - call field_size(river_src_file, 'basin', siz, domain=domain) + exists = open_file(fileobj, river_src_file, "read") + if (.not. exists) then + call error_mesg("get_river_data", & + "file "//trim(river_src_file)//" does not exist.", & + fatal) + endif + ndims = get_variable_num_dimensions(fileobj, "basin") + allocate(siz(ndims)) + call get_variable_size(fileobj, "basin", siz) ni = siz(1) nj = siz(2) + deallocate(siz) if(ni .NE. River%nlon .OR. nj .NE. River%nlat) call mpp_error(FATAL, & "river_mod: size mismatch between river grid and land grid") @@ -1101,13 +1102,17 @@ subroutine get_river_data(land_lon, land_lat, land_frac) allocate(lake_frac(isc:iec, jsc:jec)) if (ntiles == 1) then - call read_data(river_src_file, 'x', glon, no_domain=.true.) - call read_data(river_src_file, 'y', glat, no_domain=.true.) + call read_data(fileobj, "x", glon) + call read_data(fileobj, "y", glat) endif - call read_data(river_src_file, 'x', xt, domain) - call read_data(river_src_file, 'y', yt, domain) - call read_data(river_src_file, 'land_frac', frac, domain) - call read_data(river_src_file, 'lake_frac', lake_frac, domain) + isize = iec - isc + 1 + jsize = jec - jsc + 1 + call read_data(fileobj, "x", xt, corner=(/isc, jsc/), edge_lengths=(/isize, jsize/)) + call read_data(fileobj, "y", yt, corner=(/isc, jsc/), edge_lengths=(/isize, jsize/)) + call read_data(fileobj, "land_frac", frac, corner=(/isc, jsc/), & + edge_lengths=(/isize, jsize/)) + call read_data(fileobj, "lake_frac", lake_frac, & + corner=(/isc, jsc/), edge_lengths=(/isize, jsize/)) !--- the following will be changed when the river data sets is finalized. xt = land_lon yt = land_lat @@ -1185,7 +1190,8 @@ subroutine get_river_data(land_lon, land_lat, land_frac) River%inflow = 0. River%inflow_c = 0. !--- read the data from the source file - call read_data(river_src_file, 'tocell', River%tocell, domain) + call read_data(fileobj, "tocell", River%tocell, corner=(/isc, jsc/), & + edge_lengths=(/isize, jsize/)) where (River%tocell(:,:).eq. 4) River%tocell(:,:)=3 where (River%tocell(:,:).eq. 8) River%tocell(:,:)=4 @@ -1225,7 +1231,8 @@ subroutine get_river_data(land_lon, land_lat, land_frac) if (nerrors>0.and.stop_on_mask_mismatch) call mpp_error(FATAL,& 'get_river_data: river/land mask-related mismatch detected during river data initialization') - call read_data(river_src_file, 'basin', River%basinid, domain) + call read_data(fileobj, "basin", River%basinid, corner=(/isc, jsc/), & + edge_lengths=(/isize, jsize/)) where (River%basinid >0) River%mask = .true. elsewhere @@ -1233,19 +1240,24 @@ subroutine get_river_data(land_lon, land_lat, land_frac) endwhere River%travel = 0 - call read_data(river_src_file, 'travel', River%travel(isc:iec,jsc:jec), domain) + call read_data(fileobj, "travel", River%travel(isc:iec,jsc:jec), & + corner=(/isc, jsc/), edge_lengths=(/isize, jsize/)) call mpp_update_domains(River%travel, domain) - call read_data(river_src_file, 'celllength', River%reach_length, domain) + call read_data(fileobj, "celllength", River%reach_length, & + corner=(/isc, jsc/), edge_lengths=(/isize, jsize/)) River%reach_length = River%reach_length * River%landfrac * (1.-lake_frac) if (land_area_called_cellarea) then - call read_data(river_src_file, 'cellarea', River%land_area, domain) + call read_data(fileobj, "cellarea", River%land_area, & + corner=(/isc, jsc/), edge_lengths=(/isize, jsize/)) else - call read_data(river_src_file, 'land_area', River%land_area, domain) + call read_data(fileobj, "land_area", River%land_area, & + corner=(/isc, jsc/), edge_lengths=(/isize, jsize/)) endif -! call read_data(river_src_file, 'So', River%So, domain) +! call read_data(fileobj, "So", River%So) River%So = 0.0 where (River%So .LT. 0.0) River%So = Somin + call close_file(fileobj) deallocate(lake_frac) end subroutine get_river_data @@ -1630,15 +1642,12 @@ end module river_mod program river_solo use mpp_mod, only : mpp_error, mpp_pe, mpp_root_pe, mpp_npes, FATAL - use mpp_mod, only : mpp_clock_id, mpp_clock_begin, mpp_clock_end + use mpp_mod, only : mpp_clock_id, mpp_clock_begin, mpp_clock_end, input_nml_file use mpp_domains_mod, only : mpp_define_layout, mpp_define_domains use mpp_domains_mod, only : mpp_get_compute_domain, domain2d, CYCLIC_GLOBAL_DOMAIN use mpp_domains_mod, only : mpp_get_current_ntile, mpp_get_tile_id - use mpp_io_mod, only : mpp_open, MPP_RDONLY, MPP_NETCDF, MPP_SINGLE - use mpp_io_mod, only : MPP_ASCII, MPP_OVERWR, mpp_close - use fms_mod, only : fms_init, fms_end, stdlog, open_namelist_file - use fms_mod, only : check_nml_error, close_file, file_exist, stdout, read_data - use fms_io_mod, only : fms_io_exit + use fms_mod, only : fms_init, fms_end, stdlog + use fms_mod, only : check_nml_error, stdout, get_unit use time_manager_mod, only : time_type, increment_time, set_date, increment_date, set_time use time_manager_mod, only : set_calendar_type, JULIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR use time_manager_mod, only : operator(/), operator(-), operator( + ), month_name, get_date @@ -1650,6 +1659,8 @@ program river_solo use grid_mod, only : define_cube_mosaic, get_grid_ntiles use river_mod, only : num_species + use fms2_io_mod, only: close_file, file_exists, FmsNetcdfFile_t, open_file + implicit none @@ -1709,14 +1720,13 @@ program river_solo call get_date(Time,yr,mon,day,hr,min,sec) if (mpp_pe() == mpp_root_pe()) then - call mpp_open(unit, 'RESTART/river_solo.res',form=MPP_ASCII,& - action=MPP_OVERWR,threading=MPP_SINGLE,fileset=MPP_SINGLE,nohdrs=.true.) + unit = get_unit + open(unit=unit, file="RESTART/river_solo.res", action="write") write(unit,*) yr, mon, day, hr, min, sec write(unit,*) calendar_type - call mpp_close(unit) + close(unit) endif - call fms_io_exit call fms_end @@ -1733,24 +1743,13 @@ subroutine river_solo_init real, allocatable :: area_lnd(:,:), area_lnd_cell(:,:), gfrac(:,:) integer :: date(6) character(len=9) :: month + type(FmsNetcdfFile_t ) :: fileobj + logical :: exists call constants_init -#ifdef INTERNAL_FILE_NML read (input_nml_file, nml=river_solo_nml, iostat=io) ierr = check_nml_error(io, 'river_solo_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file () - ierr=1 - do while (ierr /= 0) - read (unit, nml=river_solo_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'river_solo_nml') - enddo -10 continue - call close_file (unit) - endif -#endif unit=stdlog() write(unit, nml= river_solo_nml) @@ -1771,11 +1770,12 @@ subroutine river_solo_init endif ! get river_solo restart - if (file_exist('INPUT/river_solo.res')) then - call mpp_open(unit,'INPUT/river_solo.res',form=MPP_ASCII,action=MPP_RDONLY) + if (file_exists("INPUT/river_solo.res")) then + unit = get_unit() + open(unit=unit, file="INPUT/river_solo.res", action="read") read(unit,*) date read(unit,*) calendar_type - call close_file(unit) + close(unit) endif call set_calendar_type (calendar_type) @@ -1789,7 +1789,7 @@ subroutine river_solo_init current_date(4),current_date(5),current_date(6)) endif - if (file_exist('INPUT/river_solo.res')) then + if (file_exists('INPUT/river_solo.res')) then Time_start = set_date(date(1),date(2),date(3),date(4),date(5),date(6)) else Time_start = Time_start @@ -1802,16 +1802,16 @@ subroutine river_solo_init Time_step_fast = set_time(dt_fast, 0) num_fast_step = Run_len/Time_step_fast - call mpp_open (unit, 'time_stamp.out', form=MPP_ASCII, action=MPP_OVERWR,threading=MPP_SINGLE) - - month = month_name(current_date(2)) - if ( mpp_pe() == mpp_root_pe() ) write (unit,'(6i4,2x,a3)') date, month(1:3) - - call get_date (Time_end, date(1), date(2), date(3), date(4), date(5), date(6)) - month = month_name(date(2)) - if ( mpp_pe() == mpp_root_pe() ) write (unit,'(6i4,2x,a3)') date, month(1:3) - - call close_file (unit) + if (mpp_pe() .eq. mpp_root_pe()) then + unit = get_unit() + open(unit=unit, file="time_stamp.out", action="write") + month = month_name(current_date(2)) + write (unit,'(6i4,2x,a3)') date, month(1:3) + call get_date (Time_end, date(1), date(2), date(3), date(4), date(5), date(6)) + month = month_name(date(2)) + write (unit,'(6i4,2x,a3)') date, month(1:3) + close(unit) + endif !--- get the land grid and set up domain decomposition call get_grid_size('LND', 1, ni, nj) @@ -1850,14 +1850,13 @@ subroutine river_solo_init allocate(runoff_c(isc:iec,jsc:jec,num_species) ) allocate(runoff(isc:iec,jsc:jec), discharge(isc:iec,jsc:jec) ) - if(file_exist("INPUT/runoff.nc")) then - call read_data("INPUT/runoff.nc", "runoff", runoff ) + exists = open_file(fileobj, "INPUT/runoff.nc", "read") + if (exists) then + call read_data(fileobj, "runoff", runoff) + call read_data(fileobj, "runoff_c", runoff_c) + call close_file(fileobj) else runoff = CONST_RUNOFF - end if - if(file_exist("INPUT/runoff.nc")) then - call read_data("INPUT/runoff.nc", "runoff_c", runoff_c ) - else runoff_c = CONST_RUNOFF end if allocate( discharge2ocean(isc:iec,jsc:jec) ) diff --git a/river/river_physics.F90 b/river/river_physics.F90 index bb0c8d26..370d14cc 100644 --- a/river/river_physics.F90 +++ b/river/river_physics.F90 @@ -20,23 +20,16 @@ module river_physics_mod ! Kirsten Findell ! Zhi Liang -#ifdef INTERNAL_FILE_NML - use mpp_mod, only: input_nml_file -#else - use fms_mod, only: open_namelist_file -#endif - use mpp_mod, only : mpp_sync_self, mpp_send, mpp_recv, EVENT_RECV, EVENT_SEND use mpp_mod, only : mpp_npes, mpp_error, FATAL, mpp_get_current_pelist - use mpp_mod, only : mpp_root_pe, mpp_pe, mpp_max + use mpp_mod, only : mpp_root_pe, mpp_pe, mpp_max, input_nml_file use mpp_mod, only : COMM_TAG_1, COMM_TAG_2, COMM_TAG_3, COMM_TAG_4 use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, mpp_get_data_domain use mpp_domains_mod, only : ZERO, NINETY, MINUS_NINETY, mpp_update_domains use mpp_domains_mod, only : mpp_get_compute_domains use mpp_domains_mod, only : mpp_get_num_overlap, mpp_get_overlap use mpp_domains_mod, only : mpp_get_update_size, mpp_get_update_pelist - use fms_mod, only : stdlog - use fms_mod, only : close_file, check_nml_error, file_exist + use fms_mod, only : check_nml_error, stdlog use diag_manager_mod,only : register_diag_field, send_data use tracer_manager_mod, only : NO_TRACER use river_type_mod, only : river_type, Leo_Mad_trios, NO_RIVER_FLAG @@ -137,21 +130,8 @@ subroutine river_physics_init(River, domain, id_lon, id_lat ) !--- read namelist ------------------------------------------------- -#ifdef INTERNAL_FILE_NML read (input_nml_file, nml=river_physics_nml, iostat=io_status) ierr = check_nml_error(io_status, 'river_physics_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while ( ierr/=0 ) - read (unit, river_physics_nml, iostat=io_status, end=10) - ierr = check_nml_error(io_status,'river_physics_nml') - enddo -10 continue - call close_file (unit) - endif -#endif !--- write version and namelist info to logfile -------------------- call log_version(version, module_name, & diff --git a/shared/land_debug.F90 b/shared/land_debug.F90 index afd3cb30..1db12163 100644 --- a/shared/land_debug.F90 +++ b/shared/land_debug.F90 @@ -18,15 +18,10 @@ !*********************************************************************** module land_debug_mod -#ifdef INTERNAL_FILE_NML -use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif -use mpp_mod, only: mpp_max +use mpp_mod, only: mpp_max, input_nml_file use constants_mod, only: PI -use fms_mod, only: error_mesg, file_exist, check_nml_error, stdlog, & - close_file, mpp_pe, mpp_npes, mpp_root_pe, string, FATAL, WARNING, NOTE +use fms_mod, only: error_mesg, check_nml_error, stdlog, & + mpp_pe, mpp_npes, mpp_root_pe, string, FATAL, WARNING, NOTE use time_manager_mod, only : & time_type, get_date, set_date, operator(<=), operator(>=) use grid_mod, only: get_grid_ntiles @@ -141,31 +136,10 @@ subroutine land_debug_init() call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML read (input_nml_file, nml=land_debug_nml, iostat=io) ierr = check_nml_error(io, 'land_debug_nml') read (input_nml_file, nml=land_conservation_nml, iostat=io) ierr = check_nml_error(io, 'land_conservation_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=land_debug_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'land_debug_nml') - enddo -10 continue - call close_file (unit) - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=land_conservation_nml, iostat=io, end=11) - ierr = check_nml_error (io, 'land_conservation_nml') - enddo -11 continue - call close_file (unit) - endif -#endif if (mpp_pe() == mpp_root_pe()) then unit=stdlog() write(unit, nml=land_debug_nml) diff --git a/shared/land_io.F90 b/shared/land_io.F90 index e1c27a40..090f8e5d 100644 --- a/shared/land_io.F90 +++ b/shared/land_io.F90 @@ -18,33 +18,20 @@ !*********************************************************************** module land_io_mod +use netcdf, only: nf90_max_name use mpp_domains_mod, only : mpp_pass_sg_to_ug - -use mpp_io_mod, only : fieldtype, mpp_get_info, mpp_get_fields, mpp_get_axis_data, & - mpp_read, validtype, mpp_get_atts, MPP_RDONLY, MPP_NETCDF, MPP_MULTI, MPP_SINGLE, & - axistype, mpp_open, mpp_close, mpp_is_valid, mpp_get_file_name, mpp_get_field_index - -use axis_utils_mod, only : get_axis_bounds - use constants_mod, only : PI -use fms_mod, only : file_exist, error_mesg, FATAL, stdlog, mpp_pe, & - mpp_root_pe, string, check_nml_error, close_file - -use mpp_mod, only: mpp_sync -#ifdef INTERNAL_FILE_NML +use fms_mod, only: error_mesg, FATAL, stdlog, mpp_pe, & + mpp_root_pe, string, check_nml_error use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif - - use horiz_interp_mod, only : horiz_interp_type, & horiz_interp_new, horiz_interp_del, horiz_interp - use land_numerics_mod, only : nearest, bisect -use nf_utils_mod, only : nfu_validtype, nfu_get_dim, nfu_get_dim_bounds, & - nfu_get_valid_range, nfu_is_valid, nfu_inq_var, nfu_get_var use land_data_mod, only : log_version, lnd, horiz_interp_ug +use fms2_io_mod, only: close_file, FmsNetcdfFile_t, get_valid, get_variable_attribute, & + get_variable_num_dimensions, get_variable_dimension_names, get_variable_size, & + is_valid, open_file, read_data, Valid_t, variable_att_exists, variable_exists +use axis_utils2_mod, only: axis_edges implicit none private @@ -54,23 +41,14 @@ module land_io_mod public :: read_field public :: read_land_io_namelist -public :: print_netcdf_error - public :: input_buf_size -public :: new_land_io ! ==== end of public interface =============================================== interface read_field module procedure read_field_N_2D, read_field_N_3D - module procedure read_field_I_2D, read_field_I_3D module procedure read_field_N_2D_int, read_field_N_3D_int - module procedure read_field_I_2D_int, read_field_I_3D_int end interface -! ==== NetCDF declarations =================================================== -include 'netcdf.inc' -#define __NF_ASRT__(x) call print_netcdf_error((x),__FILE__,__LINE__) - ! ==== module constants ====================================================== character(len=*), parameter :: module_name = 'land_io_mod' #include "../shared/version_variable.inc" @@ -81,8 +59,7 @@ module land_io_mod logical :: module_is_initialized = .false. character(len=64) :: interp_method = "conservative" integer :: input_buf_size = 65536 ! input buffer size for tile and cohort reading -logical :: new_land_io = .true. -namelist /land_io_nml/ interp_method, input_buf_size, new_land_io +namelist /land_io_nml/ interp_method, input_buf_size contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- @@ -95,25 +72,11 @@ subroutine read_land_io_namelist() call log_version (version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml=land_io_nml, iostat=io) - ierr = check_nml_error(io, 'land_io_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file ( ) - ierr = 1; - do while (ierr /= 0) - read (unit, nml=land_io_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'land_io_nml') - enddo -10 continue - call close_file (unit) - endif -#endif + read (input_nml_file, nml=land_io_nml, iostat=io) + ierr = check_nml_error(io, 'land_io_nml') if (mpp_pe() == mpp_root_pe()) then unit = stdlog() write (unit, nml=land_io_nml) - call close_file (unit) endif if(trim(interp_method) .NE. "conservative" .AND. trim(interp_method) .NE. "conserve_great_circle") then @@ -194,97 +157,74 @@ subroutine read_cover_field(file, cover_field_name, frac_field_name,& integer, optional , intent(in) :: input_cover_types(:) ! --- local vars -! integer :: ncid, varid - integer :: input_unit , ndim , nvar , natt , nrec , iret - type(fieldtype), allocatable, dimension(:) :: fields - type(fieldtype) :: field + type(FmsNetcdfFile_t) :: fileobj + logical :: exists - if (.not.file_exist(file)) call error_mesg(module_name,'input file "'//trim(file)//'" does not exist',FATAL) + exists = open_file(fileobj, trim(file), "read") + if (.not. exists) then + call error_mesg(module_name, 'input file "'//trim(file)//'" does not exist', & + fatal) + endif ! If field named 'cover' does not exist in file then read field named 'frac' ! 'cover' does not exist in either ground_type.nc or cover_type.nc ! The extent of the third dimension is 10 in ground_type.nc and 11 in cover_type.nc - call mpp_open(input_unit, trim(file), action=MPP_RDONLY, form=MPP_NETCDF, & - threading=MPP_MULTI, fileset=MPP_SINGLE, iostat=iret) - call mpp_get_info(input_unit,ndim,nvar,natt,nrec) - allocate(fields(nvar)) - call mpp_get_fields(input_unit,fields) - -! if(nf_inq_varid(ncid,cover_field_name,varid)==NF_NOERR) then -! call do_read_cover_field(ncid,varid,lonb,latb,input_cover_types,frac) -! else if ( nf_inq_varid(ncid,frac_field_name,varid)==NF_NOERR) then -! call do_read_fraction_field(ncid,varid,lonb,latb,input_cover_types,frac) - - if(get_field(fields,cover_field_name,field)==0) then - call do_read_cover_field(input_unit,field,lonb,latb,input_cover_types,frac) - else if ( get_field(fields,frac_field_name,field)==0) then - call do_read_fraction_field(input_unit,field,lonb,latb,input_cover_types,frac) + if (variable_exists(fileobj, cover_field_name)) then + call do_read_cover_field(fileobj, cover_field_name, lonb, latb, input_cover_types, frac) + elseif (variable_exists(fileobj, frac_field_name)) then + call do_read_fraction_field(fileobj, frac_field_name, lonb, latb, input_cover_types, frac) else - call error_mesg(module_name,& - 'neither "'//trim(cover_field_name)//'" nor "'//& - frac_field_name//'" is present in input file "'//trim(file)//'"' ,& - FATAL) + call error_mesg(module_name, & + 'neither "'//trim(cover_field_name)//'" nor "'//& + frac_field_name//'" is present in input file "'//trim(file)//'"' , & + fatal) endif - call mpp_close(input_unit) + call close_file(fileobj) end subroutine read_cover_field ! ============================================================================ -function get_field(fields,field_name,field) - type(fieldtype), intent(in) :: fields(:) - character(len=*), intent(in) :: field_name - type(fieldtype), intent(out) :: field - integer :: get_field, n - character(len=256) :: name_out - - n = mpp_get_field_index(fields,trim(field_name)) - if ( n > 0 ) then - get_field = 0 - field = fields(n) - else - get_field = 1 - endif - -end function get_field - +subroutine do_read_cover_field(fileobj, name, lonb, latb, input_cover_types, frac) -! ============================================================================ -subroutine do_read_cover_field(input_unit, field, lonb, latb, input_cover_types, frac) - integer, intent(in) :: input_unit - type(fieldtype), intent(in) :: field + type(FmsNetcdfFile_t), intent(in) :: fileobj + character(len=*), intent(in) :: name real , intent(in) :: lonb(:,:),latb(:,:) integer, intent(in) :: input_cover_types(:) real , intent(out) :: frac(:,:) ! ---- local vars + integer, dimension(:), allocatable :: dimlens + character(len=nf90_max_name), dimension(:), allocatable :: dimnames + integer :: ndims integer :: nlon, nlat, k integer, allocatable :: in_cover(:,:) real, allocatable :: in_lonb(:), in_latb(:), x(:,:), r_in_cover(:,:) type(horiz_interp_type) :: interp - type(validtype) :: v + type(Valid_t) :: v integer :: in_j_start, in_j_end, in_j_count ! limits of the latitude belt we read - integer :: ndim, dimlens(2) - type(axistype) :: axes_centers(2), axis_bounds integer :: start(4), count(4) - character(len=256) :: name real :: min_in_latb, max_in_latb, y - ! check the field dimensions - call mpp_get_atts(field, ndim=ndim, name=name) - if (ndim.ne.2) call error_mesg('do_read_cover_field',& - 'cover field "'//trim(name)//'" in file "'//trim(mpp_get_file_name(input_unit))// & - '" must be two-dimensional (lon,lat)', FATAL) - - ! get size of the longitude and latitude axes - call mpp_get_atts(field, name=name, siz=dimlens, axes=axes_centers) - nlon = dimlens(1); nlat = dimlens(2) - allocate ( in_lonb(nlon+1), in_latb(nlat+1) ) - - call get_axis_bounds(axes_centers(1), axis_bounds, axes_centers) - call mpp_get_axis_data(axis_bounds, in_lonb) - call get_axis_bounds(axes_centers(2), axis_bounds, axes_centers) - call mpp_get_axis_data(axis_bounds, in_latb) - in_lonb = in_lonb*PI/180; in_latb = in_latb*PI/180 + ! check the field dimenions and get size of the longitude and latitude axes + ndims = get_variable_num_dimensions(fileobj, name) + if (ndims .ne. 2) then + call error_mesg('do_read_cover_field', & + 'cover field "'//trim(name)//'" in file "'//trim(fileobj%path)// & + '" must be two-dimensional (lon,lat)', fatal) + endif + allocate(dimlens(ndims)) + allocate(dimnames(ndims)) + call get_variable_size(fileobj, name, dimlens) + call get_variable_dimension_names(fileobj, name, dimnames) + nlon = dimlens(1) + nlat = dimlens(2) + allocate(in_lonb(nlon+1), in_latb(nlat+1)) + call axis_edges(fileobj, dimnames(1), in_lonb) + in_lonb = in_lonb*PI/180 + call axis_edges(fileobj, dimnames(2), in_latb) + in_latb = in_latb*PI/180 + deallocate(dimlens) + deallocate(dimnames) ! to minimize the i/o and work done by horiz_interp, find the boundaries ! of latitude belt in input data that covers the entire latb array @@ -311,15 +251,15 @@ subroutine do_read_cover_field(input_unit, field, lonb, latb, input_cover_types, ! check for unreasonable values if (in_j_start<1) & call error_mesg('do_read_cover_field','reading field "'//trim(name)//'" from file "'& - //trim(mpp_get_file_name(input_unit))//'" input latitude start index ('& + //trim(fileobj%path)//'" input latitude start index ('& //trim(string(in_j_start))//') is out of bounds', FATAL) if (in_j_count<1) & call error_mesg('do_read_cover_field','reading field "'//trim(name)//'" from file "'& - //trim(mpp_get_file_name(input_unit))//'" computed input latitude count for domain'& + //trim(fileobj%path)//'" computed input latitude count for domain'& //' is not positive, perhaps input data do not cover entire globe', FATAL) if (in_j_start+in_j_count-1>nlat) & call error_mesg('do_read_cover_field','reading field "'//trim(name)//'" from file "'& - //trim(mpp_get_file_name(input_unit))//'input latitude count ('& + //trim(fileobj%path)//'input latitude count ('& //trim(string(in_j_count))//') is too large (start index='& //trim(string(in_j_start))//')', FATAL) @@ -327,20 +267,18 @@ subroutine do_read_cover_field(input_unit, field, lonb, latb, input_cover_types, allocate ( x(nlon,in_j_count), in_cover(nlon,in_j_count), r_in_cover(nlon,in_j_count) ) ! read input data -! iret = nf_get_vara_int(ncid,varid, (/1,in_j_start/), (/nlon,in_j_count/), in_cover) start = (/1,in_j_start,1,1/) count(1:2) = shape(in_cover) count(3:4) = 1 - call mpp_read( input_unit, field, r_in_cover, start, count ) + call read_data(fileobj, name, r_in_cover, corner=start, edge_lengths=count) in_cover = r_in_cover - call mpp_get_atts(field,valid=v) - + v = get_valid(fileobj, name) call horiz_interp_new(interp, in_lonb,in_latb(in_j_start:in_j_start+in_j_count), & lonb,latb, interp_method=trim(interp_method)) frac=0 do k = 1,size(input_cover_types(:)) x=0 - where(mpp_is_valid(r_in_cover,v).and.in_cover==input_cover_types(k)) x = 1 + where(is_valid(r_in_cover,v).and.in_cover==input_cover_types(k)) x = 1 call horiz_interp_ug(interp,x,frac(:,k)) enddo @@ -353,43 +291,50 @@ end subroutine do_read_cover_field ! ============================================================================ - subroutine do_read_fraction_field(input_unit,field,lonb,latb,input_cover_types,frac) - integer, intent(in) :: input_unit - type(fieldtype), intent(in) :: field + subroutine do_read_fraction_field(fileobj, name, lonb, latb, input_cover_types, frac) + + type(FmsNetcdfFile_t), intent(in) :: fileobj + character(len=*), intent(in) :: name real , intent(in) :: lonb(:,:),latb(:,:) integer, intent(in) :: input_cover_types(:) real , intent(out) :: frac(:,:) ! ---- local vars + integer, dimension(:), allocatable :: dimlens + character(len=nf90_max_name), dimension(:), allocatable :: dimnames + integer :: ndims integer :: nlon, nlat, ntypes, k, cover real, allocatable :: in_frac(:,:,:) real, allocatable :: in_lonb(:), in_latb(:) real, allocatable :: in_mask(:,:) type(horiz_interp_type) :: interp - type(validtype) :: v + type(Valid_t) :: v integer :: in_j_end, in_j_start, in_j_count ! limits of the latitude belt we read - integer :: ndim, dimlens(3) - type(axistype) :: axes_centers(3), axis_bounds integer :: start(4), count(4) - character(len=256) :: name real :: min_in_latb, max_in_latb, y - ! check the field dimensions - call mpp_get_atts(field, ndim=ndim, name=name) - if (ndim.ne.3) call error_mesg('do_read_fraction_field', & - 'fraction field "'//trim(name)//'" in file "'//trim(mpp_get_file_name(input_unit))// & - '" must be three-dimensional (lon,lat,_)', FATAL) - - ! get size of the longitude and latitude axes - call mpp_get_atts(field, name=name, siz=dimlens, axes=axes_centers) - nlon = dimlens(1); nlat = dimlens(2) ; ntypes = dimlens(3) - allocate ( in_lonb(nlon+1), in_latb(nlat+1) ) - - call get_axis_bounds(axes_centers(1), axis_bounds, axes_centers) - call mpp_get_axis_data(axis_bounds, in_lonb) - call get_axis_bounds(axes_centers(2), axis_bounds, axes_centers) - call mpp_get_axis_data(axis_bounds, in_latb) - in_lonb = in_lonb*PI/180.0; in_latb = in_latb*PI/180.0 + ! check the field dimenions and get size of the longitude and latitude axes + ndims = get_variable_num_dimensions(fileobj, name) + if (ndims .ne. 3) then + call error_mesg('do_read_cover_field', & + 'cover field "'//trim(name)//'" in file "'//trim(fileobj%path)// & + '" must be two-dimensional (lon,lat,_)', fatal) + endif + allocate(dimlens(ndims)) + allocate(dimnames(ndims)) + call get_variable_size(fileobj, name, dimlens) + call get_variable_dimension_names(fileobj, name, dimnames) + nlon = dimlens(1) + nlat = dimlens(2) + ntypes = dimlens(3) + allocate(in_lonb(nlon+1), in_latb(nlat+1)) + call axis_edges(fileobj, dimnames(1), in_lonb) + in_lonb = in_lonb*PI/180 + call axis_edges(fileobj, dimnames(2), in_latb) + in_latb = in_latb*PI/180 + deallocate(dimlens) + deallocate(dimnames) + ! find the boundaries of latitude belt in input data that covers the ! entire latb array min_in_latb = minval(in_latb); max_in_latb = maxval(in_latb) @@ -415,15 +360,15 @@ subroutine do_read_fraction_field(input_unit,field,lonb,latb,input_cover_types,f ! check for unreasonable values if (in_j_start<1) & call error_mesg('do_read_fraction_field','reading field "'//trim(name)//'" from file "'& - //trim(mpp_get_file_name(input_unit))//'input latitude start index ('& + //trim(fileobj%path)//'input latitude start index ('& //trim(string(in_j_start))//') is out of bounds', FATAL) if (in_j_count<1) & call error_mesg('do_read_fraction_field','reading field "'//trim(name)//'" from file "'& - //trim(mpp_get_file_name(input_unit))//'computed input latitude count for domain'& + //trim(fileobj%path)//'computed input latitude count for domain'& //' is not positive, perhaps input data do not cover entire globe', FATAL) if (in_j_start+in_j_count-1>nlat) & call error_mesg('do_read_fraction_field','reading field "'//trim(name)//'" from file "'& - //trim(mpp_get_file_name(input_unit))//'input latitude count ('& + //trim(fileobj%path)//'input latitude count ('& //trim(string(in_j_count))//') is too large (start index='& //trim(string(in_j_start))//')', FATAL) @@ -434,13 +379,13 @@ subroutine do_read_fraction_field(input_unit,field,lonb,latb,input_cover_types,f start = (/1,in_j_start,1,1/) count(1:3) = shape(in_frac) count(4) = 1 - call mpp_read( input_unit, field, in_frac, start, count ) ! interface called here is mpp_read_region_r3D - call mpp_get_atts(field,valid=v) + call read_data(fileobj, name, in_frac, corner=start, edge_lengths=count) + v = get_valid(fileobj, name) ! Initialize horizontal interpolator; we assume that the valid data mask is ! the same for all levels in input frac array. This is probably a good assumption ! in all cases. - where(mpp_is_valid(in_frac(:,:,1),v)) + where(is_valid(in_frac(:,:,1),v)) in_mask = 1.0 elsewhere in_mask = 0.0 @@ -466,8 +411,8 @@ subroutine do_read_fraction_field(input_unit,field,lonb,latb,input_cover_types,f end subroutine do_read_fraction_field ! ============================================================================ -subroutine read_field_N_2D_int(filename, varname, data_ug, interp, fill) - character(*), intent(in) :: filename +subroutine read_field_N_2D_int(fileobj, varname, data_ug, interp, fill) + type(FmsNetcdfFile_t), intent(in) :: fileobj character(*), intent(in) :: varname integer, intent(out) :: data_ug(:) character(*), intent(in), optional :: interp ! kind of interpolation @@ -479,13 +424,13 @@ subroutine read_field_N_2D_int(filename, varname, data_ug, interp, fill) fill_ = DEFAULT_FILL_INT if (present(fill)) fill_ = fill - call read_field_N_3D(filename, varname, data3, interp, fill_) + call read_field_N_3D(fileobj, varname, data3, interp, fill_) data_ug = nint(data3(:,1)) end subroutine read_field_N_2D_int ! ============================================================================ -subroutine read_field_N_3D_int(filename, varname, data_ug, interp, fill) - character(*), intent(in) :: filename +subroutine read_field_N_3D_int(fileobj, varname, data_ug, interp, fill) + type(FmsNetcdfFile_t), intent(in) :: fileobj character(*), intent(in) :: varname integer, intent(out) :: data_ug(:,:) character(*), intent(in), optional :: interp @@ -497,49 +442,13 @@ subroutine read_field_N_3D_int(filename, varname, data_ug, interp, fill) fill_ = DEFAULT_FILL_INT if (present(fill)) fill_ = fill - call read_field_N_3D(filename, varname, data3, interp, fill_) + call read_field_N_3D(fileobj, varname, data3, interp, fill_) data_ug = nint(data3(:,:)) end subroutine read_field_N_3D_int ! ============================================================================ -subroutine read_field_I_2D_int(ncid, varname, data_ug, interp, fill) - integer, intent(in) :: ncid - character(*), intent(in) :: varname - integer, intent(out) :: data_ug(:) - character(*), intent(in), optional :: interp - integer, intent(in), optional :: fill - ! ---- local vars - real :: data3(size(data_ug,1),1) - real :: fill_ - - fill_ = DEFAULT_FILL_INT - if (present(fill)) fill_ = fill - - call read_field_I_3D(ncid, varname, data3, interp, fill_) - data_ug = nint(data3(:,1)) -end subroutine read_field_I_2D_int - -! ============================================================================ -subroutine read_field_I_3D_int(ncid, varname, data_ug, interp, fill) - integer, intent(in) :: ncid - character(*), intent(in) :: varname - integer, intent(out) :: data_ug(:,:) - character(*), intent(in), optional :: interp - integer, intent(in), optional :: fill - ! ---- local vars - real :: data3(size(data_ug,1),size(data_ug,2)) - real :: fill_ - - fill_ = DEFAULT_FILL_INT - if (present(fill)) fill_ = fill - - call read_field_I_3D(ncid, varname, data3, interp, fill_) - data_ug = nint(data3(:,:)) -end subroutine read_field_I_3D_int - -! ============================================================================ -subroutine read_field_N_2D(filename, varname, data_ug, interp, fill) - character(*), intent(in) :: filename +subroutine read_field_N_2D(fileobj, varname, data_ug, interp, fill) + type(FmsNetcdfFile_t), intent(in) :: fileobj character(*), intent(in) :: varname real, intent(out) :: data_ug(:) character(*), intent(in), optional :: interp @@ -547,59 +456,26 @@ subroutine read_field_N_2D(filename, varname, data_ug, interp, fill) ! ---- local vars real :: data3(size(data_ug,1),1) - call read_field_N_3D(filename, varname, data3, interp, fill) + call read_field_N_3D(fileobj, varname, data3, interp, fill) data_ug = data3(:,1) end subroutine read_field_N_2D ! ============================================================================ -subroutine read_field_N_3D(filename, varname, data_ug, interp, fill) - character(*), intent(in) :: filename - character(*), intent(in) :: varname - real, intent(out) :: data_ug(:,:) - character(*), intent(in), optional :: interp - real, intent(in), optional :: fill - ! ---- local vars - integer :: ierr, input_unit - - ! Files read: biodata.nc, geohydrology.nc, soil_brdf.nc - input_unit = -9999 - call mpp_open(input_unit, trim(filename), action=MPP_RDONLY, form=MPP_NETCDF, & - threading=MPP_MULTI, fileset=MPP_SINGLE, iostat=ierr) - call read_field_I_3D(input_unit, varname, data_ug, interp, fill) - call mpp_sync() - call mpp_close(input_unit) -end subroutine read_field_N_3D - -! ============================================================================ -subroutine read_field_I_2D(ncid, varname, data_ug, interp, fill) - integer, intent(in) :: ncid - character(*), intent(in) :: varname - real, intent(out) :: data_ug(:) - character(*), intent(in), optional :: interp - real, intent(in), optional :: fill - ! ---- local vars - real :: data3(size(data_ug,1),1) - logical :: mask3(size(data_ug,1),1) - - call read_field_I_3D(ncid, varname, data3, interp, fill) - data_ug = data3(:,1) -end subroutine read_field_I_2D - -! ============================================================================ -subroutine read_field_I_3D(input_unit, varname, data_ug, interp, fill) - integer, intent(in) :: input_unit +subroutine read_field_N_3D(fileobj, varname, data_ug, interp, fill) + type(FmsNetcdfFile_t), intent(in) :: fileobj character(*), intent(in) :: varname real, intent(out) :: data_ug(lnd%ls:,:) character(*), intent(in), optional :: interp real, intent(in), optional :: fill - - ! TODO: possibly check the size of the output array - ! ---- local vars - integer :: nlon, nlat, nlev ! size of input grid + character(len=20) :: interp_ + real :: fill_ + integer, dimension(:), allocatable :: dimlens integer :: varndims ! number of variable dimension - integer :: dimlens(1024) ! sizes of respective dimensions + integer :: nlon, nlat, nlev ! size of input grid real, allocatable :: in_lonb(:), in_latb(:), in_lon(:), in_lat(:) + character(len=nf90_max_name), dimension(:), allocatable :: dimnames + type(Valid_t) :: v real, allocatable :: in_data(:,:,:) ! input buffer logical, allocatable :: lmask(:,:,:) ! mask of valid input values real, allocatable :: rmask(:,:,:) ! real mask for interpolator @@ -607,17 +483,9 @@ subroutine read_field_I_3D(input_unit, varname, data_ug, interp, fill) real, allocatable :: omask(:,:) ! mask of valid output data real, allocatable :: data2(:,:) integer :: k,imap,jmap,l - type(validtype) :: v type(horiz_interp_type) :: hinterp integer :: ndim,nvar,natt,nrec - type(axistype), allocatable :: varaxes(:) - type(axistype):: axis_bnd - type(fieldtype), allocatable :: fields(:) - type(fieldtype) :: fld - character(len=256) :: file_name integer :: jstart, jend - character(len=20) :: interp_ - real :: fill_ interp_ = 'bilinear' if(present(interp)) interp_ = interp @@ -625,55 +493,53 @@ subroutine read_field_I_3D(input_unit, varname, data_ug, interp, fill) fill_ = DEFAULT_FILL_REAL if (present(fill)) fill_=fill - ! find the field in the file - call mpp_get_info(input_unit,ndim,nvar,natt,nrec) - file_name = mpp_get_file_name(input_unit) - allocate(fields(nvar)) - call mpp_get_fields(input_unit, fields) - k = mpp_get_field_index(fields,trim(varname)) - if(k > 0) then - fld = fields(k) - else - call error_mesg('read_field','variable "'//trim(varname)//'" not found in file "'//trim(file_name)//'"',FATAL) + if (.not. variable_exists(fileobj, varname)) then + call error_mesg('read_field', & + 'variable "'//trim(varname)//'" not found in file "'//trim(fileobj%path)//'"', & + FATAL) endif ! get the dimensions of our variable - call mpp_get_atts(fld, ndim=varndims, siz=dimlens, valid=v) - if(varndims<2.or.varndims>3) then - call error_mesg('read_field','variable "'//trim(varname)//'" in file "'//trim(file_name)//& + varndims = get_variable_num_dimensions(fileobj, varname) + if (varndims .lt. 2 .or. varndims .gt. 3) then + call error_mesg('read_field','variable "'//trim(varname)//'" in file "'//trim(fileobj%path)// & '" is '//string(varndims)//'D, but only reading 2D or 3D variables is supported', FATAL) endif - allocate(varaxes(varndims)) - call mpp_get_atts(fld, axes=varaxes) + allocate(dimlens(varndims)) + call get_variable_size(fileobj, varname, dimlens) nlon = dimlens(1) ; nlat = dimlens(2) nlev = 1; if (varndims==3) nlev=dimlens(3) if(nlev/=size(data_ug,2)) then call error_mesg('read_field','3rd dimension length of the variable "'& - //trim(varname)//'" ('//trim(string(nlev))//') in file "'//trim(file_name)//& + //trim(varname)//'" ('//trim(string(nlev))//') in file "'//trim(fileobj%path)//& '" is different from the expected size of data ('// trim(string(size(data_ug,2)))//')', & FATAL) endif + deallocate(dimlens) + v = get_valid(fileobj, varname) + ! read boundaries of the grid cells in longitudinal direction allocate (in_lon (nlon), in_lat (nlat), & in_lonb (nlon+1), in_latb (nlat+1) ) - - ! read boundaries of the grid cells in longitudinal direction - call mpp_get_axis_data(varaxes(1), in_lon) - call mpp_get_axis_data(varaxes(2), in_lat) - in_lon = in_lon*PI/180.0; in_lat = in_lat*PI/180.0 - call get_axis_bounds(varaxes(1), axis_bnd, varaxes) - call mpp_get_axis_data(axis_bnd, in_lonb) - call get_axis_bounds(varaxes(2), axis_bnd, varaxes) - call mpp_get_axis_data(axis_bnd, in_latb) - in_lonb = in_lonb*PI/180.0; in_latb = in_latb*PI/180.0 + allocate(dimnames(varndims)) + call get_variable_dimension_names(fileobj, varname, dimnames) + call read_data(fileobj, dimnames(1), in_lon) + in_lon = in_lon*PI/180 + call axis_edges(fileobj, dimnames(1), in_lonb) + in_lonb = in_lonb*PI/180 + call read_data(fileobj, dimnames(2), in_lat) + in_lat = in_lat*PI/180 + call axis_edges(fileobj, dimnames(2), in_latb) + in_latb = in_latb*PI/180 + deallocate(dimnames) select case(trim(interp_)) case('nearest') allocate (in_data(nlon, nlat, nlev), lmask(nlon, nlat, nlev)) ! read input data. In case of nearest interpolation we need global fields. - call mpp_read(input_unit, fld, in_data) - lmask = mpp_is_valid(in_data,v) + call read_data(fileobj, varname, in_data) + lmask = is_valid(in_data,v) do k = 1,size(data_ug,2) do l = lnd%ls,lnd%le call nearest (lmask(:,:,k), in_lon, in_lat, lnd%ug_lon(l), lnd%ug_lat(l), imap, jmap) @@ -722,7 +588,6 @@ subroutine read_field_I_3D(input_unit, varname, data_ug, interp, fill) end select deallocate(in_lonb, in_latb, in_lon, in_lat) - deallocate(varaxes, fields) contains ! internal subroutines @@ -737,8 +602,8 @@ subroutine read_input start(3) = 1; count(3) = nlev start(4:) = 1; count(4:) = 1 ! read input data - call mpp_read(input_unit, fld, in_data, start, count) - where (mpp_is_valid(in_data,v)) + call read_data(fileobj, varname, in_data, corner=start, edge_lengths=count) + where (is_valid(in_data,v)) rmask = 1.0 elsewhere rmask = 0.0 @@ -776,23 +641,6 @@ subroutine jlimits(minlat, maxlat, in_lat, jstart, jend) jend = min(jend+1,nlat) end subroutine jlimits -end subroutine read_field_I_3D - -! ============================================================================ -subroutine print_netcdf_error(ierr, file, line) - ! prints out NetCDF library error message, including file name and line number - integer, intent(in) :: ierr ! error code - character(len=*), intent(in) :: file ! name of the file - integer, intent(in) :: line ! number of line in the file - - ! ---- local vars - character(len=1024) :: mesg - - if (ierr.ne.NF_NOERR) then - write(mesg, "('File ',a,' Line ',i4.4,' :: ',a)") & - trim(file),line,trim(NF_STRERROR(ierr)) - call error_mesg('NetCDF', mesg, FATAL) - endif -end subroutine print_netcdf_error +end subroutine read_field_N_3D end module diff --git a/shared/land_tile_io.F90 b/shared/land_tile_io.F90 index 4205241c..693db1c2 100644 --- a/shared/land_tile_io.F90 +++ b/shared/land_tile_io.F90 @@ -18,30 +18,20 @@ !*********************************************************************** module land_tile_io_mod -#ifdef INTERNAL_FILE_NML -use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif - -use mpp_mod, only : mpp_send, mpp_recv, mpp_sync, & - COMM_TAG_1, COMM_TAG_2, COMM_TAG_3, COMM_TAG_4, & - COMM_TAG_5, COMM_TAG_6, COMM_TAG_7, COMM_TAG_8, & - COMM_TAG_9, COMM_TAG_10 -use fms_mod, only : error_mesg, FATAL, NOTE, mpp_pe, get_mosaic_tile_file -use fms_io_mod, only : & - restart_file_type, free_restart_type, get_instance_filename, read_data, & - fms_io_unstructured_save_restart, fms_io_unstructured_register_restart_axis, & - fms_io_unstructured_register_restart_field, CIDX,ZIDX,CCIDX, & - fms_io_unstructured_get_field_size, fms_io_unstructured_read, & - fms_io_unstructured_field_exist +use netcdf, only: NF90_MAX_NAME, NF90_FILL_DOUBLE, NF90_FILL_INT +use fms_mod, only : error_mesg, FATAL, mpp_pe + +use fms2_io_mod, only: FmsNetcdfUnstructuredDomainFile_t, get_instance_filename, & + register_axis, register_field,unlimited, & + register_variable_attribute, write_restart, & + close_file, variable_exists, get_variable_size, & + read_data, write_data, open_file, get_dimension_size, & + get_variable_num_dimensions, compressed_start_and_count use time_manager_mod, only : time_type use data_override_mod, only : data_override_ug use mpp_domains_mod, only : mpp_pass_SG_to_UG -use nf_utils_mod, only : nfu_inq_dim, nfu_inq_var, nfu_def_dim, nfu_def_var, & - nfu_get_var, nfu_put_var, nfu_put_att -use land_io_mod, only : print_netcdf_error, read_field, input_buf_size, new_land_io +use land_io_mod, only : read_field, input_buf_size use land_tile_mod, only : land_tile_type, land_tile_list_type, land_tile_enum_type, & first_elmt, loop_over_tiles, & tile_exists_func, fptr_i0, fptr_i0i, fptr_r0, fptr_r0i, fptr_r0ij, fptr_r0ijk, & @@ -49,7 +39,7 @@ module land_tile_io_mod use land_data_mod, only : lnd use land_utils_mod, only : put_to_tiles_r0d_fptr - +use land_chksum_mod implicit none private @@ -71,11 +61,9 @@ module land_tile_io_mod ! auxiliary subroutines public :: get_tile_by_idx -public :: print_netcdf_error ! ==== end of public interfaces ============================================== interface create_tile_out_file - module procedure create_tile_out_file_idx_old module procedure create_tile_out_file_idx_new end interface @@ -127,12 +115,11 @@ module land_tile_io_mod end type axis ! land restart type encapsulates the data needed for the land restarts type land_restart_type - type(restart_file_type) :: rhandle ! fms_io restart file data type + type(FmsNetcdfUnstructuredDomainFile_t) :: rhandle ! fms_io restart file data type logical :: should_free_rhandle = .FALSE. character(267) :: basename ='' ! name of the restart file character(267) :: filename ='' ! name of the restart file after adding PE number and such - integer :: ncid = -1 ! netcdf id, used only for old land io integer, allocatable :: tidx(:) ! tile index integer, allocatable :: cidx(:) ! vegetation cohort index integer :: tile_dim_length = -1! length of tile dimension @@ -142,10 +129,6 @@ module land_tile_io_mod type(axis) :: ax(5) end type land_restart_type -! ==== NetCDF declarations =================================================== -include 'netcdf.inc' -#define __NF_ASRT__(x) call print_netcdf_error((x),module_name,__LINE__) - contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- ! ============================================================================== @@ -165,14 +148,9 @@ subroutine init_land_restart(restart,filename,tile_exists,tile_dim_length) ! allocate and fill tile compression index call gather_tile_index(tile_exists,restart%tidx) - if (new_land_io) then - call create_tile_out_file_idx_new(restart%rhandle,restart%basename,restart%tidx, & - restart%tile_dim_length) - restart%should_free_rhandle = .TRUE. - else - call create_tile_out_file_idx_old(restart%ncid,'RESTART/'//trim(restart%basename), & - restart%tidx, restart%tile_dim_length, lnd%coord_glon, lnd%coord_glat) - endif + call create_tile_out_file_idx_new(restart%rhandle,restart%basename,restart%tidx, & + restart%tile_dim_length) + restart%should_free_rhandle = .TRUE. end subroutine init_land_restart ! ============================================================================== @@ -182,54 +160,56 @@ subroutine open_land_restart(restart,filename,restart_exists) logical, intent(out) :: restart_exists ! ---- local vars - integer :: flen(4) ! length of the index - logical :: found ! true if field exists - integer :: ierr + integer,dimension(:),allocatable :: flen ! length of the index + integer :: ndims restart%basename = filename - call get_input_restart_name(restart%basename,restart_exists,restart%filename) - if (.not.restart_exists) return - - if (new_land_io) then - !Get the size of the tile dimension from the file. - call fms_io_unstructured_get_field_size(filename, "tile", flen, lnd%ug_domain, & - field_found=found) - if (.not. found) then - call error_mesg("open_land_restart", "dimension 'tile' not found in file '" & - //trim(filename)//"'.", FATAL) - endif - restart%tile_dim_length = flen(1) - - !Get the size of the tile index dimension from the file. - call fms_io_unstructured_get_field_size(filename, "tile_index", flen, lnd%ug_domain, & - field_found=found) - if (.not. found) then - call error_mesg("open_land_restart", "'tile_index' not found in file '" & - //trim(filename)//"'.", FATAL) - endif - allocate(restart%tidx(flen(1))) - - ! Read in the tile_index field from the file. - call fms_io_unstructured_read(filename, "tile_index", restart%tidx, lnd%ug_domain, & - timelevel=1) - - ! Get the size of the cohort_index dimension from the file. - call fms_io_unstructured_get_field_size(restart%basename, "cohort_index", flen, & - lnd%ug_domain, field_found=found) - if (found) then - ! Read in the cohort_index field from the file. - allocate(restart%cidx(flen(1))) - call fms_io_unstructured_read(restart%basename, "cohort_index", restart%cidx, & - lnd%ug_domain, timelevel=1) - endif - ! TODO: possibly make tile index and cohort index names parameters in this module - ! just constants, no sense to make them namelists vars - else ! old i/o - __NF_ASRT__(nf_open(restart%filename,NF_NOWRITE,restart%ncid)) - ierr = nfu_inq_dim(restart%ncid,'tile',len=restart%tile_dim_length) - if (ierr/=NF_NOERR) call error_mesg('open_land_restart', & - 'dimension "tile" not found in file "'//trim(filename)//'"', FATAL) + restart_exists = open_file(restart%rhandle, restart%basename, "read", & + lnd%ug_domain, is_restart=.true.) + if (.not. restart_exists) return + + !Get the size of the tile dimension from the file. + if (.not. field_exists(restart, "tile")) then !This checks if the file has a variable called "tile" + !Check if the file has a dimension called "tile" + allocate(flen(1)) + call get_dimension_size(restart%rhandle, "tile", flen(1)) + restart%tile_dim_length = flen(1) + deallocate(flen) + else + ndims = get_variable_num_dimensions(restart%rhandle, "tile") + allocate(flen(ndims)) + call get_variable_size(restart%rhandle, "tile", flen) + restart%tile_dim_length = flen(1) + deallocate(flen) + endif + + !Get the size of the tile index dimension from the file. + if (.not. field_exists(restart, "tile_index")) then + call error_mesg("open_land_restart", "'tile_index' not found in file '" & + //trim(filename)//"'.", FATAL) + endif + ndims = get_variable_num_dimensions(restart%rhandle, "tile_index") + allocate(flen(ndims)) + call get_variable_size(restart%rhandle, "tile_index", flen) + allocate(restart%tidx(flen(1))) + deallocate(flen) + + !Read in the tile_index field from the file. + call read_data(restart%rhandle, "tile_index", restart%tidx) + + !Get the size of the cohort_index dimension from the file. + if (field_exists(restart, "cohort_index")) then + ndims = get_variable_num_dimensions(restart%rhandle, "cohort_index") + allocate(flen(ndims)) + call get_variable_size(restart%rhandle, "cohort_index", flen) + + !Read in the cohort_index field from the file. + allocate(restart%cidx(flen(1))) + deallocate(flen) + call read_data(restart%rhandle, "cohort_index", restart%cidx) endif + ! TODO: possibly make tile index and cohort index names parameters in this module + ! just constants, no sense to make them namelists vars end subroutine open_land_restart ! ============================================================================== @@ -237,7 +217,7 @@ subroutine save_land_restart(restart) type(land_restart_type), intent(inout) :: restart if (restart%should_free_rhandle) then - call fms_io_unstructured_save_restart(restart%rhandle) + call write_restart(restart%rhandle) endif end subroutine save_land_restart @@ -246,12 +226,8 @@ end subroutine save_land_restart subroutine free_land_restart(restart) type(land_restart_type), intent(inout) :: restart - if (restart%should_free_rhandle) call free_restart_type(restart%rhandle) + if (restart%should_free_rhandle) call close_file(restart%rhandle) restart%should_free_rhandle = .FALSE. - if (restart%ncid>0) then - __NF_ASRT__(nf_close(restart%ncid)) - restart%ncid = -1 - endif restart%basename = '' restart%filename = '' if (allocated(restart%tidx)) deallocate(restart%tidx) @@ -260,33 +236,45 @@ subroutine free_land_restart(restart) end subroutine free_land_restart ! ============================================================================== -subroutine add_restart_axis(restart,name,data,cartesian,units,longname,sense) +subroutine add_restart_axis(restart,name,data,is_unstructured,cartesian,units,longname,sense) type(land_restart_type), intent(inout) :: restart character(len=*), intent(in) :: name real, intent(in) :: data(:) - character(len=*), intent(in) :: cartesian + logical, intent(in) :: is_unstructured + character(len=1), optional, intent(in) :: cartesian character(len=*), optional, intent(in) :: units, longname integer, optional, intent(in) :: sense - ! how to get rid of "cartesian" attribute? In some cases (carbon cohort) it is far from obvious what it should be. integer :: n real, pointer :: data_(:) - if (new_land_io) then - allocate(data_(size(data))) - data_(:) = data(:) - call fms_io_unstructured_register_restart_axis(restart%rhandle, restart%basename, & - name, data_, cartesian, lnd%ug_domain, units=units, longname=longname, sense=sense) + allocate(data_(size(data))) + data_(:) = data(:) + if (is_unstructured) then + call register_axis(restart%rhandle, name) else - if (mpp_pe()==lnd%io_pelist(1)) then - __NF_ASRT__(nfu_def_dim(restart%ncid,name,data(:),longname,units)) - if (present(sense)) then - if (sense<0) then - __NF_ASRT__(nfu_put_att(restart%ncid,name,'positive','down')) - endif - endif - endif + call register_axis(restart%rhandle, name, size(data)) + endif + call register_field(restart%rhandle, name, "double", (/name/)) + if (present(cartesian)) then + call register_variable_attribute(restart%rhandle, name, "cartesian_axis", trim(cartesian), str_len=len(trim(cartesian))) + endif + if (present(units)) then + call register_variable_attribute(restart%rhandle, name, "units", trim(units), str_len=len(trim(units))) endif + if (present(longname)) then + call register_variable_attribute(restart%rhandle, name, "long_name", trim(longname), str_len=len(trim(longname))) + endif + if (present(sense)) then + if (sense .eq. -1) then + call register_variable_attribute(restart%rhandle, name, "positive", "down", str_len=len(trim("down"))) + else + call register_variable_attribute(restart%rhandle, name, "positive", "up", str_len=len(trim("up"))) + endif + endif + call write_data(restart%rhandle,name,data_) + deallocate(data_) + ! record dimension information for future use n = restart%nax+1; restart%nax = n restart%ax(n)%name = name @@ -298,12 +286,7 @@ logical function field_exists(restart,name) type(land_restart_type), intent(in) :: restart character(len=*), intent(in) :: name - if (new_land_io) then - field_exists = fms_io_unstructured_field_exist(restart%basename, name, & - domain=lnd%ug_domain) - else - field_exists = (nfu_inq_var(restart%ncid,trim(name))==NF_NOERR) - endif + field_exists = variable_exists(restart%rhandle, name) end function field_exists ! ============================================================================== @@ -312,21 +295,20 @@ subroutine add_scalar_data(restart,varname,datum,longname,units) character(len=*), intent(in) :: varname ! name of the variable to write integer, intent(in) :: datum character(len=*), intent(in), optional :: units, longname + character(len=32) :: chksum - integer :: id_restart, ierr - - if (new_land_io) then - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, & - restart%basename, varname, datum, lnd%ug_domain, longname=longname, & - units=units) - else - if(mpp_pe()==lnd%io_pelist(1)) then - ierr = nf_redef(restart%ncid) - __NF_ASRT__(nfu_def_var(restart%ncid,varname,NF_INT,long_name=longname,units=units)) - ierr = nf_enddef(restart%ncid) - __NF_ASRT__(nfu_put_var(restart%ncid,varname,datum)) - end if + call register_field(restart%rhandle, varname, "int") + call register_variable_attribute(restart%rhandle, varname, "_FillValue", NF90_FILL_INT) + if (present(longname)) then + call register_variable_attribute(restart%rhandle, varname, "long_name", trim(longname), str_len=len(trim(longname))) + endif + if (present(units)) then + call register_variable_attribute(restart%rhandle, varname, "units", trim(units), str_len=len(trim(units))) endif + + call get_land_chksum(datum,chksum) + call register_variable_attribute(restart%rhandle, varname, "checksum", trim(chksum), str_len=len(trim(chksum))) + call write_data(restart%rhandle, varname, datum) end subroutine add_scalar_data subroutine add_text_data(restart,varname,dim1,dim2,datum,longname) @@ -337,19 +319,9 @@ subroutine add_text_data(restart,varname,dim1,dim2,datum,longname) character(len=*), intent(in), optional :: longname integer :: id_restart, ierr - character(NF_MAX_NAME)::dimnames(2) + character(NF90_MAX_NAME)::dimnames(2) - if (new_land_io) then - call error_mesg('add_text_data','does not work with new io yet', FATAL) - else - if(mpp_pe()==lnd%io_pelist(1)) then - ierr = nf_redef(restart%ncid) - dimnames(1) = dim1; dimnames(2) = dim2 - __NF_ASRT__(nfu_def_var(restart%ncid,varname,NF_CHAR,dimnames,long_name=longname)) - ierr = nf_enddef(restart%ncid) - __NF_ASRT__(nfu_put_var(restart%ncid,varname,datum)) - end if - endif + call error_mesg('add_text_data','does not work with new io yet', FATAL) end subroutine add_text_data subroutine add_tile_data_i0d_fptr_i0(restart,varname,fptr,longname,units) @@ -357,22 +329,27 @@ subroutine add_tile_data_i0d_fptr_i0(restart,varname,fptr,longname,units) character(len=*), intent(in) :: varname ! name of the variable to write procedure(fptr_i0) :: fptr ! subroutine returning pointer to the data character(len=*), intent(in), optional :: units, longname + character(len=32) :: chksum - integer :: id_restart integer, pointer :: data(:) if (.not.allocated(restart%tidx)) call error_mesg('add_tile_data_r0d_fptr_r0', & 'tidx not allocated: looks like land restart was not initialized',FATAL) allocate(data(size(restart%tidx))) call gather_tile_data_i0d(fptr,restart%tidx,data) - if (new_land_io) then - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, restart%basename, & - varname, data, (/CIDX/), lnd%ug_domain, longname=longname, units=units, & - restart_owns_data=.true.) - else ! old land io - call write_tile_data_i1d(restart%ncid,varname,data,longname,units) - deallocate(data) + call register_field(restart%rhandle, varname, "int", (/"tile_index"/)) + call register_variable_attribute(restart%rhandle, varname, "_FillValue", NF90_FILL_INT) + if (present(longname)) then + call register_variable_attribute(restart%rhandle, varname, "long_name", trim(longname), str_len=len(trim(longname))) endif + if (present(units)) then + call register_variable_attribute(restart%rhandle, varname, "units", trim(units), str_len=len(trim(units))) + endif + + call get_land_chksum(data,chksum) + call register_variable_attribute(restart%rhandle, varname, "checksum", trim(chksum), str_len=len(trim(chksum))) + call write_data(restart%rhandle, varname, data) + deallocate(data) end subroutine add_tile_data_i0d_fptr_i0 subroutine add_tile_data_r0d_fptr_r0(restart,varname,fptr,longname,units) @@ -380,22 +357,28 @@ subroutine add_tile_data_r0d_fptr_r0(restart,varname,fptr,longname,units) character(len=*), intent(in) :: varname ! name of the variable to write procedure(fptr_r0) :: fptr ! subroutine returning pointer to the data character(len=*), intent(in), optional :: units, longname + character(len=32) :: chksum - integer :: id_restart real, pointer :: data(:) - + if (.not.allocated(restart%tidx)) call error_mesg('add_tile_data_r0d_fptr_r0', & 'tidx not allocated: looks like land restart was not initialized',FATAL) allocate(data(size(restart%tidx))) call gather_tile_data_r0d(fptr,restart%tidx,data) - if (new_land_io) then - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, restart%basename, & - varname, data, (/CIDX/), lnd%ug_domain, longname=longname, units=units, & - restart_owns_data=.true.) - else ! old land io - call write_tile_data_r1d(restart%ncid,varname,data,longname,units) - deallocate(data) + call register_field(restart%rhandle, varname, "double", (/"tile_index"/)) + call register_variable_attribute(restart%rhandle, varname, "_FillValue", NF90_FILL_DOUBLE) + if (present(longname)) then + call register_variable_attribute(restart%rhandle, varname, "long_name", trim(longname), str_len=len(trim(longname))) + endif + if (present(units)) then + call register_variable_attribute(restart%rhandle, varname, "units", trim(units), str_len=len(trim(units))) endif + + call get_land_chksum(data,chksum) + call register_variable_attribute(restart%rhandle, varname, "checksum", trim(chksum), str_len=len(trim(chksum))) + call write_data(restart%rhandle, varname, data) + + deallocate(data) end subroutine add_tile_data_r0d_fptr_r0 subroutine add_tile_data_r0d_fptr_r0i(restart,varname,fptr,index,longname,units) @@ -404,22 +387,27 @@ subroutine add_tile_data_r0d_fptr_r0i(restart,varname,fptr,index,longname,units) procedure(fptr_r0i) :: fptr ! subroutine returning pointer to the data integer , intent(in) :: index ! index of the fptr array element to write character(len=*), intent(in), optional :: units, longname + character(len=32) :: chksum - integer :: id_restart real, pointer :: data(:) if (.not.allocated(restart%tidx)) call error_mesg('add_tile_data_r0d_fptr_r0', & 'tidx not allocated: looks like land restart was not initialized',FATAL) allocate(data(size(restart%tidx))) call gather_tile_data_r0i(fptr,index,restart%tidx,data) - if (new_land_io) then - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, restart%basename, & - varname, data, (/CIDX/), lnd%ug_domain, longname=longname, units=units, & - restart_owns_data=.true.) - else ! old land io - call write_tile_data_r1d(restart%ncid,varname,data,longname,units) - deallocate(data) + call register_field(restart%rhandle, varname, "double", (/"tile_index"/)) + call register_variable_attribute(restart%rhandle, varname, "_FillValue", NF90_FILL_DOUBLE) + if (present(longname)) then + call register_variable_attribute(restart%rhandle, varname, "long_name", trim(longname), str_len=len(trim(longname))) + endif + if (present(units)) then + call register_variable_attribute(restart%rhandle, varname, "units", trim(units), str_len=len(trim(units))) endif + + call get_land_chksum(data,chksum) + call register_variable_attribute(restart%rhandle, varname, "checksum", trim(chksum), str_len=len(trim(chksum))) + call write_data(restart%rhandle, varname, data) + deallocate(data) end subroutine add_tile_data_r0d_fptr_r0i subroutine add_tile_data_r0d_fptr_r0ij(restart,varname,fptr,idx1,idx2,longname,units) @@ -428,22 +416,27 @@ subroutine add_tile_data_r0d_fptr_r0ij(restart,varname,fptr,idx1,idx2,longname,u procedure(fptr_r0ij) :: fptr ! subroutine returning pointer to the data integer , intent(in) :: idx1,idx2 ! indices of the fptr array element to write character(len=*), intent(in), optional :: units, longname + character(len=32) :: chksum - integer :: id_restart real, pointer :: data(:) if (.not.allocated(restart%tidx)) call error_mesg('add_tile_data_r0d_fptr_r0ij', & 'tidx not allocated: looks like land restart was not initialized',FATAL) allocate(data(size(restart%tidx))) call gather_tile_data_r0ij(fptr,idx1,idx2,restart%tidx,data) - - if (new_land_io) then - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, restart%basename, & - varname, data, (/CIDX/), lnd%ug_domain, longname=longname, units=units, & - restart_owns_data=.true.) - else ! old land io - call write_tile_data_r1d(restart%ncid,varname,data,longname,units) + call register_field(restart%rhandle, varname, "double", (/"tile_index"/)) + call register_variable_attribute(restart%rhandle, varname, "_FillValue", NF90_FILL_DOUBLE) + if (present(longname)) then + call register_variable_attribute(restart%rhandle, varname, "long_name", trim(longname), str_len=len(trim(longname))) + endif + if (present(units)) then + call register_variable_attribute(restart%rhandle, varname, "units", trim(units), str_len=len(trim(units))) endif + call get_land_chksum(data,chksum) + + call register_variable_attribute(restart%rhandle, varname, "checksum", trim(chksum), str_len=len(trim(chksum))) + call write_data(restart%rhandle, varname, data) + deallocate(data) end subroutine add_tile_data_r0d_fptr_r0ij ! given restart and name of the dimension, returns the size of this dimension @@ -462,15 +455,14 @@ integer function dimlen(restart,dimname) if (dimlen<1) call error_mesg('dimlen', 'axis "'//trim(dimname)//'" not found', FATAL) end - subroutine add_tile_data_i1d_fptr_i0i(restart,varname,zdim,fptr,longname,units) type(land_restart_type), intent(inout) :: restart character(len=*), intent(in) :: varname ! name of the variable to write character(len=*), intent(in) :: zdim ! name of the z-dimension procedure(fptr_i0i) :: fptr ! subroutine returning pointer to the data character(len=*), intent(in), optional :: units, longname + character(len=32) :: chksum - integer :: id_restart integer, pointer :: data(:,:) ! needs to be pointer; we are passing ownership to restart object integer :: i,nlev @@ -480,15 +472,19 @@ subroutine add_tile_data_i1d_fptr_i0i(restart,varname,zdim,fptr,longname,units) nlev = dimlen(restart,zdim) allocate(data(size(restart%tidx),nlev)) call gather_tile_data_i1d(fptr,restart%tidx,data) - - if (new_land_io) then - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, restart%basename, & - varname, data, (/CIDX,ZIDX/), lnd%ug_domain, longname=longname, units=units, & - restart_owns_data=.true.) - else ! old land io - call write_tile_data_i2d(restart%ncid,varname,data,zdim,longname,units) - deallocate(data) + call register_field(restart%rhandle, varname, "int", (/"tile_index ",zdim/)) + call register_variable_attribute(restart%rhandle, varname, "_FillValue", NF90_FILL_INT) + if (present(longname)) then + call register_variable_attribute(restart%rhandle, varname, "long_name", trim(longname), str_len=len(trim(longname))) + endif + if (present(units)) then + call register_variable_attribute(restart%rhandle, varname, "units", trim(units), str_len=len(trim(units))) endif + call get_land_chksum(data,chksum) + + call register_variable_attribute(restart%rhandle, varname, "checksum", trim(chksum), str_len=len(trim(chksum))) + call write_data(restart%rhandle, varname, data) + deallocate(data) end subroutine add_tile_data_i1d_fptr_i0i subroutine add_tile_data_r1d_fptr_r0i(restart,varname,zdim,fptr,longname,units) @@ -497,8 +493,8 @@ subroutine add_tile_data_r1d_fptr_r0i(restart,varname,zdim,fptr,longname,units) character(len=*), intent(in) :: zdim ! name of the z-dimension procedure(fptr_r0i) :: fptr ! subroutine returning pointer to the data character(len=*), intent(in), optional :: units, longname + character(len=32) :: chksum - integer :: id_restart real, pointer :: data(:,:) ! needs to be pointer; we are passing ownership to restart object integer :: i,nlev @@ -508,27 +504,19 @@ subroutine add_tile_data_r1d_fptr_r0i(restart,varname,zdim,fptr,longname,units) nlev = dimlen(restart,zdim) allocate(data(size(restart%tidx),nlev)) call gather_tile_data_r1d(fptr,restart%tidx,data) - - if (new_land_io) then - ! checking name of the dimension here is a dirty trick, which is sure to - ! bite us in the future, but it is necessary because fms_io has no way to - ! figure out what the additional dimension of the variable is. A better way - ! to fix that is to rewrite fms_io so that it allows to specify the dimensions - ! of the variable in a sane way. - if (trim(zdim)=='soilCCohort') then - ! write (*,*) 'writing "',trim(varname),'" with C_CC' - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, restart%basename, & - varname, data, (/CIDX,CCIDX/), lnd%ug_domain, longname=longname, units=units, & - restart_owns_data=.true.) - else - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, restart%basename, & - varname, data, (/CIDX,ZIDX/), lnd%ug_domain, longname=longname, units=units, & - restart_owns_data=.true.) - endif - else ! old land io - call write_tile_data_r2d(restart%ncid,varname,data,zdim,longname,units) - deallocate(data) + call register_field(restart%rhandle, varname, "double", (/"tile_index ",zdim/) ) + call register_variable_attribute(restart%rhandle, varname, "_FillValue", NF90_FILL_DOUBLE) + if (present(longname)) then + call register_variable_attribute(restart%rhandle, varname, "long_name", trim(longname), str_len=len(trim(longname))) endif + if (present(units)) then + call register_variable_attribute(restart%rhandle, varname, "units", trim(units), str_len=len(trim(units))) + endif + call get_land_chksum(data,chksum) + + call register_variable_attribute(restart%rhandle, varname, "checksum", trim(chksum), str_len=len(trim(chksum))) + call write_data(restart%rhandle, varname, data) + deallocate(data) end subroutine add_tile_data_r1d_fptr_r0i subroutine add_tile_data_r1d_fptr_r0ij(restart,varname,zdim,fptr,index,longname,units) @@ -538,8 +526,8 @@ subroutine add_tile_data_r1d_fptr_r0ij(restart,varname,zdim,fptr,index,longname, procedure(fptr_r0ij) :: fptr ! subroutine returning pointer to the data integer , intent(in) :: index ! index of the array element to write character(len=*), intent(in), optional :: units, longname + character(len=32) :: chksum - integer :: id_restart type(land_tile_type), pointer :: tileptr ! pointer to tiles real, pointer :: data(:,:) ! needs to be pointer; we are passing ownership to restart object real, pointer :: ptr ! pointer to the tile data @@ -550,7 +538,7 @@ subroutine add_tile_data_r1d_fptr_r0ij(restart,varname,zdim,fptr,index,longname, nlev = dimlen(restart,zdim) allocate(data(size(restart%tidx),nlev)) - data = NF_FILL_DOUBLE + data = NF90_FILL_DOUBLE ! gather data into an array along the tile dimension. It is assumed that ! the tile dimension spans all the tiles that need to be written. @@ -563,26 +551,19 @@ subroutine add_tile_data_r1d_fptr_r0ij(restart,varname,zdim,fptr,index,longname, endif enddo enddo - if (new_land_io) then - ! checking name of the dimension here is a dirty trick, which is sure to - ! bite us in the future, but it is necessary because fms_io has no way to - ! figure out what the additional dimension of the variable is. A better way - ! to fix that is to rewrite fms_io so that it allows to specify the dimensions - ! of the variable in a sane way. - if (trim(zdim)=='soilCCohort') then - ! write (*,*) 'writing "',trim(varname),'" with C_CC' - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, restart%basename, & - varname, data, (/CIDX,CCIDX/), lnd%ug_domain, longname=longname, units=units, & - restart_owns_data=.true.) - else - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, restart%basename, & - varname, data, (/CIDX,ZIDX/), lnd%ug_domain, longname=longname, units=units, & - restart_owns_data=.true.) - endif - else ! old land io - call write_tile_data_r2d(restart%ncid,varname,data,zdim,longname,units) - deallocate(data) + call register_field(restart%rhandle, varname, "double", (/"tile_index ",zdim/)) + call register_variable_attribute(restart%rhandle, varname, "_FillValue", NF90_FILL_DOUBLE) + if (present(longname)) then + call register_variable_attribute(restart%rhandle, varname, "long_name", trim(longname), str_len=len(trim(longname))) endif + if (present(units)) then + call register_variable_attribute(restart%rhandle, varname, "units", trim(units), str_len=len(trim(units))) + endif + call get_land_chksum(data,chksum) + + call register_variable_attribute(restart%rhandle, varname, "checksum", trim(chksum), str_len=len(trim(chksum))) + call write_data(restart%rhandle, varname, data) + deallocate(data) end subroutine add_tile_data_r1d_fptr_r0ij subroutine add_tile_data_r1d_fptr_r0ijk(restart,varname,zdim,fptr,idx1,idx2,longname,units) @@ -592,6 +573,7 @@ subroutine add_tile_data_r1d_fptr_r0ijk(restart,varname,zdim,fptr,idx1,idx2,long procedure(fptr_r0ijk) :: fptr ! subroutine returning pointer to the data integer , intent(in) :: idx1,idx2 ! indices of the array element to write character(len=*), intent(in), optional :: units, longname + character(len=32) :: chksum integer :: id_restart type(land_tile_type), pointer :: tileptr ! pointer to tiles @@ -609,7 +591,7 @@ subroutine add_tile_data_r1d_fptr_r0ijk(restart,varname,zdim,fptr,idx1,idx2,long if (nlev<1) call error_mesg('add_tile_data_r0d_fptr_r0i', 'axis "'//trim(zdim)//'" not found', FATAL) allocate(data(size(restart%tidx),nlev)) - data = NF_FILL_DOUBLE + data = NF90_FILL_DOUBLE ! gather data into an array along the tile dimension. It is assumed that ! the tile dimension spans all the tiles that need to be written. @@ -622,26 +604,19 @@ subroutine add_tile_data_r1d_fptr_r0ijk(restart,varname,zdim,fptr,idx1,idx2,long endif enddo enddo - if (new_land_io) then - ! checking name of the dimension here is a dirty trick, which is sure to - ! bite us in the future, but it is necessary because fms_io has no way to - ! figure out what the additional dimension of the variable is. A better way - ! to fix that is to rewrite fms_io so that it allows to specify the dimensions - ! of the variable in a sane way. - if (trim(zdim)=='soilCCohort') then - ! write (*,*) 'writing "',trim(varname),'" with C_CC' - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, restart%basename, & - varname, data, (/CIDX,CCIDX/), lnd%ug_domain, longname=longname, units=units, & - restart_owns_data=.true.) - else - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, restart%basename, & - varname, data, (/CIDX,ZIDX/), lnd%ug_domain, longname=longname, units=units, & - restart_owns_data=.true.) - endif - else ! old land io - call write_tile_data_r2d(restart%ncid,varname,data,zdim,longname,units) - deallocate(data) + call register_field(restart%rhandle, varname, "double", (/"tile_index ",zdim/)) + call register_variable_attribute(restart%rhandle, varname, "_FillValue", NF90_FILL_DOUBLE) + if (present(longname)) then + call register_variable_attribute(restart%rhandle, varname, "long_name", trim(longname), str_len=len(trim(longname))) endif + if (present(units)) then + call register_variable_attribute(restart%rhandle, varname, "units", trim(units), str_len=len(trim(units))) + endif + call get_land_chksum(data,chksum) + + call register_variable_attribute(restart%rhandle, varname, "checksum", trim(chksum), str_len=len(trim(chksum))) + call write_data(restart%rhandle, varname, data) + deallocate(data) end subroutine add_tile_data_r1d_fptr_r0ijk subroutine add_tile_data_r2d_fptr_r0ij(restart,varname,dim1,dim2,fptr,longname,units) @@ -650,6 +625,7 @@ subroutine add_tile_data_r2d_fptr_r0ij(restart,varname,dim1,dim2,fptr,longname,u character(len=*), intent(in) :: dim1,dim2 ! names of extra dimensions procedure(fptr_r0ij) :: fptr ! subroutine returning pointer to the data character(len=*), intent(in), optional :: units, longname + character(len=32) :: chksum integer :: id_restart real, pointer :: data(:,:,:) ! needs to be pointer; we are passing ownership to restart object @@ -662,15 +638,19 @@ subroutine add_tile_data_r2d_fptr_r0ij(restart,varname,dim1,dim2,fptr,longname,u dim2len = dimlen(restart,dim2) allocate(data(size(restart%tidx),dim1len,dim2len)) call gather_tile_data_r2d(fptr,restart%tidx,data) - - if (new_land_io) then - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, restart%basename, & - varname, data, (/CIDX,ZIDX,CCIDX/), lnd%ug_domain, longname=longname, units=units, & - restart_owns_data=.true.) - else ! old land io - call write_tile_data_r3d(restart%ncid,varname,data,dim1,dim2,longname,units) - deallocate(data) + call register_field(restart%rhandle, varname, "double", (/"tile_index ",dim1,dim2/) ) + call register_variable_attribute(restart%rhandle, varname, "_FillValue", NF90_FILL_DOUBLE) + if (present(longname)) then + call register_variable_attribute(restart%rhandle, varname, "long_name", trim(longname), str_len=len(trim(longname))) endif + if (present(units)) then + call register_variable_attribute(restart%rhandle, varname, "units", trim(units), str_len=len(trim(units))) + endif + call get_land_chksum(data,chksum) + + call register_variable_attribute(restart%rhandle, varname, "checksum", trim(chksum), str_len=len(trim(chksum))) + call write_data(restart%rhandle, varname, data) + deallocate(data) end subroutine add_tile_data_r2d_fptr_r0ij subroutine add_tile_data_r2d_fptr_r0ijk(restart,varname,dim1,dim2,fptr,index,longname,units) @@ -680,6 +660,7 @@ subroutine add_tile_data_r2d_fptr_r0ijk(restart,varname,dim1,dim2,fptr,index,lon procedure(fptr_r0ijk) :: fptr ! subroutine returning pointer to the data integer , intent(in) :: index ! index of the array element to write character(len=*), intent(in), optional :: units, longname + character(len=32) :: chksum integer :: id_restart real, pointer :: data(:,:,:) ! needs to be pointer; we are passing ownership to restart object @@ -692,15 +673,18 @@ subroutine add_tile_data_r2d_fptr_r0ijk(restart,varname,dim1,dim2,fptr,index,lon dim2len = dimlen(restart,dim2) allocate(data(size(restart%tidx),dim1len,dim2len)) call gather_tile_data_r2d_idx(fptr,index,restart%tidx,data) - - if (new_land_io) then - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, restart%basename, & - varname, data, (/CIDX,ZIDX,CCIDX/), lnd%ug_domain, longname=longname, units=units, & - restart_owns_data=.true.) - else ! old land io - call write_tile_data_r3d(restart%ncid,varname,data,dim1,dim2,longname,units) - deallocate(data) + call register_field(restart%rhandle, varname, "double", (/"tile_index ",dim1,dim2/)) + call register_variable_attribute(restart%rhandle, varname, "_FillValue", NF90_FILL_DOUBLE) + if (present(longname)) then + call register_variable_attribute(restart%rhandle, varname, "long_name", trim(longname), str_len=len(trim(longname))) endif + if (present(units)) then + call register_variable_attribute(restart%rhandle, varname, "units", trim(units), str_len=len(trim(units))) + endif + call get_land_chksum(data,chksum) + call register_variable_attribute(restart%rhandle, varname, "checksum", trim(chksum), str_len=len(trim(chksum))) + call write_data(restart%rhandle, varname, data) + deallocate(data) end subroutine add_tile_data_r2d_fptr_r0ijk ! ============================================================================= @@ -709,11 +693,7 @@ subroutine get_scalar_data(restart,varname,datum) character(len=*), intent(in) :: varname ! name of the variable to write integer, intent(out) :: datum - if (new_land_io) then - call read_data(restart%basename,varname,datum,domain=lnd%sg_domain) - else - __NF_ASRT__(nfu_get_var(restart%ncid,varname,datum)) - endif + call read_data(restart%rhandle,varname,datum) end subroutine get_scalar_data subroutine get_text_data(restart,varname,text) @@ -721,18 +701,7 @@ subroutine get_text_data(restart,varname,text) character(len=*), intent(in) :: varname ! name of the variable to write character, allocatable, intent(out) :: text(:,:) - integer :: dimlens(NF_MAX_VAR_DIMS), ndims - - if (new_land_io) then - ! call read_data(restart%basename,varname,datum,domain=lnd%domain) - call error_mesg('get_text_data','does not work with new io yet', FATAL) - else - __NF_ASRT__(nfu_inq_var(restart%ncid,varname,dimlens=dimlens,ndims=ndims)) - if (ndims==1) dimlens(2) = 1 - if (ndims>2) call error_mesg('get_text_data','input text has more than two dimensions',FATAL) - allocate(text(dimlens(1),dimlens(2))) - __NF_ASRT__(nfu_get_var(restart%ncid,varname,text)) - endif + call error_mesg('get_text_data','does not work with new io yet', FATAL) end subroutine get_text_data subroutine get_tile_data_i0d_fptr_i0(restart,varname,fptr) @@ -742,16 +711,11 @@ subroutine get_tile_data_i0d_fptr_i0(restart,varname,fptr) ! ---- local vars integer, allocatable :: r(:) ! input data buffer - logical :: found - - if (new_land_io) then - allocate(r(size(restart%tidx))) - call fms_io_unstructured_read(restart%basename, varname, r, lnd%ug_domain, timelevel=1) - call distrib_tile_data_i0d(fptr,restart%tidx,r) - deallocate(r) - else ! old land io - call read_tile_data_i0d_fptr(restart%ncid,varname,fptr) - endif + + allocate(r(size(restart%tidx))) + call read_data(restart%rhandle, varname, r) + call distrib_tile_data_i0d(fptr,restart%tidx,r) + deallocate(r) end subroutine get_tile_data_i0d_fptr_i0 subroutine get_tile_data_r0d_fptr_r0(restart,varname,fptr) @@ -761,16 +725,11 @@ subroutine get_tile_data_r0d_fptr_r0(restart,varname,fptr) ! ---- local vars real, allocatable :: r(:) ! input data buffer - logical :: found - - if (new_land_io) then - allocate(r(size(restart%tidx))) - call fms_io_unstructured_read(restart%basename, varname, r, lnd%ug_domain, timelevel=1) - call distrib_tile_data_r0d(fptr,restart%tidx,r) - deallocate(r) - else ! old land io - call read_tile_data_r0d_fptr_r0(restart%ncid,varname,fptr) - endif + + allocate(r(size(restart%tidx))) + call read_data(restart%rhandle, varname, r) + call distrib_tile_data_r0d(fptr,restart%tidx,r) + deallocate(r) end subroutine get_tile_data_r0d_fptr_r0 subroutine get_tile_data_r0d_fptr_r0i(restart,varname,fptr,index) @@ -781,16 +740,11 @@ subroutine get_tile_data_r0d_fptr_r0i(restart,varname,fptr,index) ! ---- local vars real, allocatable :: r(:) ! input data buffer - logical :: found - - if (new_land_io) then - allocate(r(size(restart%tidx))) - call fms_io_unstructured_read(restart%basename, varname, r, lnd%ug_domain, timelevel=1) - call distrib_tile_data_r0d_idx(fptr,index,restart%tidx,r) - deallocate(r) - else ! old land io - call read_tile_data_r0d_fptr_r0i(restart%ncid,varname,fptr,index) - endif + + allocate(r(size(restart%tidx))) + call read_data(restart%rhandle, varname, r) + call distrib_tile_data_r0d_idx(fptr,index,restart%tidx,r) + deallocate(r) end subroutine get_tile_data_r0d_fptr_r0i subroutine get_tile_data_r0d_fptr_r0ij(restart,varname,fptr,i1, i2) @@ -801,16 +755,11 @@ subroutine get_tile_data_r0d_fptr_r0ij(restart,varname,fptr,i1, i2) ! ---- local vars real, allocatable :: r(:) ! input data buffer - logical :: found - - if (new_land_io) then - allocate(r(size(restart%tidx))) - call fms_io_unstructured_read(restart%basename, varname, r, lnd%ug_domain, timelevel=1) - call distrib_tile_data_r0d_ij(fptr,i1,i2,restart%tidx,r) - deallocate(r) - else ! old land io - call read_tile_data_r0d_fptr_r0ij(restart%ncid,varname,fptr,i1,i2) - endif + + allocate(r(size(restart%tidx))) + call read_data(restart%rhandle, varname, r) + call distrib_tile_data_r0d_ij(fptr,i1,i2,restart%tidx,r) + deallocate(r) end subroutine get_tile_data_r0d_fptr_r0ij subroutine get_tile_data_r1d_fptr_r0i(restart,varname,zdim,fptr) @@ -820,28 +769,27 @@ subroutine get_tile_data_r1d_fptr_r0i(restart,varname,zdim,fptr) procedure(fptr_r0i) :: fptr ! subroutine returning pointer to the data ! ---- local vars - integer :: flen(4) ! size of the input field + integer,dimension(:),allocatable :: flen ! size of the input field real, allocatable :: r(:,:) ! input data buffer - logical :: found - - if (new_land_io) then - !Get the size of z-dimension from the file. - call fms_io_unstructured_get_field_size(restart%basename, zdim, flen, lnd%ug_domain, & - field_found=found) - if (.not. found) then - call error_mesg("get_tile_data_r0d_fptr_r0i", & - "axis '"//trim(zdim)//"' was not found in file '"//trim(restart%basename)//"'.", & - FATAL) - endif + integer :: ndims - !Read in the field from the file. - allocate(r(size(restart%tidx),flen(1))) - call fms_io_unstructured_read(restart%basename, varname, r, lnd%ug_domain, timelevel=1) - call distrib_tile_data_r1d(fptr,restart%tidx,r) - deallocate(r) - else ! old land io - call read_tile_data_r1d_fptr_r0i(restart%ncid,varname,fptr) + if (.not. field_exists(restart, zdim)) then + call error_mesg("get_tile_data_r0d_fptr_r0i", & + "axis '"//trim(zdim)//"' was not found in file '"//trim(restart%basename)//"'.", & + FATAL) endif + + !Get the size of z-dimension from the file. + ndims = get_variable_num_dimensions(restart%rhandle, zdim) + allocate(flen(ndims)) + call get_variable_size(restart%rhandle, zdim, flen) + + !Read in the field from the file. + allocate(r(size(restart%tidx),flen(1))) + call read_data(restart%rhandle, varname, r) + call distrib_tile_data_r1d(fptr,restart%tidx,r) + deallocate(r) + deallocate(flen) end subroutine get_tile_data_r1d_fptr_r0i subroutine get_tile_data_i1d_fptr_i0i(restart,varname,zdim,fptr) @@ -851,28 +799,27 @@ subroutine get_tile_data_i1d_fptr_i0i(restart,varname,zdim,fptr) procedure(fptr_i0i) :: fptr ! subroutine returning pointer to the data ! ---- local vars - integer :: flen(4) ! size of the input field + integer,dimension(:),allocatable :: flen ! size of the input field integer, allocatable :: r(:,:) ! input data buffer - logical :: found - - if (new_land_io) then - !Get the size of z-dimension from the file. - call fms_io_unstructured_get_field_size(restart%basename, zdim, flen, lnd%ug_domain, & - field_found=found) - if (.not. found) then - call error_mesg("get_tile_data_i1d_fptr_i0i", & - "axis '"//trim(zdim)//"' was not found in file '"//trim(restart%basename)//"'.", & - FATAL) - endif + integer :: ndims - !Read in the field data from the file. - allocate(r(size(restart%tidx),flen(1))) - call fms_io_unstructured_read(restart%basename, varname, r, lnd%ug_domain, timelevel=1) - call distrib_tile_data_i1d(fptr,restart%tidx,r) - deallocate(r) - else ! old land io - call read_tile_data_i1d_fptr_i0i(restart%ncid,varname,fptr) + if (.not. field_exists(restart, zdim)) then + call error_mesg("get_tile_data_i1d_fptr_i0i", & + "axis '"//trim(zdim)//"' was not found in file '"//trim(restart%basename)//"'.", & + FATAL) endif + + !Get the size of z-dimension from the file. + ndims = get_variable_num_dimensions(restart%rhandle, zdim) + allocate(flen(ndims)) + call get_variable_size(restart%rhandle, zdim, flen) + + !Read in the field from the file. + allocate(r(size(restart%tidx),flen(1))) + call read_data(restart%rhandle, varname, r) + call distrib_tile_data_i1d(fptr,restart%tidx,r) + deallocate(r) + deallocate(flen) end subroutine get_tile_data_i1d_fptr_i0i subroutine get_tile_data_r1d_fptr_r0ij(restart,varname,zdim,fptr,index) @@ -883,26 +830,27 @@ subroutine get_tile_data_r1d_fptr_r0ij(restart,varname,zdim,fptr,index) integer , intent(in) :: index ! ---- local vars - integer :: flen(4) ! size of the input field + integer,dimension(:),allocatable :: flen ! size of the input field real, allocatable :: r(:,:) ! input data buffer - logical :: found - - if (new_land_io) then - !Get the size of z-dimension from the file. - call fms_io_unstructured_get_field_size(restart%basename, zdim, flen, lnd%ug_domain, & - field_found=found) - if (.not. found) call error_mesg("get_tile_data_r1d_fptr_r0ij", & - "axis '"//trim(zdim)//"' was not found in file '"//trim(restart%basename)//"'.", & - FATAL) - - !Read in the field from the file. - allocate(r(size(restart%tidx),flen(1))) - call fms_io_unstructured_read(restart%basename, varname, r, lnd%ug_domain, timelevel=1) - call distrib_tile_data_r1d_idx(fptr,index,restart%tidx,r) - deallocate(r) - else ! old land io - call read_tile_data_r1d_fptr_r0ij(restart%ncid,varname,fptr,index) + integer :: ndims + + if (.not. field_exists(restart, zdim)) then + call error_mesg("get_tile_data_r1d_fptr_r0ij", & + "axis '"//trim(zdim)//"' was not found in file '"//trim(restart%basename)//"'.", & + FATAL) endif + + !Get the size of z-dimension from the file. + ndims = get_variable_num_dimensions(restart%rhandle, zdim) + allocate(flen(ndims)) + call get_variable_size(restart%rhandle, zdim, flen) + + !Read in the field from the file. + allocate(r(size(restart%tidx),flen(1))) + call read_data(restart%rhandle, varname, r) + call distrib_tile_data_r1d_idx(fptr,index,restart%tidx,r) + deallocate(r) + deallocate(flen) end subroutine get_tile_data_r1d_fptr_r0ij subroutine get_tile_data_r1d_fptr_r0ijk(restart,varname,zdim,fptr,idx1,idx2) @@ -913,26 +861,27 @@ subroutine get_tile_data_r1d_fptr_r0ijk(restart,varname,zdim,fptr,idx1,idx2) integer , intent(in) :: idx1,idx2 ! ---- local vars - integer :: flen(4) ! size of the input field + integer,dimension(:),allocatable :: flen ! size of the input field real, allocatable :: r(:,:) ! input data buffer - logical :: found - - if (new_land_io) then - ! get the size of zdim - call fms_io_unstructured_get_field_size(restart%basename, zdim, flen, lnd%ug_domain, & - field_found=found) - if (.not.found) call error_mesg('get_tile_data_r1d_fptr_r0ijk', & - 'axis "'//trim(zdim)//'" was not found in file "'//trim(restart%basename)//'"', & - FATAL) - - ! read the data - allocate(r(size(restart%tidx),flen(1))) - call fms_io_unstructured_read(restart%basename, varname, r, lnd%ug_domain, timelevel=1) - ! call distrib_tile_data_r1d_idx(fptr,idx1,idx2,restart%tidx,r) - deallocate(r) - else ! old land io - call read_tile_data_r1d_fptr_r0ijk(restart%ncid,varname,fptr,idx1,idx2) + integer :: ndims + + if (.not. field_exists(restart, zdim)) then + call error_mesg("get_tile_data_r1d_fptr_r0ijk", & + "axis '"//trim(zdim)//"' was not found in file '"//trim(restart%basename)//"'.", & + FATAL) endif + + !Get the size of z-dimension from the file. + ndims = get_variable_num_dimensions(restart%rhandle, zdim) + allocate(flen(ndims)) + call get_variable_size(restart%rhandle, zdim, flen) + + !Read in the field from the file. + allocate(r(size(restart%tidx),flen(1))) + call read_data(restart%rhandle, varname, r) +! call distrib_tile_data_r1d_idx(fptr,idx1,idx2,restart%tidx,r) + deallocate(r) + deallocate(flen) end subroutine get_tile_data_r1d_fptr_r0ijk subroutine get_tile_data_r2d_fptr_r0ij(restart,varname,dim1,dim2,fptr) @@ -942,39 +891,42 @@ subroutine get_tile_data_r2d_fptr_r0ij(restart,varname,dim1,dim2,fptr) procedure(fptr_r0ij) :: fptr ! subroutine returning pointer to the data ! ---- local vars - integer :: flen(4),n,m ! size of the input field + integer,dimension(:),allocatable :: flen ! size of the input field + integer :: n,m real, allocatable :: r(:,:,:) ! input data buffer - logical :: found - - if (new_land_io) then - !Get the size of the first dimension of the field. - call fms_io_unstructured_get_field_size(restart%basename, dim1, flen, lnd%ug_domain, & - field_found=found) - if (.not. found) then - call error_mesg("get_tile_data_r0d_fptr_r0i", & - "axis '"//trim(dim1)//"' was not found in file '"//trim(restart%basename)//"'.", & - FATAL) - endif - n = flen(1) - - !Get the size of the second dimension of the field. - call fms_io_unstructured_get_field_size(restart%basename, dim2, flen, lnd%ug_domain, & - field_found=found) - if (.not. found) then - call error_mesg("get_tile_data_r0d_fptr_r0i", & - "axis '"//trim(dim2)//"' was not found in file '"//trim(restart%basename)//"'.", & - FATAL) - endif - m = flen(1) - - !Read in the field data from the file. - allocate(r(size(restart%tidx),n,m)) - call fms_io_unstructured_read(restart%basename, varname, r, lnd%ug_domain, timelevel=1) - call distrib_tile_data_r2d(fptr,restart%tidx,r) - deallocate(r) - else ! old land io - call read_tile_data_r2d_fptr_r0ij(restart%ncid,varname,fptr) + integer :: ndims + + if (.not. field_exists(restart, dim1)) then + call error_mesg("get_tile_data_r2d_fptr_r0ij", & + "axis '"//trim(dim1)//"' was not found in file '"//trim(restart%basename)//"'.", & + FATAL) endif + + !Get the size of the first dimension of the field. + ndims = get_variable_num_dimensions(restart%rhandle, dim1) + allocate(flen(ndims)) + call get_variable_size(restart%rhandle, dim1, flen) + n = flen(1) + deallocate(flen) + + if (.not. field_exists(restart, dim2)) then + call error_mesg("get_tile_data_r2d_fptr_r0ij", & + "axis '"//trim(dim2)//"' was not found in file '"//trim(restart%basename)//"'.", & + FATAL) + endif + + !Get the size of the second dimension of the field. + ndims = get_variable_num_dimensions(restart%rhandle, dim2) + allocate(flen(ndims)) + call get_variable_size(restart%rhandle, dim2, flen) + m = flen(1) + deallocate(flen) + + !Read in the field data from the file. + allocate(r(size(restart%tidx),n,m)) + call read_data(restart%rhandle, varname, r) + call distrib_tile_data_r2d(fptr,restart%tidx,r) + deallocate(r) end subroutine get_tile_data_r2d_fptr_r0ij subroutine get_tile_data_r2d_fptr_r0ijk(restart,varname,dim1,dim2,fptr,index) @@ -985,214 +937,121 @@ subroutine get_tile_data_r2d_fptr_r0ijk(restart,varname,dim1,dim2,fptr,index) integer, intent(in) :: index ! index where to read the data ! ---- local vars - integer :: flen(4), m, n ! size of the input field + integer,dimension(:),allocatable :: flen ! size of the input field + integer :: m,n real, allocatable :: r(:,:,:) ! input data buffer - logical :: found - - if (new_land_io) then - !Get the size of the z-dimension from the file. - call fms_io_unstructured_get_field_size(restart%basename, dim1, flen, lnd%ug_domain, & - field_found=found) - if (.not. found) then - call error_mesg("get_tile_data_r0d_fptr_r0i", & - "axis '"//trim(dim1)//"' was not found in file '"//trim(restart%basename)//"'.", & - FATAL) - endif - n = flen(1) - - !Get the size of the 3rd dimension of the field. - call fms_io_unstructured_get_field_size(restart%basename, dim2, flen, lnd%ug_domain, & - field_found=found) - if (.not. found) then - call error_mesg("get_tile_data_r0d_fptr_r0i", & - "axis '"//trim(dim1)//"' was not found in file '"//trim(restart%basename)//"'.", & - FATAL) - endif - m = flen(1) - - !Read in the field from the file. - allocate(r(size(restart%tidx),n,m)) - call fms_io_unstructured_read(restart%basename, varname, r, lnd%ug_domain, timelevel=1) - call distrib_tile_data_r2d_idx(fptr,index,restart%tidx,r) - deallocate(r) - else ! old land io - call read_tile_data_r2d_fptr_r0ijk(restart%ncid,varname,fptr,index) - endif -end subroutine get_tile_data_r2d_fptr_r0ijk - -! ============================================================================= -! given a generic name of the restart file, checks if a file with one of the -! possible restarts file names exists, and if it does returns the tile-qualified -! (or tile- and processor-qualified) name of the restart. -subroutine get_input_restart_name(name, restart_exists, actual_name, new_land_io) - character(*), intent(in) :: name ! "generic" name of the restart - logical , intent(out) :: restart_exists ! TRUE if any file found - character(*), intent(out) :: actual_name ! name of the found file, if any - logical, intent(in), optional :: new_land_io + integer :: ndims - ! ---- local vars - character(6) :: PE_suffix ! PE number - character(len=256) :: distributed_name - - ! Build the restart file name. - call get_instance_filename(trim(name), actual_name) - call get_mosaic_tile_file(trim(actual_name),actual_name, lnd%ug_domain) - ! we cannot use fms file_exist function here, because it lies: it checks not - ! just the original name, but the name with PE suffix, and returns true if - ! either of those exist - inquire (file=trim(actual_name), exist=restart_exists) - if (.not.restart_exists) then - ! try the name with current PE number attached - write(PE_suffix,'(".",I4.4)') lnd%io_id - distributed_name = trim(actual_name)//trim(PE_suffix) - inquire (file=trim(distributed_name), exist=restart_exists) - if(present(new_land_io)) then - if(.not.new_land_io) actual_name = trim(distributed_name) - else - ! if new_land_io is not present then revert to behavior of previous revision. That is, as if new_land_io=.false. - actual_name = trim(distributed_name) - endif + if (.not. field_exists(restart, dim1)) then + call error_mesg("get_tile_data_r2d_fptr_r0ijk", & + "axis '"//trim(dim1)//"' was not found in file '"//trim(restart%basename)//"'.", & + FATAL) endif -end subroutine get_input_restart_name - -! ============================================================================= -! this subroutine creates netcdf file for output of tiled data using "compression -! by gathering," as described in CF conventions, and creates coordinate system -! necessary for write_tile_data subroutines. -! In particular: -! "compressed" dimension and integer variable with appropriate attributes, with -! variable filled with packing indices -! horizontal dimensions "lat" and "lon" with associated variable, and boundaries, -! describing global grid -! dimension "tile," without any associated variable. length of this dimension is -! equal to current global max of number of tiles per grid cell -! -! The file is actually created only by root processor of our io_domain; the rest -! of the processors just open the created file in NOWRITE mode. -subroutine create_tile_out_file_idx_old(ncid, name, tidx, tile_dim_length, glon, glat, reserve) - integer , intent(out) :: ncid ! resulting NetCDF id - character(len=*) , intent(in) :: name ! name of the file to create - real , intent(in) :: glon(:) ! longitudes of the grid centers - real , intent(in) :: glat(:) ! latitudes of the grid centers - integer , intent(in) :: tidx(:) ! integer compressed index of tiles - integer , intent(in) :: tile_dim_length ! length of tile axis - integer, optional, intent(in) :: reserve ! amount of space to reserve for - ! header expansion. This subroutine and following calls to write_tile_data - ! will work even if this is set to 0, but for efficiency it is useful to - ! specify some non-zero value, so that netcdf library do not have to rewrite - ! entire file each time a new variable is added. Default value (8K) should do - ! fine in most cases. - - ! ---- local vars - integer :: reserve_ ! local value of space to reserve at the end of NetCDF header - character(256) :: full_name ! full name of the file, including the processor number - character(6) :: PE_suffix ! PE number - integer, allocatable :: ntiles(:) ! list of land tile numbers for each of PEs in io_domain - integer, allocatable :: tidx2(:) ! array of tile indices from all PEs in io_domain - integer :: p ! io_domain PE iterator - integer :: k ! current index in tidx2 array for receive operation - integer :: i - integer :: iret - - ! form the full name of the file - call get_instance_filename(trim(name), full_name) - call get_mosaic_tile_file(trim(full_name),full_name,lnd%ug_domain) - if (lnd%append_io_id) then - write(PE_suffix,'(".",I4.4)') lnd%io_id - else - PE_suffix = '' + !Get the size of the first dimension of the field. + ndims = get_variable_num_dimensions(restart%rhandle, dim1) + allocate(flen(ndims)) + call get_variable_size(restart%rhandle, dim1, flen) + n = flen(1) + deallocate(flen) + + if (.not. field_exists(restart, dim2)) then + call error_mesg("get_tile_data_r2d_fptr_r0ijk", & + "axis '"//trim(dim2)//"' was not found in file '"//trim(restart%basename)//"'.", & + FATAL) endif - full_name = trim(full_name)//trim(PE_suffix) - if(tile_dim_length<=0) & - call error_mesg('create_tile_out_file','tile axis length must be positive', FATAL) - - if (mpp_pe()/=lnd%io_pelist(1)) then - ! if current PE does not do io, we just send the data to the processor that - ! does - call mpp_send(size(tidx), plen=1, to_pe=lnd%io_pelist(1), tag=COMM_TAG_1) - call mpp_send(tidx(1), plen=size(tidx), to_pe=lnd%io_pelist(1), tag=COMM_TAG_2) - else - ! gather an array of tile sizes from all processors in our io_domain - allocate(ntiles(size(lnd%io_pelist))) - ntiles(1) = size(tidx) - do p = 2,size(lnd%io_pelist) - call mpp_recv(ntiles(p), from_pe=lnd%io_pelist(p), glen=1, tag=COMM_TAG_1) - enddo - ! gather tile indices from all processors in our io_domain - allocate(tidx2(sum(ntiles(:)))) - tidx2(1:ntiles(1))=tidx(:) - k=ntiles(1)+1 - do p = 2,size(lnd%io_pelist) - call mpp_recv(tidx2(k), from_pe=lnd%io_pelist(p), glen=ntiles(p), tag=COMM_TAG_2) - k = k+ntiles(p) - enddo - ! create netcdf file -#ifdef use_netCDF3 - __NF_ASRT__(nf_create(full_name,NF_CLOBBER,ncid)) -#elif use_LARGEFILE - __NF_ASRT__(nf_create(full_name,ior(NF_64BIT_OFFSET,NF_CLOBBER),ncid)) -#else - __NF_ASRT__(nf_create(full_name,ior(NF_NETCDF4,NF_CLASSIC_MODEL),ncid)) -#endif - - ! create lon, lat, dimensions and variables - __NF_ASRT__(nfu_def_dim(ncid,'lon' ,glon(:) ,'longitude','degrees_east')) - __NF_ASRT__(nfu_def_dim(ncid,'lat' ,glat(:) ,'latitude','degrees_north')) - - iret=nfu_def_dim(ncid,'tile',(/(p,p=1,tile_dim_length)/),'tile number within grid cell') - __NF_ASRT__(iret) - ! the size of tile dimension really does not matter for the output, but it does - ! matter for uncompressing utility, since it uses it as a size of the array to - ! unpack to - ! create tile index dimension and variable - __NF_ASRT__(nfu_def_dim(ncid,tile_index_name,tidx2,'compressed land point index')) - __NF_ASRT__(nfu_put_att(ncid,tile_index_name,'compress','tile lat lon')) - __NF_ASRT__(nfu_put_att(ncid,tile_index_name,'valid_min',0)) - - ! determine the local value of space reserved in the header; by default 16K - reserve_ = 1024*16 - if(present(reserve)) reserve_ = reserve - - ! end definition mode, reserving some space for future additions - ! this call also commits the changes to the disk - __NF_ASRT__(nf__enddef(ncid,reserve_,4,0,4)) - ! arguments are ncid,h_minfree,v_align,v_minfree,r_align; default is (ncid,0,4,0,4). - ! The above call reserves some space at the end of the netcdf header for - ! future expansion without library's having to rewrite the entire file. See - ! manual pages netcdf(3f) or netcdf(3) for more information. - endif - - call mpp_sync() -end subroutine create_tile_out_file_idx_old + !Get the size of the second dimension of the field. + ndims = get_variable_num_dimensions(restart%rhandle, dim2) + allocate(flen(ndims)) + call get_variable_size(restart%rhandle, dim2, flen) + m = flen(1) + deallocate(flen) + + !Read in the field from the file. + allocate(r(size(restart%tidx),n,m)) + call read_data(restart%rhandle, varname, r) + call distrib_tile_data_r2d_idx(fptr,index,restart%tidx,r) + deallocate(r) +end subroutine get_tile_data_r2d_fptr_r0ijk subroutine create_tile_out_file_idx_new(rhandle,name,tidx,tile_dim_length,zaxis_data,soilCCohort_data) - type(restart_file_type), intent(inout) :: rhandle ! restart file handle + type(FmsNetcdfUnstructuredDomainFile_t), intent(inout) :: rhandle ! restart file handle character(len=*), intent(in) :: name ! name of the file to create integer , intent(in) :: tidx(:) ! integer compressed index of tiles (local) integer , intent(in) :: tile_dim_length ! length of tile axis real, optional, intent(in) :: zaxis_data(:) ! data for the Z-axis real, optional, intent(in) :: soilCCohort_data(:) - call fms_io_unstructured_register_restart_axis(rhandle, trim(name), "lon", lnd%coord_glon, "X", & - lnd%ug_domain, units="degrees_east", longname="longitude") - call fms_io_unstructured_register_restart_axis(rhandle, trim(name), "lat", lnd%coord_glat, "Y", & - lnd%ug_domain, units="degrees_north", longname="latitude") + logical :: s + integer :: ntidx + integer, dimension(:), allocatable :: npes_tidx !Tile index length of each pe in file's pelist. + integer, dimension(:), allocatable :: npes_tidx_start !Offset of tile index of each pe in file's pelist. + integer, dimension(tile_dim_length) :: buffer + integer :: i + + s = open_file(rhandle, name, "overwrite", lnd%ug_domain, is_restart=.true.) + call register_axis(rhandle, "lon", size(lnd%coord_glon)) + call register_field(rhandle, "lon", "double", (/"lon"/)) + call register_variable_attribute(rhandle, "lon", "units", "degrees_east", str_len=len(trim("degrees_east"))) + call register_variable_attribute(rhandle, "lon", "long_name", "longitude", str_len=len(trim("longitude"))) + call register_variable_attribute(rhandle, "lon", "cartesian_axis", "X", str_len=len(trim("X"))) + call write_data(rhandle, "lon", lnd%coord_glon) + + call register_axis(rhandle, "lat", size(lnd%coord_glat)) + call register_field(rhandle, "lat", "double", (/"lat"/)) + call register_variable_attribute(rhandle, "lat", "units", "degrees_north", str_len=len(trim("degrees_north"))) + call register_variable_attribute(rhandle, "lat", "long_name", "latitude", str_len=len(trim("latitude"))) + call register_variable_attribute(rhandle, "lat", "cartesian_axis", "Y", str_len=len(trim("Y"))) + call write_data(rhandle, "lat", lnd%coord_glat) + + call register_axis(rhandle, "Time", unlimited) + call register_field(rhandle, "Time", "double", (/"Time"/)) + call register_variable_attribute(rhandle, "Time", "units", "time trim(level)", str_len=len(trim("time level"))) + call register_variable_attribute(rhandle, "Time", "long_name", "Time", str_len=len(trim("Time"))) + call register_variable_attribute(rhandle, "Time", "cartesian_axis", "T", str_len=len(trim("T"))) + call write_data(rhandle, "Time", 1) + ! the size of tile dimension really does not matter for the output, but it does ! matter for uncompressing utility, since it uses it as a size of the array to ! unpack to create tile index dimension and variable. - call fms_io_unstructured_register_restart_axis(rhandle, trim(name), trim(tile_index_name), & - tidx, "tile lat lon", "C", tile_dim_length, lnd%ug_domain, dimlen_name="tile", & - dimlen_lname="tile number within grid cell", longname="compressed land point index", imin=0) + call register_axis(rhandle, "tile", tile_dim_length) + call register_field(rhandle, "tile", "int", (/"tile"/)) + call register_variable_attribute(rhandle, "tile", "long_name", "tile number within grid cell", & + str_len=len(trim("tile number within grid cell"))) + do i = 1, tile_dim_length + buffer(i) = i + enddo + call write_data(rhandle, "tile", buffer) + + ntidx = size(tidx) + call compressed_start_and_count(rhandle, ntidx, npes_tidx_start, npes_tidx) + call register_axis(rhandle, tile_index_name, npes_corner=npes_tidx_start, npes_nelems=npes_tidx) + deallocate(npes_tidx) + deallocate(npes_tidx_start) + call register_field(rhandle, tile_index_name, "int", (/tile_index_name/)) + call register_variable_attribute(rhandle, tile_index_name, "long_name", "compressed land point index", & + str_len=len(trim("compressed land point index"))) + call register_variable_attribute(rhandle, tile_index_name, "compress", "tile lat lon", str_len=len(trim("tile lat lon"))) + call register_variable_attribute(rhandle, tile_index_name, "units", "", str_len=len(trim(""))) + call register_variable_attribute(rhandle, tile_index_name, "valid_min", 0) + call write_data(rhandle, tile_index_name, tidx) + if (present(zaxis_data)) then - call fms_io_unstructured_register_restart_axis(rhandle, trim(name), "zfull", zaxis_data, "Z", & - lnd%ug_domain, units="m", longname="full level", sense=-1) + call register_axis(rhandle, "zfull", size(zaxis_data)) + call register_field(rhandle, "zfull", "double", (/"zfull"/)) + call register_variable_attribute(rhandle, "zfull", "long_name", "full level", str_len=len(trim("full level"))) + call register_variable_attribute(rhandle, "zfull", "units", "m", str_len=len(trim("m"))) + call register_variable_attribute(rhandle, "zfull", "positive", "down", str_len=len(trim("down"))) + call write_data(rhandle,"zfull",zaxis_data) endif if (present(soilCCohort_data)) then - call fms_io_unstructured_register_restart_axis(rhandle, trim(name), "soilCCohort", soilCCohort_data, "CC", & - lnd%ug_domain, longname="Soil carbon cohort") + call register_axis(rhandle, "soilCCohort", size(soilCCohort_data)) + call register_field(rhandle, "soilCCohort", "double", (/"soilCCohort"/)) + call register_variable_attribute(rhandle, "soilCCohort", "long_name", "Soil carbon cohort", & + str_len=len(trim("Soil carbon cohort"))) + call write_data(rhandle,"soilCCohort",soilCCohort_data) endif end subroutine create_tile_out_file_idx_new @@ -1265,810 +1124,6 @@ subroutine get_tile_by_idx(idx,ptr) end subroutine get_tile_by_idx - -! ============================================================================ -! given the netcdf file id, name of the variable, and accessor subroutine, this -! subroutine reads integer 2D data (a scalar value per grid cell, that is why -! there is 0d in the name of this subroutine) and assigns the input values to -! each tile in respective grid cell. -subroutine read_tile_data_i0d_fptr(ncid,name,fptr) - integer , intent(in) :: ncid ! netcdf file id - character(*), intent(in) :: name ! name of the variable to read - procedure(fptr_i0) :: fptr ! subroutine returning the pointer to the - ! data to be written - - ! ---- local constants - character(*), parameter :: module_name='read_tile_data_i0d_fptr' - ! ---- local vars - integer :: ndims ! number of the variable dimensions - integer :: dimids(1) ! IDs of the variable dimensions - integer :: dimlen(1) ! size of the variable dimensions - character(NF_MAX_NAME) :: idxname ! name of the index variable - integer, allocatable :: idx(:) ! storage for compressed index - integer, allocatable :: x1d(:) ! storage for the data - integer :: i,j,bufsize - integer :: varid, idxid - type(land_tile_type), pointer :: tileptr ! pointer to tile - integer, pointer :: ptr - - ! get the number of variable dimensions, and their lengths - __NF_ASRT__(nfu_inq_var(ncid,name,id=varid,ndims=ndims,dimids=dimids,dimlens=dimlen)) - if(ndims/=1) then - call error_mesg(module_name,'variable "'//trim(name)//'" has incorrect number of dimensions -- must be 1-dimensional', FATAL) - endif - ! get the name of compressed dimension and ID of corresponding variable - __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),idxname)) - __NF_ASRT__(nfu_inq_var(ncid,idxname,id=idxid)) - ! allocate input buffers for compression index and the variable - bufsize = min(input_buf_size,dimlen(1)) - allocate(idx(bufsize),x1d(bufsize)) - ! read the input buffer-by-buffer - do j = 1,dimlen(1),bufsize - ! read the index variable - __NF_ASRT__(nf_get_vara_int(ncid,idxid,(/j/),(/min(bufsize,dimlen(1)-j+1)/),idx)) - ! read the data - __NF_ASRT__(nf_get_vara_int(ncid,varid,(/j/),(/min(bufsize,dimlen(1)-j+1)/),x1d)) - ! distribute the data over the tiles - do i = 1, min(input_buf_size,dimlen(1)-j+1) - call get_tile_by_idx(idx(i), tileptr) - call fptr(tileptr, ptr) - if(associated(ptr)) ptr = x1d(i) - enddo - enddo - ! release allocated memory - deallocate(idx,x1d) -end subroutine read_tile_data_i0d_fptr - -subroutine read_tile_data_r0d_fptr_r0(ncid,name,fptr) - integer , intent(in) :: ncid ! netcdf file id - character(*), intent(in) :: name ! name of the variable to read - procedure(fptr_r0) :: fptr ! subroutine returning the pointer to the - ! data to be written - ! ---- local constants - character(*), parameter :: module_name='read_tile_data_r0d_fptr_r0' - ! ---- local vars - integer :: ndims ! number of the variable dimensions - integer :: dimids(1) ! IDs of the variable dimensions - integer :: dimlen(1) ! size of the variable dimensions - character(NF_MAX_NAME) :: idxname ! name of the index variable - integer, allocatable :: idx(:) ! storage for compressed index - real , allocatable :: x1d(:) ! storage for the data - integer :: i, j, bufsize - integer :: varid, idxid - type(land_tile_type), pointer :: tileptr ! pointer to tile - real, pointer :: ptr - - ! get the number of variable dimensions, and their lengths - __NF_ASRT__(nfu_inq_var(ncid,name,id=varid,ndims=ndims,dimids=dimids,dimlens=dimlen)) - if(ndims/=1) then - call error_mesg(module_name,'variable "'//trim(name)//'" has incorrect number of dimensions -- must be 1-dimensional', FATAL) - endif - ! get the name of compressed dimension and ID of corresponding variable - __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),idxname)) - __NF_ASRT__(nfu_inq_var(ncid,idxname,id=idxid)) - ! allocate input buffers for compression index and the variable - bufsize=min(input_buf_size,dimlen(1)) - allocate(idx(bufsize),x1d(bufsize)) - ! read the input buffer-by-buffer - do j = 1,dimlen(1),bufsize - ! read the index variable - __NF_ASRT__(nf_get_vara_int(ncid,idxid,(/j/),(/min(bufsize,dimlen(1)-j+1)/),idx)) - ! read the data - __NF_ASRT__(nf_get_vara_double(ncid,varid,(/j/),(/min(bufsize,dimlen(1)-j+1)/),x1d)) - ! distribute the data over the tiles - do i = 1, min(bufsize,dimlen(1)-j+1) - call get_tile_by_idx(idx(i), tileptr) - call fptr(tileptr, ptr) - if(associated(ptr)) ptr = x1d(i) - enddo - enddo - ! release allocated memory - deallocate(idx,x1d) -end subroutine read_tile_data_r0d_fptr_r0 - -subroutine read_tile_data_r0d_fptr_r0i (ncid,name,fptr,index) - integer , intent(in) :: ncid ! netcdf file id - character(*), intent(in) :: name ! name of the variable to read - procedure(fptr_r0i) :: fptr ! subroutine returning the pointer to the - ! data to be written - integer , intent(in) :: index ! index where to read the data - - ! ---- local constants - character(*), parameter :: module_name='read_tile_data_r0d_fptr_r0i' - ! ---- local vars - integer :: ndims ! number of the variable dimensions - integer :: dimids(1) ! IDs of the variable dimensions - integer :: dimlen(1) ! size of the variable dimensions - character(NF_MAX_NAME) :: idxname ! name of the index variable - integer, allocatable :: idx(:) ! storage for compressed index - real , allocatable :: x1d(:) ! storage for the data - integer :: i,j,bufsize - integer :: varid, idxid - type(land_tile_type), pointer :: tileptr ! pointer to tile - real, pointer :: ptr - - ! get the number of variable dimensions, and their lengths - __NF_ASRT__(nfu_inq_var(ncid,name,id=varid,ndims=ndims,dimids=dimids,dimlens=dimlen)) - if(ndims/=1) then - call error_mesg(module_name,'variable "'//trim(name)//'" has incorrect number of dimensions -- must be 1-dimensional', FATAL) - endif - ! get the name of compressed dimension and ID of corresponding variable - __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),idxname)) - __NF_ASRT__(nfu_inq_var(ncid,idxname,id=idxid)) - ! allocate input buffers for compression index and the variable - bufsize=min(input_buf_size,dimlen(1)) - allocate(idx(bufsize),x1d(bufsize)) - ! read the input buffer-by-buffer - do j = 1,dimlen(1),bufsize - ! read the index variable - __NF_ASRT__(nf_get_vara_int(ncid,idxid,(/j/),(/min(bufsize,dimlen(1)-j+1)/),idx)) - ! read the data - __NF_ASRT__(nf_get_vara_double(ncid,varid,(/j/),(/min(bufsize,dimlen(1)-j+1)/),x1d)) - ! distribute the data over the tiles - do i = 1, min(bufsize,dimlen(1)-j+1) - call get_tile_by_idx(idx(i), tileptr) - call fptr(tileptr, index, ptr) - if(associated(ptr)) ptr = x1d(i) - enddo - enddo - ! release allocated memory - deallocate(idx,x1d) -end subroutine read_tile_data_r0d_fptr_r0i - -subroutine read_tile_data_r0d_fptr_r0ij (ncid,name,fptr,idx1,idx2) - integer , intent(in) :: ncid ! netcdf file id - character(*), intent(in) :: name ! name of the variable to read - procedure(fptr_r0ij) :: fptr ! subroutine returning the pointer to the - ! data to be written - integer , intent(in) :: idx1,idx2 ! index where to read the data - - ! ---- local constants - character(*), parameter :: module_name='read_tile_data_r0d_fptr_r0i' - ! ---- local vars - integer :: ndims ! number of the variable dimensions - integer :: dimids(1) ! IDs of the variable dimensions - integer :: dimlen(1) ! size of the variable dimensions - character(NF_MAX_NAME) :: idxname ! name of the index variable - integer, allocatable :: idx(:) ! storage for compressed index - real , allocatable :: x1d(:) ! storage for the data - integer :: i,j,bufsize - integer :: varid, idxid - type(land_tile_type), pointer :: tileptr ! pointer to tile - real, pointer :: ptr - - ! get the number of variable dimensions, and their lengths - __NF_ASRT__(nfu_inq_var(ncid,name,id=varid,ndims=ndims,dimids=dimids,dimlens=dimlen)) - if(ndims/=1) then - call error_mesg(module_name,'variable "'//trim(name)//'" has incorrect number of dimensions -- must be 1-dimensional', FATAL) - endif - ! get the name of compressed dimension and ID of corresponding variable - __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),idxname)) - __NF_ASRT__(nfu_inq_var(ncid,idxname,id=idxid)) - ! allocate input buffers for compression index and the variable - bufsize=min(input_buf_size,dimlen(1)) - allocate(idx(bufsize),x1d(bufsize)) - ! read the input buffer-by-buffer - do j = 1,dimlen(1),bufsize - ! read the index variable - __NF_ASRT__(nf_get_vara_int(ncid,idxid,(/j/),(/min(bufsize,dimlen(1)-j+1)/),idx)) - ! read the data - __NF_ASRT__(nf_get_vara_double(ncid,varid,(/j/),(/min(bufsize,dimlen(1)-j+1)/),x1d)) - ! distribute the data over the tiles - do i = 1, min(bufsize,dimlen(1)-j+1) - call get_tile_by_idx(idx(i), tileptr) - call fptr(tileptr, idx1,idx2, ptr) - if(associated(ptr)) ptr = x1d(i) - enddo - enddo - ! release allocated memory - deallocate(idx,x1d) -end subroutine read_tile_data_r0d_fptr_r0ij - -subroutine read_tile_data_i1d_fptr_i0i(ncid,name,fptr) - integer , intent(in) :: ncid ! netcdf file id - character(*), intent(in) :: name ! name of the variable to read - procedure(fptr_i0i) :: fptr ! subroutine returning the pointer to the data - - ! ---- local constants - character(*), parameter :: module_name='read_tile_data_i1d_fptr_i0i' - ! ---- local vars - integer :: ndims ! number of the variable dimensions - integer :: dimids(2) ! IDs of the variable dimensions - integer :: dimlen(2) ! size of the variable dimensions - character(NF_MAX_NAME) :: idxname ! name of the index variable - integer, allocatable :: idx(:) ! storage for compressed index - integer, allocatable :: x1d(:) ! storage for the data - integer :: i, j, n, bufsize - integer :: varid,idxid - integer :: start(2), count(2) ! input slab parameters - type(land_tile_type), pointer :: tileptr ! pointer to tile - integer, pointer :: ptr - - ! get the number of variable dimensions, and their lengths - __NF_ASRT__(nfu_inq_var(ncid,name,id=varid,ndims=ndims,dimids=dimids,dimlens=dimlen)) - if(ndims/=2) then - call error_mesg(module_name,'variable "'//trim(name)//'" has incorrect number of dimensions -- must be 2-dimensional', FATAL) - endif - ! get the name of compressed dimension and ID of corresponding variable - __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),idxname)) - __NF_ASRT__(nfu_inq_var(ncid,idxname,id=idxid)) - ! allocate input buffers for compression index and the variable - bufsize=min(input_buf_size,dimlen(1)) - allocate(idx(bufsize),x1d(bufsize*dimlen(2))) - ! read the input buffer-by-buffer - do j = 1,dimlen(1),bufsize - ! set up slab parameters - start(1) = j ; count(1) = min(bufsize,dimlen(1)-j+1) - start(2) = 1 ; count(2) = dimlen(2) - ! read the index variable - __NF_ASRT__(nf_get_vara_int(ncid,idxid,start(1),count(1),idx)) - ! read the data - __NF_ASRT__(nf_get_vara_int(ncid,varid,start,count,x1d)) - ! distribute the data over the tiles - do i = 1, min(bufsize,dimlen(1)-j+1) - call get_tile_by_idx(idx(i), tileptr) - do n = 1,count(2) - call fptr(tileptr, n, ptr) - if(associated(ptr)) ptr = x1d(i+count(1)*(n-1)) - enddo - enddo - enddo - ! release allocated memory - deallocate(idx,x1d) -end subroutine read_tile_data_i1d_fptr_i0i - -subroutine read_tile_data_r1d_fptr_r0i(ncid,name,fptr) - integer , intent(in) :: ncid ! netcdf file id - character(*), intent(in) :: name ! name of the variable to read - procedure(fptr_r0i) :: fptr ! subroutine returning the pointer to the data - - ! ---- local constants - character(*), parameter :: module_name='read_tile_data_r1d_fptr_r0i' - ! ---- local vars - integer :: ndims ! number of the variable dimensions - integer :: dimids(2) ! IDs of the variable dimensions - integer :: dimlen(2) ! size of the variable dimensions - character(NF_MAX_NAME) :: idxname ! name of the index variable - integer, allocatable :: idx(:) ! storage for compressed index - real , allocatable :: x1d(:) ! storage for the data - integer :: i, j, n, bufsize - integer :: varid,idxid - integer :: start(2), count(2) ! input slab parameters - type(land_tile_type), pointer :: tileptr ! pointer to tile - real, pointer :: ptr - - ! get the number of variable dimensions, and their lengths - __NF_ASRT__(nfu_inq_var(ncid,name,id=varid,ndims=ndims,dimids=dimids,dimlens=dimlen)) - if(ndims/=2) then - call error_mesg(module_name,'variable "'//trim(name)//'" has incorrect number of dimensions -- must be 2-dimensional', FATAL) - endif - ! get the name of compressed dimension and ID of corresponding variable - __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),idxname)) - __NF_ASRT__(nfu_inq_var(ncid,idxname,id=idxid)) - ! allocate input buffers for compression index and the variable - bufsize=min(input_buf_size,dimlen(1)) - allocate(idx(bufsize),x1d(bufsize*dimlen(2))) - ! read the input buffer-by-buffer - do j = 1,dimlen(1),bufsize - ! set up slab parameters - start(1) = j ; count(1) = min(bufsize,dimlen(1)-j+1) - start(2) = 1 ; count(2) = dimlen(2) - ! read the index variable - __NF_ASRT__(nf_get_vara_int(ncid,idxid,start(1),count(1),idx)) - ! read the data - __NF_ASRT__(nf_get_vara_double(ncid,varid,start,count,x1d)) - ! distribute the data over the tiles - do i = 1, min(bufsize,dimlen(1)-j+1) - call get_tile_by_idx(idx(i), tileptr) - do n = 1,count(2) - call fptr(tileptr, n, ptr) - if(associated(ptr)) ptr = x1d(i+count(1)*(n-1)) - enddo - enddo - enddo - ! release allocated memory - deallocate(idx,x1d) -end subroutine read_tile_data_r1d_fptr_r0i - -subroutine read_tile_data_r1d_fptr_r0ij(ncid,name,fptr,index) - integer , intent(in) :: ncid ! netcdf file id - character(*), intent(in) :: name ! name of the variable to read - procedure(fptr_r0ij) :: fptr ! subroutine returning the pointer to the data - integer , intent(in) :: index - - ! ---- local constants - character(*), parameter :: module_name='read_tile_data_r1d_fptr_r0ij' - ! ---- local vars - integer :: ndims ! number of the variable dimensions - integer :: dimids(2) ! IDs of the variable dimensions - integer :: dimlen(2) ! size of the variable dimensions - character(NF_MAX_NAME) :: idxname ! name of the index variable - integer, allocatable :: idx(:) ! storage for compressed index - real , allocatable :: x1d(:) ! storage for the data - integer :: i, j, n, bufsize - integer :: varid,idxid - integer :: start(2), count(2) ! input slab parameters - type(land_tile_type), pointer :: tileptr ! pointer to tile - real, pointer :: ptr - - ! get the number of variable dimensions, and their lengths - __NF_ASRT__(nfu_inq_var(ncid,name,id=varid,ndims=ndims,dimids=dimids,dimlens=dimlen)) - if(ndims/=2) then - call error_mesg(module_name,'variable "'//trim(name)//'" has incorrect number of dimensions -- must be 2-dimensional', FATAL) - endif - ! get the name of compressed dimension and ID of corresponding variable - __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),idxname)) - __NF_ASRT__(nfu_inq_var(ncid,idxname,id=idxid)) - ! allocate input buffers for compression index and the variable - bufsize=min(input_buf_size,dimlen(1)) - allocate(idx(bufsize),x1d(bufsize*dimlen(2))) - ! read the input buffer-by-buffer - do j = 1,dimlen(1),bufsize - ! set up slab parameters - start(1) = j ; count(1) = min(bufsize,dimlen(1)-j+1) - start(2) = 1 ; count(2) = dimlen(2) - ! read the index variable - __NF_ASRT__(nf_get_vara_int(ncid,idxid,start(1),count(1),idx)) - ! read the data - __NF_ASRT__(nf_get_vara_double(ncid,varid,start,count,x1d)) - ! distribute the data over the tiles - do i = 1, min(bufsize,dimlen(1)-j+1) - call get_tile_by_idx(idx(i), tileptr) - do n = 1,count(2) - call fptr(tileptr, n, index, ptr) - if(associated(ptr)) ptr = x1d(i+count(1)*(n-1)) - enddo - enddo - enddo - ! release allocated memory - deallocate(idx,x1d) -end subroutine read_tile_data_r1d_fptr_r0ij - -subroutine read_tile_data_r1d_fptr_r0ijk(ncid,name,fptr,idx1,idx2) - integer , intent(in) :: ncid ! netcdf file id - character(*), intent(in) :: name ! name of the variable to read - procedure(fptr_r0ijk) :: fptr ! subroutine returning the pointer to the data - integer , intent(in) :: idx1,idx2 - - ! ---- local constants - character(*), parameter :: module_name='read_tile_data_r1d_fptr_r0ijk' - ! ---- local vars - integer :: ndims ! number of the variable dimensions - integer :: dimids(2) ! IDs of the variable dimensions - integer :: dimlen(2) ! size of the variable dimensions - character(NF_MAX_NAME) :: idxname ! name of the index variable - integer, allocatable :: idx(:) ! storage for compressed index - real , allocatable :: x1d(:) ! storage for the data - integer :: i, j, n, bufsize - integer :: varid,idxid - integer :: start(2), count(2) ! input slab parameters - type(land_tile_type), pointer :: tileptr ! pointer to tile - real, pointer :: ptr - - ! get the number of variable dimensions, and their lengths - __NF_ASRT__(nfu_inq_var(ncid,name,id=varid,ndims=ndims,dimids=dimids,dimlens=dimlen)) - if(ndims/=2) then - call error_mesg(module_name,'variable "'//trim(name)//'" has incorrect number of dimensions -- must be 2-dimensional', FATAL) - endif - ! get the name of compressed dimension and ID of corresponding variable - __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),idxname)) - __NF_ASRT__(nfu_inq_var(ncid,idxname,id=idxid)) - ! allocate input buffers for compression index and the variable - bufsize=min(input_buf_size,dimlen(1)) - allocate(idx(bufsize),x1d(bufsize*dimlen(2))) - ! read the input buffer-by-buffer - do j = 1,dimlen(1),bufsize - ! set up slab parameters - start(1) = j ; count(1) = min(bufsize,dimlen(1)-j+1) - start(2) = 1 ; count(2) = dimlen(2) - ! read the index variable - __NF_ASRT__(nf_get_vara_int(ncid,idxid,start(1),count(1),idx)) - ! read the data - __NF_ASRT__(nf_get_vara_double(ncid,varid,start,count,x1d)) - ! distribute the data over the tiles - do i = 1, min(bufsize,dimlen(1)-j+1) - call get_tile_by_idx(idx(i), tileptr) - do n = 1,count(2) - call fptr(tileptr, n, idx1,idx2, ptr) - if(associated(ptr)) ptr = x1d(i+count(1)*(n-1)) - enddo - enddo - enddo - ! release allocated memory - deallocate(idx,x1d) -end subroutine read_tile_data_r1d_fptr_r0ijk - -subroutine read_tile_data_r2d_fptr_r0ij (ncid,name,fptr) - integer , intent(in) :: ncid ! netcdf file id - character(*), intent(in) :: name ! name of the variable to read - procedure(fptr_r0ij) :: fptr ! subroutine returning the pointer to the data - - ! ---- local constants - character(*), parameter :: module_name='read_tile_data_r2d_fptr_r0ij' - ! ---- local vars - integer :: ndims ! number of the variable dimensions - integer :: dimids(3) ! IDs of the variable dimensions - integer :: dimlen(3) ! size of the variable dimensions - character(NF_MAX_NAME) :: idxname ! name of the index variable - integer, allocatable :: idx(:) ! storage for compressed index - real , allocatable :: x1d(:) ! storage for the data - integer :: i,j,m,n,bufsize - integer :: varid, idxid - integer :: start(3), count(3) ! input slab parameters - type(land_tile_type), pointer :: tileptr ! pointer to tile - real, pointer :: ptr - - ! get the number of variable dimensions, and their lengths - __NF_ASRT__(nfu_inq_var(ncid,name,id=varid,ndims=ndims,dimids=dimids,dimlens=dimlen)) - if(ndims/=3) then - call error_mesg(module_name,'variable "'//trim(name)//'" has incorrect number of dimensions -- must be 3-dimensional', FATAL) - endif - ! get the name of compressed dimension and ID of corresponding variable - __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),idxname)) - __NF_ASRT__(nfu_inq_var(ncid,idxname,id=idxid)) - ! allocate input buffers for compression index and the variable - bufsize=min(input_buf_size,dimlen(1)) - allocate(idx(bufsize),x1d(bufsize*dimlen(2)*dimlen(3))) - ! read the input buffer-by-buffer - do j = 1,dimlen(1),bufsize - ! set up slab parameters - start(1) = j ; count(1) = min(bufsize,dimlen(1)-j+1) - start(2) = 1 ; count(2) = dimlen(2) - start(3) = 1 ; count(3) = dimlen(3) - ! read the index variable - __NF_ASRT__(nf_get_vara_int(ncid,idxid,start(1),count(1),idx)) - ! read the data - __NF_ASRT__(nf_get_vara_double(ncid,varid,start,count,x1d)) - ! distribute the data over the tiles - do i = 1, min(bufsize,dimlen(1)-j+1) - call get_tile_by_idx(idx(i), tileptr) - do m = 1,dimlen(2) - do n = 1,dimlen(3) - call fptr(tileptr, m, n, ptr) - if(associated(ptr)) ptr = x1d(i+count(1)*(m-1)+count(1)*count(2)*(n-1)) - enddo - enddo - enddo - enddo - ! release allocated memory - deallocate(idx,x1d) -end subroutine read_tile_data_r2d_fptr_r0ij - -subroutine read_tile_data_r2d_fptr_r0ijk (ncid,name,fptr,index) - integer , intent(in) :: ncid ! netcdf file id - character(*), intent(in) :: name ! name of the variable to read - procedure(fptr_r0ijk) :: fptr ! subroutine returning the pointer to the data - integer, intent(in) :: index - - ! ---- local constants - character(*), parameter :: module_name='read_tile_data_r2d_fptr_r0ijk' - ! ---- local vars - integer :: ndims ! number of the variable dimensions - integer :: dimids(3) ! IDs of the variable dimensions - integer :: dimlen(3) ! size of the variable dimensions - character(NF_MAX_NAME) :: idxname ! name of the index variable - integer, allocatable :: idx(:) ! storage for compressed index - real , allocatable :: x1d(:) ! storage for the data - integer :: i,j,m,n,bufsize - integer :: varid, idxid - integer :: start(3), count(3) ! input slab parameters - type(land_tile_type), pointer :: tileptr ! pointer to tile - real, pointer :: ptr - - ! get the number of variable dimensions, and their lengths - __NF_ASRT__(nfu_inq_var(ncid,name,id=varid,ndims=ndims,dimids=dimids,dimlens=dimlen)) - if(ndims/=3) then - call error_mesg(module_name,'variable "'//trim(name)//'" has incorrect number of dimensions -- must be 3-dimensional', FATAL) - endif - ! get the name of compressed dimension and ID of corresponding variable - __NF_ASRT__(nfu_inq_dim(ncid,dimids(1),idxname)) - __NF_ASRT__(nfu_inq_var(ncid,idxname,id=idxid)) - ! allocate input buffers for compression index and the variable - bufsize=min(input_buf_size,dimlen(1)) - allocate(idx(bufsize),x1d(bufsize*dimlen(2)*dimlen(3))) - ! read the input buffer-by-buffer - do j = 1,dimlen(1),bufsize - ! set up slab parameters - start(1) = j ; count(1) = min(bufsize,dimlen(1)-j+1) - start(2) = 1 ; count(2) = dimlen(2) - start(3) = 1 ; count(3) = dimlen(3) - ! read the index variable - __NF_ASRT__(nf_get_vara_int(ncid,idxid,start(1),count(1),idx)) - ! read the data - __NF_ASRT__(nf_get_vara_double(ncid,varid,start,count,x1d)) - ! distribute the data over the tiles - do i = 1, min(bufsize,dimlen(1)-j+1) - call get_tile_by_idx(idx(i), tileptr) - do m = 1,dimlen(2) - do n = 1,dimlen(3) - call fptr(tileptr, m, n, index, ptr) - if(associated(ptr)) ptr = x1d(i+count(1)*(m-1)+count(1)*count(2)*(n-1)) - enddo - enddo - enddo - enddo - ! release allocated memory - deallocate(idx,x1d) -end subroutine read_tile_data_r2d_fptr_r0ijk - - -! ============================================================================ -! The subroutines write_tile_data_* below write tiled data (that is, data provided -! in arrays congruous with current tiling) to NetCDF files using "compression -! by gathering" (see CF conventions). They assume that the compressed dimension -! is already created, has certain name (see parameter "tile_index_name" at the beginning -! of this file), is written in the same order. - -! ============================================================================ -! writes out 1-d integer tiled data using "compression by gathering" -subroutine write_tile_data_i1d(ncid,name,data,long_name,units) - integer , intent(in) :: ncid - character(len=*), intent(in) :: name - integer , intent(in) :: data(:) ! data to write - character(len=*), intent(in), optional :: units, long_name - - ! local vars - integer :: varid,iret,p,k - integer, allocatable :: buffer(:) ! data buffers - integer, allocatable :: ntiles(:) ! list of land tile numbers for each of PEs in io_domain - - if (mpp_pe()/=lnd%io_pelist(1)) then - call mpp_send(size(data), plen=1, to_pe=lnd%io_pelist(1), tag=COMM_TAG_3) - call mpp_send(data(1), plen=size(data), to_pe=lnd%io_pelist(1), tag=COMM_TAG_4) - else - allocate(ntiles(size(lnd%io_pelist))) - ntiles(1) = size(data) - do p = 2,size(lnd%io_pelist) - call mpp_recv(ntiles(p), from_pe=lnd%io_pelist(p), glen=1, tag=COMM_TAG_3) - enddo - ! gather data from all processors in io_domain - allocate(buffer(sum(ntiles(:)))) - buffer(1:ntiles(1)) = data(:) - k=ntiles(1)+1 - do p = 2,size(lnd%io_pelist) - call mpp_recv(buffer(k), glen=ntiles(p), from_pe=lnd%io_pelist(p), tag=COMM_TAG_4) - k = k+ntiles(p) - enddo - ! create variable, if it does not exist - if(nf_inq_varid(ncid,name,varid)/=NF_NOERR) then - __NF_ASRT__(nfu_def_var(ncid,name,NF_INT,(/tile_index_name/),long_name,units,varid)) - endif - ! write data - iret = nf_enddef(ncid) ! ignore errors (file may be in data mode already) - __NF_ASRT__(nf_put_var_int(ncid,varid,buffer)) - endif - ! wait for all PEs to finish: necessary because mpp_send does not seem to - ! copy the data, and therefore on non-root io_domain PE there would be a chance - ! that the data and mask are destroyed before they are actually sent. - call mpp_sync() -end subroutine write_tile_data_i1d - -! ============================================================================ -! writes out 1-d real tiled data using "compression by gathering" -subroutine write_tile_data_r1d(ncid,name,data,long_name,units) - integer , intent(in) :: ncid ! netcdf ID - character(len=*), intent(in) :: name ! name of the variable - real , intent(in) :: data(:) ! data to write - character(len=*), intent(in), optional :: units, long_name ! attributes - - ! ---- local vars - integer :: varid,iret,p,k - real, allocatable :: buffer(:) ! data buffer - integer, allocatable :: ntiles(:) ! list of land tile numbers for each of PEs in io_domain - - ! if our PE does not do IO (that is, it is not the root io_domain processor), - ! simply send data size and data the root IO processor - if (mpp_pe()/=lnd%io_pelist(1)) then - call mpp_send(size(data), plen=1, to_pe=lnd%io_pelist(1), tag=COMM_TAG_5) - call mpp_send(data(1), plen=size(data), to_pe=lnd%io_pelist(1), tag=COMM_TAG_6) - else - allocate(ntiles(size(lnd%io_pelist))) - ntiles(1) = size(data) - do p = 2,size(lnd%io_pelist) - call mpp_recv(ntiles(p), from_pe=lnd%io_pelist(p), glen=1, tag=COMM_TAG_5) - enddo - ! gather data from the processors in io_domain - allocate(buffer(sum(ntiles(:)))) - buffer(1:ntiles(1)) = data(:) - k=ntiles(1)+1 - do p = 2,size(lnd%io_pelist) - call mpp_recv(buffer(k), glen=ntiles(p), from_pe=lnd%io_pelist(p), tag=COMM_TAG_6) - k = k+ntiles(p) - enddo - ! create variable, if it does not exist - if(nf_inq_varid(ncid,name,varid)/=NF_NOERR) then - __NF_ASRT__(nfu_def_var(ncid,name,NF_DOUBLE,(/tile_index_name/),long_name,units,varid)) - endif - ! write data - iret = nf_enddef(ncid) ! ignore errors (file may be in data mode already) - __NF_ASRT__(nf_put_var_double(ncid,varid,buffer)) - deallocate(buffer,ntiles) - endif - ! wait for all PEs to finish: necessary because mpp_send does not seem to - ! copy the data, and therefore on non-root io_domain PE there would be a chance - ! that the data and mask are destroyed before they are actually sent. - call mpp_sync() -end subroutine write_tile_data_r1d - -! ============================================================================ -! writes out 2-d integer tiled data using "compression by gathering". The dimension -! of the data is (tile,z), and both tile and z dimensions are assumed to be -! already created -subroutine write_tile_data_i2d(ncid,name,data,zdim,long_name,units) - integer , intent(in) :: ncid ! netcdf id - character(len=*), intent(in) :: name ! name of the variable to write - character(len=*), intent(in) :: zdim ! name of the z-dimension - integer , intent(inout) :: data(:,:) ! (tile,z) - character(len=*), intent(in), optional :: units, long_name - ! data and mask are "inout" to save the memory on send-receive buffers. On the - ! root io_domain PE mask is destroyed and data is filled with the information - ! from other PEs in our io_domain. On other PEs these arrays reman intact. - - ! local vars - integer :: varid,iret,p,i,k - character(NF_MAX_NAME)::dimnames(2) - integer, allocatable :: buff2(:,:), buff1(:) ! send/receive buffers - integer, allocatable :: ntiles(:) ! list of land tile numbers for each of PEs in io_domain - - ! if our PE does not do io (that is, it is not the root io_domain processor), - ! simply send the data and mask of valid data to the root IO processor - if (mpp_pe()/=lnd%io_pelist(1)) then - call mpp_send(size(data,1), plen=1, to_pe=lnd%io_pelist(1), tag=COMM_TAG_7) - call mpp_send(data(1,1), plen=size(data), to_pe=lnd%io_pelist(1), tag=COMM_TAG_8) - else - allocate(ntiles(size(lnd%io_pelist))) - ntiles(1) = size(data,1) - do p = 2,size(lnd%io_pelist) - call mpp_recv(ntiles(p), from_pe=lnd%io_pelist(p), glen=1, tag=COMM_TAG_7) - enddo - allocate(buff2(sum(ntiles),size(data,2)),buff1(maxval(ntiles)*size(data,2))) - ! gather data from the processors in our io_domain - buff2(1:ntiles(1),:) = data(:,:) - k=ntiles(1) - do p = 2,size(lnd%io_pelist) - call mpp_recv(buff1(1), glen=ntiles(p)*size(data,2), from_pe=lnd%io_pelist(p), tag=COMM_TAG_8) - do i = 1,size(data,2) - buff2(k+1:k+ntiles(p),i) = buff1((i-1)*ntiles(p)+1:i*ntiles(p)) - enddo - k = k+ntiles(p) - enddo - - ! create variable, if it does not exist - if(nf_inq_varid(ncid,name,varid)/=NF_NOERR) then - dimnames(1) = tile_index_name - dimnames(2) = zdim - __NF_ASRT__(nfu_def_var(ncid,name,NF_INT,dimnames,long_name,units,varid)) - endif - ! write data - iret = nf_enddef(ncid) ! ignore errors: its OK if file is in data mode already - __NF_ASRT__(nf_put_var_int(ncid,varid,buff2)) - deallocate(buff2,buff1,ntiles) - endif - ! wait for all PEs to finish: necessary because mpp_send does not seem to - ! copy the data, and therefore on non-root io_domain PE there would be a chance - ! that the data and mask are destroyed before they are actually sent. - call mpp_sync() -end subroutine write_tile_data_i2d - -! ============================================================================ -! writes out 2-d real tiled data using "compression by gathering". The dimension -! of the data is (tile,z), and both tile and z dimensions are assumed to be -! already created -subroutine write_tile_data_r2d(ncid,name,data,zdim,long_name,units) - integer , intent(in) :: ncid ! netcdf id - character(len=*), intent(in) :: name ! name of the variable to write - character(len=*), intent(in) :: zdim ! name of the z-dimension - real , intent(in) :: data(:,:) ! (tile,z) - character(len=*), intent(in), optional :: units, long_name - - ! local vars - integer :: varid,iret,p,i,k - character(NF_MAX_NAME)::dimnames(2) - real, allocatable :: buff2(:,:), buff1(:) ! send/receive buffers - integer, allocatable :: ntiles(:) ! list of land tile numbers for each of PEs in io_domain - - ! if our PE does not do io (that is, it is not the root io_domain processor), - ! simply send the data and mask of valid data to the root IO processor - if (mpp_pe()/=lnd%io_pelist(1)) then - call mpp_send(size(data,1), plen=1, to_pe=lnd%io_pelist(1), tag=COMM_TAG_7) - call mpp_send(data(1,1), plen=size(data), to_pe=lnd%io_pelist(1), tag=COMM_TAG_8) - else - allocate(ntiles(size(lnd%io_pelist))) - ntiles(1) = size(data,1) - do p = 2,size(lnd%io_pelist) - call mpp_recv(ntiles(p), from_pe=lnd%io_pelist(p), glen=1, tag=COMM_TAG_7) - enddo - allocate(buff2(sum(ntiles),size(data,2)),buff1(maxval(ntiles)*size(data,2))) - ! gather data from the processors in our io_domain - buff2(1:ntiles(1),:) = data(:,:) - k=ntiles(1) - do p = 2,size(lnd%io_pelist) - call mpp_recv(buff1(1), glen=ntiles(p)*size(data,2), from_pe=lnd%io_pelist(p), tag=COMM_TAG_8) - do i = 1,size(data,2) - buff2(k+1:k+ntiles(p),i) = buff1((i-1)*ntiles(p)+1:i*ntiles(p)) - enddo - k = k+ntiles(p) - enddo - - ! create variable, if it does not exist - if(nf_inq_varid(ncid,name,varid)/=NF_NOERR) then - dimnames(1) = tile_index_name - dimnames(2) = zdim - __NF_ASRT__(nfu_def_var(ncid,name,NF_DOUBLE,dimnames,long_name,units,varid)) - endif - ! write data - iret = nf_enddef(ncid) ! ignore errors: its OK if file is in data mode already - __NF_ASRT__(nf_put_var_double(ncid,varid,buff2)) - deallocate(buff2,buff1,ntiles) - endif - ! wait for all PEs to finish: necessary because mpp_send does not seem to - ! copy the data, and therefore on non-root io_domain PE there would be a chance - ! that the data and mask are destroyed before they are actually sent. - call mpp_sync() -end subroutine write_tile_data_r2d - -! ============================================================================ -! writes out 3-d real tiled data using "compression by gathering". The dimension -! of the data is (tile,z,cohort), and both tile and z dimensions are assumed to be -! already created -subroutine write_tile_data_r3d(ncid,name,data,dim1,dim2,long_name,units) - integer , intent(in) :: ncid ! netcdf id - character(len=*), intent(in) :: name ! name of the variable to write - character(len=*), intent(in) :: dim1,dim2 ! names of dimensions - real , intent(in) :: data(:,:,:) ! (tile,dim1,dim2) - character(len=*), intent(in), optional :: units, long_name - - ! local vars - integer :: varid,iret,p,i,j,k,n - character(NF_MAX_NAME)::dimnames(3) - real, allocatable :: buff3(:,:,:),buff1(:) ! send/receive buffers - integer, allocatable :: ntiles(:) ! list of land tile numbers for each of PEs in io_domain - - ! if our PE does not do io (that is, it is not the root io_domain processor), - ! simply send the data and mask of valid data to the root IO processor - if (mpp_pe()/=lnd%io_pelist(1)) then - call mpp_send(size(data,1), plen=1, to_pe=lnd%io_pelist(1), tag=COMM_TAG_9) - call mpp_send(data(1,1,1), plen=size(data), to_pe=lnd%io_pelist(1), tag=COMM_TAG_10) - else - allocate(ntiles(size(lnd%io_pelist))) - ntiles(1) = size(data,1) - do p = 2,size(lnd%io_pelist) - call mpp_recv(ntiles(p), from_pe=lnd%io_pelist(p), glen=1, tag=COMM_TAG_9) - enddo - allocate(buff3(sum(ntiles),size(data,2),size(data,3)),& - buff1(maxval(ntiles)*size(data,2)*size(data,3))) - ! gather data from the processors in our io_domain - buff3(1:ntiles(1),:,:) = data(:,:,:) - k=ntiles(1) - do p = 2,size(lnd%io_pelist) - call mpp_recv(buff1(1), glen=ntiles(p)*size(data,2)*size(data,3), from_pe=lnd%io_pelist(p),& - tag=COMM_TAG_10) - n = 0 - do i = 1,size(data,2) - do j = 1,size(data,3) - buff3(k+1:k+ntiles(p),i,j) = buff1(n*ntiles(p)+1:(n+1)*ntiles(p)) - n = n+1 - enddo - enddo - k = k+ntiles(p) - enddo - ! create variable, if it does not exist - if(nf_inq_varid(ncid,name,varid)/=NF_NOERR) then - dimnames(1) = tile_index_name - dimnames(2) = dim1 - dimnames(3) = dim2 - __NF_ASRT__(nfu_def_var(ncid,name,NF_DOUBLE,dimnames,long_name,units,varid)) - endif - ! write data - iret = nf_enddef(ncid) ! ignore errors: its OK if file is in data mode already - __NF_ASRT__(nf_put_var_double(ncid,varid,buff3)) - endif - ! wait for all PEs to finish: necessary because mpp_send does not seem to - ! copy the data, and therefore on non-root io_domain PE there would be a chance - ! that the data and mask are destroyed before they are actually sent. - call mpp_sync() -end subroutine write_tile_data_r3d - ! ============================================================================ subroutine gather_tile_data_i0d(fptr,idx,data) procedure(fptr_i0) :: fptr ! subroutine returning pointer to the data @@ -2080,7 +1135,7 @@ subroutine gather_tile_data_i0d(fptr,idx,data) integer, pointer :: ptr ! pointer to the tile data integer :: i - data = NF_FILL_INT + data = NF90_FILL_INT ! gather data into an array along the tile dimension. It is assumed that ! the tile dimension spans all the tiles that need to be written. @@ -2101,7 +1156,7 @@ subroutine gather_tile_data_r0d(fptr,idx,data) real , pointer :: ptr ! pointer to the tile data integer :: i - data = NF_FILL_DOUBLE + data = NF90_FILL_DOUBLE ! gather data into an array along the tile dimension. It is assumed that ! the tile dimension spans all the tiles that need to be written. @@ -2123,7 +1178,7 @@ subroutine gather_tile_data_r0i(fptr,n,idx,data) real , pointer :: ptr ! pointer to the tile data integer :: i - data = NF_FILL_DOUBLE + data = NF90_FILL_DOUBLE ! gather data into an array along the tile dimension. It is assumed that ! the tile dimension spans all the tiles that need to be written. @@ -2145,7 +1200,7 @@ subroutine gather_tile_data_r0ij(fptr,n,m,idx,data) real , pointer :: ptr ! pointer to the tile data integer :: i - data = NF_FILL_DOUBLE + data = NF90_FILL_DOUBLE ! gather data into an array along the tile dimension. It is assumed that ! the tile dimension spans all the tiles that need to be written. @@ -2166,7 +1221,7 @@ subroutine gather_tile_data_r1d(fptr,idx,data) real , pointer :: ptr ! pointer to the tile data integer :: i,j - data = NF_FILL_DOUBLE + data = NF90_FILL_DOUBLE ! gather data into an array along the tile dimension. It is assumed that ! the tile dimension spans all the tiles that need to be written. @@ -2189,7 +1244,7 @@ subroutine gather_tile_data_i1d(fptr,idx,data) integer, pointer :: ptr ! pointer to the tile data integer :: i,j - data = NF_FILL_INT + data = NF90_FILL_INT ! gather data into an array along the tile dimension. It is assumed that ! the tile dimension spans all the tiles that need to be written. @@ -2212,7 +1267,7 @@ subroutine gather_tile_data_r2d(fptr,idx,data) real , pointer :: ptr ! pointer to the tile data integer :: i,k,m - data = NF_FILL_DOUBLE + data = NF90_FILL_DOUBLE ! gather data into an array along the tile dimension. It is assumed that ! the tile dimension spans all the tiles that need to be written. @@ -2238,7 +1293,7 @@ subroutine gather_tile_data_r2d_idx(fptr,n,idx,data) real , pointer :: ptr ! pointer to the tile data integer :: i,k,m - data = NF_FILL_DOUBLE + data = NF90_FILL_DOUBLE ! gather data into an array along the tile dimension. It is assumed that ! the tile dimension spans all the tiles that need to be written. diff --git a/shared/nf_utils/getput.inc b/shared/nf_utils/getput.inc deleted file mode 100644 index 19ab9152..00000000 --- a/shared/nf_utils/getput.inc +++ /dev/null @@ -1,582 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Flexible Modeling System (FMS). -!* -!* FMS 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 (at -!* your option) any later version. -!* -!* FMS is distributed in the hope that it will be useful, but WITHOUT -!* ANY WARRANTY; 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 FMS. If not, see . -!*********************************************************************** -! -*-f90-*- -! $Id$ - -! ============================================================================ -! nfu_get_var, nfu_get_rec interface and implementation -! ============================================================================ - -! some sanity checks -#ifndef F90_TYPE -#error F90_TYPE is not defined: must be one of FORTRAN 90 types -#endif - -#ifndef NF_TYPE -#error NF_TYPE is not defined: must be netcdf type name corresponding to F90_TYPE -#endif - -! macro definition for concatenation -- for construction of names based on the -! names of the operations, types, and dimension numbers -#define CONCAT3(op,T,D) op##T##D -#define CONCAT2(op,T) op##T - -! names of the functions we define -#define GET_VAR(T,D) CONCAT3(get_var_,T,D) -#define PUT_VAR(T,D) CONCAT3(put_var_,T,D) -#define GET_REC(T,D) CONCAT3(get_rec_,T,D) -#define PUT_REC(T,D) CONCAT3(put_rec_,T,D) - -! define names of the corresponding netcdf functions. The two-stage definition is -! necessary because of the preprocessor argument pre-scan rules. See, for example, -! http://gcc.gnu.org/onlinedocs/cpp/Argument-Prescan.html -#define NF_GET_VAR_(T) CONCAT2(nf_get_var_,T) -#define NF_GET_VAR_T NF_GET_VAR_(NF_TYPE) - -#define NF_PUT_VAR_(T) CONCAT2(nf_put_var_,T) -#define NF_PUT_VAR_T NF_PUT_VAR_(NF_TYPE) - -#define NF_GET_VARA_(T) CONCAT2(nf_get_vara_,T) -#define NF_GET_VARA_T NF_GET_VARA_(NF_TYPE) - -#define NF_PUT_VARA_(T) CONCAT2(nf_put_vara_,T) -#define NF_PUT_VARA_T NF_PUT_VARA_(NF_TYPE) - -! #### Interface definition ################################################### -! define specific names of the subroutines -#define GET_VAR_D0 GET_VAR(NF_TYPE, D0) -#define GET_VAR_D1 GET_VAR(NF_TYPE, D1) -#define GET_VAR_D2 GET_VAR(NF_TYPE, D2) -#define GET_VAR_D3 GET_VAR(NF_TYPE, D3) -#define GET_VAR_D4 GET_VAR(NF_TYPE, D4) - -#define PUT_VAR_D0 PUT_VAR(NF_TYPE, D0) -#define PUT_VAR_D1 PUT_VAR(NF_TYPE, D1) -#define PUT_VAR_D2 PUT_VAR(NF_TYPE, D2) -#define PUT_VAR_D3 PUT_VAR(NF_TYPE, D3) -#define PUT_VAR_D4 PUT_VAR(NF_TYPE, D4) - -#define GET_REC_D0N GET_REC(NF_TYPE, D0N) -#define GET_REC_D1N GET_REC(NF_TYPE, D1N) -#define GET_REC_D2N GET_REC(NF_TYPE, D2N) -#define GET_REC_D3N GET_REC(NF_TYPE, D3N) -#define GET_REC_D4N GET_REC(NF_TYPE, D4N) - -#define GET_REC_D0I GET_REC(NF_TYPE, D0I) -#define GET_REC_D1I GET_REC(NF_TYPE, D1I) -#define GET_REC_D2I GET_REC(NF_TYPE, D2I) -#define GET_REC_D3I GET_REC(NF_TYPE, D3I) -#define GET_REC_D4I GET_REC(NF_TYPE, D4I) - -#define PUT_REC_D0N PUT_REC(NF_TYPE, D0N) -#define PUT_REC_D1N PUT_REC(NF_TYPE, D1N) -#define PUT_REC_D2N PUT_REC(NF_TYPE, D2N) -#define PUT_REC_D3N PUT_REC(NF_TYPE, D3N) -#define PUT_REC_D4N PUT_REC(NF_TYPE, D4N) - -#define PUT_REC_D0I PUT_REC(NF_TYPE, D0I) -#define PUT_REC_D1I PUT_REC(NF_TYPE, D1I) -#define PUT_REC_D2I PUT_REC(NF_TYPE, D2I) -#define PUT_REC_D3I PUT_REC(NF_TYPE, D3I) -#define PUT_REC_D4I PUT_REC(NF_TYPE, D4I) - -#ifdef __INTERFACE_SECTION__ -! nfu_get_var interface -interface nfu_get_var - module procedure GET_VAR_D0, GET_VAR_D1, GET_VAR_D2, GET_VAR_D3, GET_VAR_D4 -end interface -interface nfu_put_var - module procedure PUT_VAR_D0, PUT_VAR_D1, PUT_VAR_D2, PUT_VAR_D3, PUT_VAR_D4 -end interface -interface nfu_get_rec - module procedure GET_REC_D0N, GET_REC_D1N, GET_REC_D2N, GET_REC_D3N, GET_REC_D4N - module procedure GET_REC_D0I, GET_REC_D1I, GET_REC_D2I, GET_REC_D3I, GET_REC_D4I -end interface -interface nfu_put_rec - module procedure PUT_REC_D0N, PUT_REC_D1N, PUT_REC_D2N, PUT_REC_D3N, PUT_REC_D4N - module procedure PUT_REC_D0I, PUT_REC_D1I, PUT_REC_D2I, PUT_REC_D3I, PUT_REC_D4I -end interface -#endif - -! #### END of interface definition ############################################ - - -! #### Implementation definition ############################################## - -#ifdef __BODY_SECTION__ -! ============================================================================ -! nfu_get_var implemenatation -! ============================================================================ -function GET_VAR_D0(ncid,name,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*), intent(in) :: name ! name of the variable - F90_TYPE , intent(inout) :: var ! storage for the variable - integer :: iret ! return value - - integer :: varid - __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7) - iret = NF_GET_VAR_T(ncid,varid,var) -7 return -end function -! ============================================================================ -function GET_VAR_D1(ncid,name,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*), intent(in) :: name ! name of the variable - F90_TYPE , intent(inout) :: var(*) ! storage for the variable - integer :: iret ! return value - - integer :: varid - __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7) - iret = NF_GET_VAR_T(ncid,varid,var) -7 return -end function -! ============================================================================ -function GET_VAR_D2(ncid,name,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*), intent(in) :: name ! name of the variable - F90_TYPE , intent(inout) :: var(:,:) ! storage for the variable - integer :: iret ! return value - - iret = GET_VAR_D1(ncid,name,var) -7 return -end function -! ============================================================================ -function GET_VAR_D3(ncid,name,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*), intent(in) :: name ! name of the variable - F90_TYPE , intent(inout) :: var(:,:,:) ! storage for the variable - integer :: iret ! return value - - iret = GET_VAR_D1(ncid,name,var) -7 return -end function -! ============================================================================ -function GET_VAR_D4(ncid,name,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*), intent(in) :: name ! name of the variable - F90_TYPE , intent(inout) :: var(:,:,:,:) ! storage for the variable - integer :: iret ! return value - - iret = GET_VAR_D1(ncid,name,var) -7 return -end function - -! ============================================================================ -function PUT_VAR_D0(ncid,name,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*), intent(in) :: name ! name of the variable - F90_TYPE , intent(in) :: var ! storage for the variable - integer :: iret ! return value - - integer :: varid - __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7) - iret = NF_PUT_VAR_T(ncid,varid,var) -7 return -end function -! ============================================================================ -function PUT_VAR_D1(ncid,name,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*), intent(in) :: name ! name of the variable - F90_TYPE , intent(in) :: var(*) ! storage for the variable - integer :: iret ! return value - - integer :: varid - __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7) - iret = NF_PUT_VAR_T(ncid,varid,var) -7 return -end function -! ============================================================================ -function PUT_VAR_D2(ncid,name,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*), intent(in) :: name ! name of the variable - F90_TYPE , intent(in) :: var(:,:) ! storage for the variable - integer :: iret ! return value - - integer :: varid - __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7) - iret = NF_PUT_VAR_T(ncid,varid,var) -7 return -end function -! ============================================================================ -function PUT_VAR_D3(ncid,name,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*), intent(in) :: name ! name of the variable - F90_TYPE , intent(in) :: var(:,:,:) ! storage for the variable - integer :: iret ! return value - - integer :: varid - __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7) - iret = NF_PUT_VAR_T(ncid,varid,var) -7 return -end function -! ============================================================================ -function PUT_VAR_D4(ncid,name,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*), intent(in) :: name ! name of the variable - F90_TYPE , intent(in) :: var(:,:,:,:) ! storage for the variable - integer :: iret ! return value - - integer :: varid - __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7) - iret = NF_PUT_VAR_T(ncid,varid,var) -7 return -end function - -! ============================================================================ -! nfu_get_rec implementation -! ============================================================================ -function GET_REC_D0N(ncid,name,rec,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*) , intent(in) :: name ! name of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(inout) :: var ! storage for the variable - integer :: iret ! return value - - F90_TYPE :: var1(1) - __NF_TRY__(GET_REC_D1N(ncid,name,rec,var1),iret,7) - var=var1(1) -7 return -end function -! ============================================================================ -function GET_REC_D1N(ncid,name,rec,var,start,count) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*) , intent(in) :: name ! name of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(inout) :: var(*) ! storage for the variable - integer, optional, intent(in) :: start(:), count(:) ! slab to read - integer :: iret ! return value - - integer :: varid - __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7) - __NF_TRY__(GET_REC_D1I(ncid,varid,rec,var,start,count),iret,7) -7 return -end function -! ============================================================================ -function GET_REC_D2N(ncid,name,rec,var,start,count) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*) , intent(in) :: name ! name of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(inout) :: var(:,:) ! storage for the variable - integer, optional, intent(in) :: start(2), count(2) ! slab to read - integer :: iret ! return value - - iret=GET_REC_D1N(ncid,name,rec,var,start,count) -end function -! ============================================================================ -function GET_REC_D3N(ncid,name,rec,var,start,count) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*) , intent(in) :: name ! name of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(inout) :: var(:,:,:) ! storage for the variable - integer, optional, intent(in) :: start(3), count(3) ! slab to read - integer :: iret ! return value - - iret=GET_REC_D1N(ncid,name,rec,var) -end function -! ============================================================================ -function GET_REC_D4N(ncid,name,rec,var,start,count) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*) , intent(in) :: name ! name of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(inout) :: var(:,:,:,:) ! storage for the variable - integer, optional, intent(in) :: start(4), count(4) ! slab to read - integer :: iret ! return value - - iret=GET_REC_D1N(ncid,name,rec,var) -end function -! ============================================================================ -function GET_REC_D0I(ncid,varid,rec,var,start) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - integer , intent(in) :: varid ! id of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(inout) :: var ! storage for the variable - integer, optional, intent(in) :: start(:) ! slab to read - integer :: iret ! return value - - F90_TYPE :: var1(1) - integer :: count_(NF_MAX_VAR_DIMS) - - count_(:) = 1 - __NF_TRY__(GET_REC_D1I(ncid,varid,rec,var1,start,count_),iret,7) - var=var1(1) -7 return -end function -! ============================================================================ -function GET_REC_D1I(ncid,varid,rec,var,start,count) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - integer , intent(in) :: varid ! id of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(inout) :: var(*) ! storage for the variable - integer , intent(in), optional :: start(:), count(:) ! definition of - ! the slab to read - integer :: iret ! return value - - integer :: dimids(NF_MAX_VAR_DIMS), ndims, unlimdim - integer :: start_(NF_MAX_VAR_DIMS) - integer :: count_(NF_MAX_VAR_DIMS) - integer :: i - - __NF_TRY__(nf_inq_unlimdim(ncid,unlimdim),iret,7) - __NF_TRY__(nf_inq_varndims(ncid,varid,ndims),iret,7) - __NF_TRY__(nf_inq_vardimid(ncid,varid,dimids),iret,7) - - do i = 1, ndims - if (dimids(i).eq.unlimdim) then - start_(i) = rec - count_(i) = 1 - else - start_(i) = 1 - __NF_TRY__(nf_inq_dimlen(ncid,dimids(i),count_(i)),iret,7) - if (present(start)) then - start_(i) = start(i) - count_(i) = count_(i)-start_(i)+1 - endif - if (present(count)) then - count_(i) = count(i) - endif - endif - ! write(*,*) i, dimids(i), start_(i), count_(i) - enddo - iret = NF_GET_VARA_T(ncid,varid,start_,count_,var) - -7 return -end function -! ============================================================================ -function GET_REC_D2I(ncid,varid,rec,var,start,count) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - integer , intent(in) :: varid ! id of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(inout) :: var(:,:) ! storage for the variable - integer , intent(in), optional :: start(2), count(2) ! definition of - ! the slab to read - integer :: iret ! return value - - iret=GET_REC_D1I(ncid,varid,rec,var,start,count) -end function -! ============================================================================ -function GET_REC_D3I(ncid,varid,rec,var,start,count) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - integer , intent(in) :: varid ! id of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(inout) :: var(:,:,:) ! storage for the variable - integer , intent(in), optional :: start(3), count(3) ! definition of - ! the slab to read - integer :: iret ! return value - - iret=GET_REC_D1I(ncid,varid,rec,var,start,count) -end function -! ============================================================================ -function GET_REC_D4I(ncid,varid,rec,var,start,count) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - integer , intent(in) :: varid ! id of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(inout) :: var(:,:,:,:) ! storage for the variable - integer , intent(in), optional :: start(4), count(4) ! definition of - ! the slab to read - integer :: iret ! return value - - iret=GET_REC_D1I(ncid,varid,rec,var,start,count) -end function - -! ============================================================================ -! nfu_put_rec implementation -! ============================================================================ -function PUT_REC_D0N(ncid,name,rec,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*) , intent(in) :: name ! name of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(in) :: var ! data to write - integer :: iret ! return value - - F90_TYPE :: var1(1) - var1(1)=var - iret = PUT_REC_D1N(ncid,name,rec,var1) -7 return -end function -! ============================================================================ -function PUT_REC_D1N(ncid,name,rec,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*) , intent(in) :: name ! name of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(in) :: var(*) ! data to write - integer :: iret ! return value - - integer :: varid - __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7) - __NF_TRY__(PUT_REC_D1I(ncid,varid,rec,var),iret,7) -7 return -end function -! ============================================================================ -function PUT_REC_D2N(ncid,name,rec,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*) , intent(in) :: name ! name of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(in) :: var(:,:) ! data to write - integer :: iret ! return value - - iret=PUT_REC_D1N(ncid,name,rec,var) -end function -! ============================================================================ -function PUT_REC_D3N(ncid,name,rec,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*) , intent(in) :: name ! name of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(in) :: var(:,:,:) ! data to write - integer :: iret ! return value - - iret=PUT_REC_D1N(ncid,name,rec,var) -end function -! ============================================================================ -function PUT_REC_D4N(ncid,name,rec,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - character(*) , intent(in) :: name ! name of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(in) :: var(:,:,:,:) ! data to write - integer :: iret ! return value - - iret=PUT_REC_D1N(ncid,name,rec,var) -end function -! ============================================================================ -function PUT_REC_D0I(ncid,varid,rec,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - integer , intent(in) :: varid ! id of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(in) :: var ! data to write - integer :: iret ! return value - - F90_TYPE :: var1(1) - var1(1)=var - iret = PUT_REC_D1I(ncid,varid,rec,var1) -end function -! ============================================================================ -function PUT_REC_D1I(ncid,varid,rec,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - integer , intent(in) :: varid ! id of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(in) :: var(*) ! data to write - integer :: iret ! return value - - integer :: dimids(NF_MAX_VAR_DIMS), ndims, unlimdim - integer :: start(NF_MAX_VAR_DIMS) - integer :: count(NF_MAX_VAR_DIMS) - integer :: i - - __NF_TRY__(nf_inq_unlimdim(ncid,unlimdim),iret,7) - __NF_TRY__(nf_inq_varndims(ncid,varid,ndims),iret,7) - __NF_TRY__(nf_inq_vardimid(ncid,varid,dimids),iret,7) - - do i = 1, ndims - if (dimids(i).eq.unlimdim) then - start(i) = rec - count(i) = 1 - else - start(i) = 1 - __NF_TRY__(nf_inq_dimlen(ncid,dimids(i),count(i)),iret,7) - endif - ! write(*,*) i, dimids(i), start(i), count(i) - enddo - i = nf_enddef(ncid) ! ignore errors here (the file may be in define mode already) - iret = NF_PUT_VARA_T(ncid,varid,start,count,var) - -7 return -end function -! ============================================================================ -function PUT_REC_D2I(ncid,varid,rec,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - integer , intent(in) :: varid ! id of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(in) :: var(:,:) ! data to write - integer :: iret ! return value - - iret=PUT_REC_D1I(ncid,varid,rec,var) -end function -! ============================================================================ -function PUT_REC_D3I(ncid,varid,rec,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - integer , intent(in) :: varid ! id of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(in) :: var(:,:,:) ! data to write - integer :: iret ! return value - - iret=PUT_REC_D1I(ncid,varid,rec,var) -end function -! ============================================================================ -function PUT_REC_D4I(ncid,varid,rec,var) result(iret) - integer , intent(in) :: ncid ! id of netcdf file - integer , intent(in) :: varid ! id of the variable - integer , intent(in) :: rec ! number of the record to get - F90_TYPE , intent(in) :: var(:,:,:,:) ! data to write - integer :: iret ! return value - - iret=PUT_REC_D1I(ncid,varid,rec,var) -end function -#endif -! #### End of implementation definition ###################################### -#undef CONCAT3 -#undef CONCAT2 - -#undef GET_VAR -#undef PUT_VAR -#undef GET_REC -#undef PUT_REC - -#undef NF_GET_VAR_ -#undef NF_GET_VAR_T - -#undef NF_PUT_VAR_ -#undef NF_PUT_VAR_T - -#undef NF_GET_VARA_ -#undef NF_GET_VARA_T - -#undef GET_VAR_D0 -#undef GET_VAR_D1 -#undef GET_VAR_D2 -#undef GET_VAR_D3 -#undef GET_VAR_D4 - -#undef PUT_VAR_D0 -#undef PUT_VAR_D1 -#undef PUT_VAR_D2 -#undef PUT_VAR_D3 -#undef PUT_VAR_D4 - -#undef GET_REC_D0N -#undef GET_REC_D1N -#undef GET_REC_D2N -#undef GET_REC_D3N -#undef GET_REC_D4N - -#undef GET_REC_D0I -#undef GET_REC_D1I -#undef GET_REC_D2I -#undef GET_REC_D3I -#undef GET_REC_D4I - -#undef PUT_REC_D0N -#undef PUT_REC_D1N -#undef PUT_REC_D2N -#undef PUT_REC_D3N -#undef PUT_REC_D4N - -#undef PUT_REC_D0I -#undef PUT_REC_D1I -#undef PUT_REC_D2I -#undef PUT_REC_D3I -#undef PUT_REC_D4I diff --git a/shared/nf_utils/getput_compressed.inc b/shared/nf_utils/getput_compressed.inc deleted file mode 100644 index 3feac954..00000000 --- a/shared/nf_utils/getput_compressed.inc +++ /dev/null @@ -1,476 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Flexible Modeling System (FMS). -!* -!* FMS 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 (at -!* your option) any later version. -!* -!* FMS is distributed in the hope that it will be useful, but WITHOUT -!* ANY WARRANTY; 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 FMS. If not, see . -!*********************************************************************** -! -*-f90-*- -! $Id$ - -! some sanity checks -#ifndef F90_TYPE -#error F90_TYPE is not defined: must be one of FORTRAN 90 types -#endif - -#ifndef NF_TYPE -#error NF_TYPE is not defined: must be netcdf type name corresponding to F90_TYPE -#endif - -! #### Basic macro definition ################################################# - -! macro definition for concatenation -- for construction of names based on the -! names of the operations, types, and dimension numbers -#define CONCAT3(op,T,D) op##T##D -#define CONCAT2(op,T) op##T - -! names of the functions we define in this module -#define GET_VAR(T,D) CONCAT3(get_compressed_var_,T,D) -#define PUT_VAR(T,D) CONCAT3(put_compressed_var_,T,D) -#define GET_REC(T,D) CONCAT3(get_compressed_rec_,T,D) - -! define names of the corresponding netcdf functions. The two-stage definition is -! necessary because of the preprocessor argument pre-scan rules. See, for example, -! http://gcc.gnu.org/onlinedocs/cpp/Argument-Prescan.html -#define NF_GET_VAR_(T) CONCAT2(nf_get_var_,T) -#define NF_GET_VAR_T NF_GET_VAR_(NF_TYPE) - -#define NF_PUT_VAR_(T) CONCAT2(nf_put_var_,T) -#define NF_PUT_VAR_T NF_PUT_VAR_(NF_TYPE) - -! #### Interface definition ################################################### -! define specific names of the subroutines -#define GET_VAR_D1N GET_VAR(NF_TYPE, D1N) -#define GET_VAR_D1I GET_VAR(NF_TYPE, D1I) - -#define PUT_VAR_D1N PUT_VAR(NF_TYPE, D1N) -#define PUT_VAR_D1I PUT_VAR(NF_TYPE, D1I) - -#define GET_REC_D4N GET_REC(NF_TYPE,D4N) -#define GET_REC_D3N GET_REC(NF_TYPE,D3N) -#define GET_REC_D2N GET_REC(NF_TYPE,D2N) -#define GET_REC_D1N GET_REC(NF_TYPE,D1N) -#define GET_REC_D1I GET_REC(NF_TYPE,D1I) - - -#ifdef __INTERFACE_SECTION__ - -interface nfu_get_compressed_var - module procedure GET_VAR_D1I, GET_VAR_D1N -end interface -interface nfu_put_compressed_var - module procedure PUT_VAR_D1I, PUT_VAR_D1N -end interface -interface nfu_get_compressed_rec - module procedure GET_REC_D1N,GET_REC_D2N,GET_REC_D3N,GET_REC_D4N,GET_REC_D1I -end interface -#endif -! #### END of interface definition ############################################ - - -! #### Implementation definition ############################################## -#ifdef __BODY_SECTION__ - -! =========================================================================== -function GET_VAR_D1N(ncid,name,data,mask) result (iret) - integer , intent(in) :: ncid - character(*) , intent(in) :: name - F90_TYPE , intent(inout) :: data(*) - logical, optional, intent(inout) :: mask(*) - integer :: iret - - integer :: varid - __NF_TRY__(nf_inq_varid(ncid, name, varid), iret, 7) - iret = GET_VAR(NF_TYPE,D1I)(ncid,varid,data,mask) -7 return -end function - -! =========================================================================== -function GET_VAR_D1I(ncid,varid,data,mask) result (iret) - integer , intent(in) :: ncid,varid - F90_TYPE , intent(inout) :: data(*) - logical, optional, intent(inout) :: mask(*) - integer :: iret - - integer :: ndims,dimids(NF_MAX_VAR_DIMS),dimlen - integer :: varsize ! total size of the compressed variable - integer :: cndims, cdimids(NF_MAX_VAR_DIMS),cdimlens(NF_MAX_VAR_DIMS) - character(NF_MAX_NAME) :: dimname - - F90_TYPE, allocatable :: buffer(:) - integer :: i, ii, n, length, idx(NF_MAX_VAR_DIMS) - integer :: stride - - type(diminfo_type) :: diminfo(NF_MAX_VAR_DIMS) - - ! get the information for the compressed variable - iret = nfu_inq_var(ncid,varid,ndims=ndims,dimids=dimids,varsize=varsize) - __NF_TRY__(iret,iret,7) - - ! get the compressed dimensions - stride = 1 - do i = 1,ndims - __NF_TRY__(nfu_inq_dim(ncid,dimids(i),len=diminfo(i)%length,name=dimname),iret,7) - if(nfu_inq_compressed_dim(ncid,dimids(i),& - ndims=cndims,dimids=cdimids,dimlens=cdimlens)==NF_NOERR) then - ! it is a compressed dimension; get dimension itself and calculate - ! get the dimension (that is, compression information) - __NF_TRY__(nfu_inq_dim(ncid,dimids(i),len=dimlen,name=dimname),iret,7) - allocate(diminfo(i)%idx(0:dimlen-1)) - __NF_TRY__(nfu_get_var(ncid,dimname,diminfo(i)%idx),iret,7) - ! calculate corresponding stride in output (unpacked) array - length = 1 - do n = 1,cndims - length = length*cdimlens(n) - enddo - else - length = diminfo(i)%length - endif - diminfo(i)%stride = stride - stride = stride*length - enddo - - ! get the entire variable - allocate(buffer(varsize)) - __NF_TRY__(NF_GET_VAR_T(ncid,varid,buffer),iret,7) - - ! move the data to the output buffer - idx(:) = 0 - do i = 1,size(buffer) - ! calculate destination index - ii = 1 - do n = 1,ndims - if(associated(diminfo(n)%idx)) then - if(diminfo(n)%idx(idx(n)) >= 0)then - ii = ii+diminfo(n)%idx(idx(n))*diminfo(n)%stride - else - ii = -1 ! set a value flagging an invalid point - exit ! from index loop - endif - else - ii = ii+idx(n)*diminfo(n)%stride - endif - enddo - - ! if index is negative, skip an invalid point - if (ii > 0) then - data(ii) = buffer(i) - if(present(mask))mask(ii) = .true. - endif - - ! increment indices - do n = 1,ndims - idx(n) = idx(n)+1 - if(idx(n)= 0)then - ii = ii+diminfo(n)%idx(idx(n))*diminfo(n)%stride - else - ii = -1 ! set a value flagging an invalid point - exit ! from index loop - endif - else - ii = ii+idx(n)*diminfo(n)%stride - endif - enddo - - ! if index is negative, skip an invalid point - if (ii > 0) then - data(ii) = buffer(i) - if(present(mask))mask(ii) = .true. - endif - - ! increment indices - do n = 1,ndims - idx(n) = idx(n)+1 - if(idx(n). -!*********************************************************************** -module nf_utils_mod - -use nfu_mod ! netcdf utilities -use nfc_mod ! netcdf utilities for compressed files - -implicit none -private - -! ==== public interfaces ===================================================== -! export stuff from nfu_mod -public :: nfu_inq_dim, nfu_inq_var, nfu_inq_att -public :: nfu_def_dim, nfu_def_var -public :: nfu_put_att -public :: nfu_get_dim, nfu_get_dim_bounds -public :: nfu_put_var, nfu_put_rec -public :: nfu_get_var, nfu_get_rec -public :: nfu_get_valid_range, nfu_is_valid, nfu_validtype, nfu_validtype2ascii -! export stuff from nfc_mod -public :: nfu_inq_compressed_dim, nfu_inq_compressed_var -public :: nfu_get_compressed_var -public :: nfu_put_compressed_var -public :: nfu_get_compressed_rec -! ==== end of public interfaces ============================================== - -end module nf_utils_mod diff --git a/shared/nf_utils/nfc.F90 b/shared/nf_utils/nfc.F90 deleted file mode 100644 index 02c6202c..00000000 --- a/shared/nf_utils/nfc.F90 +++ /dev/null @@ -1,228 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Land Model 4 (LM4). -!* -!* LM4 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 (at -!* your option) any later version. -!* -!* LM4 is distributed in the hope that it will be useful, but WITHOUT -!* ANY WARRANTY; 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 LM4. If not, see . -!*********************************************************************** -module nfc_mod - - use nfu_mod - use fms_mod, only: error_mesg, FATAL - -implicit none -private - -! ==== public interface ====================================================== -public :: nfu_inq_compressed_dim, nfu_inq_compressed_var -public :: nfu_get_compressed_var -public :: nfu_put_compressed_var -public :: nfu_get_compressed_rec -! ==== end of public interface =============================================== - -! ==== interfaces for overloaded functions =================================== -#define __INTERFACE_SECTION__ -interface nfu_inq_compressed_dim - module procedure inq_compressed_dim_n, inq_compressed_dim_i -end interface - -interface nfu_inq_compressed_var - module procedure inq_compressed_var_n, inq_compressed_var_i -end interface - -#define F90_TYPE real(8) -#define NF_TYPE double -#include "getput_compressed.inc" - -#define F90_TYPE integer -#define NF_TYPE int -#include "getput_compressed.inc" - -#undef __INTERFACE_SECTION__ - -! ---- private type - used to hold dimension/packing information during unpacking -! (see get_compressed_var_i_r8) -type diminfo_type - integer, pointer :: idx(:)=>NULL() ! packing information - integer :: length ! size of the dimension in the input array - integer :: stride ! stide along the dimension in the output array -end type - -! ==== NetCDF declarations =================================================== -include 'netcdf.inc' -#define __NF_TRY__(err_code,iret,LABEL)iret=err_code;if(iret/=NF_NOERR)goto LABEL -contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - - -! =========================================================================== -function inq_compressed_dim_n(ncid,name,ndims,dimids,dimlens,dimid) result (iret) - integer :: iret - integer, intent(in) :: ncid - character(*), intent(in) :: name - integer, intent(out), optional :: ndims - integer, intent(out), optional :: dimids(:) - integer, intent(out), optional :: dimlens(:) - integer, intent(out), optional :: dimid - - integer :: dimid_ - - __NF_TRY__(nf_inq_dimid(ncid,name,dimid_),iret,7) - if(present(dimid)) dimid = dimid_ - __NF_TRY__(inq_compressed_dim_i(ncid,dimid_,ndims,dimids,dimlens),iret,7) -7 return -end function - -! =========================================================================== -function inq_compressed_dim_i(ncid,dimid,ndims,dimids,dimlens,dimname) result (iret) - integer :: iret - integer, intent(in) :: ncid,dimid - integer, intent(out), optional :: ndims - integer, intent(out), optional :: dimids(:) - integer, intent(out), optional :: dimlens(:) - character(*), intent(out), optional :: dimname - - character(NF_MAX_NAME) :: dimname_ - character(1024) :: compress ! should be more than enough to hold the compression info - integer :: dimlen,dimid0,varid,n,is,ie - - __NF_TRY__(nfu_inq_dim(ncid,dimid,name=dimname_),iret,7) - if(present(dimname)) dimname = dimname_ - compress = '' - __NF_TRY__(nf_inq_varid(ncid,dimname_,varid),iret,7) - __NF_TRY__(nf_get_att_text(ncid,varid,'compress',compress),iret,7) - - ! parse the description of the compression - ie = len_trim(compress) - n = 0 - do while(ie>0) - is = scan(compress(1:ie),' ',back=.true.) - if(is==ie) then - ! skip space runs - else - n = n+1 - iret = nfu_inq_dim(ncid,compress(is+1:ie),len=dimlen,dimid=dimid0) - __NF_TRY__(iret,iret,7) - if(present(dimids)) dimids(n) = dimid0 - if(present(dimlens)) dimlens(n) = dimlen - endif - ie = is-1 - enddo - if(present(ndims))ndims=n -7 return -end function - -! ============================================================================ -function inq_compressed_var_n(ncid, name, id, xtype, ndims, dimids, dimlens, natts, & - is_dim, has_records, varsize, recsize, nrec, is_compressed) result(iret) - integer :: iret - integer, intent(in) :: ncid - character(*),intent(in) :: name - integer, intent(out), optional :: id - integer, intent(out), optional :: xtype - integer, intent(out), optional :: ndims - integer, intent(out), optional :: dimids(:) - integer, intent(out), optional :: dimlens(:) - integer, intent(out), optional :: natts - logical, intent(out), optional :: is_dim ! true if variable is a dimension variable - logical, intent(out), optional :: has_records ! true if variable depends on record dimension - integer, intent(out), optional :: varsize ! total size of the variable - integer, intent(out), optional :: recsize ! size of a single record - integer, intent(out), optional :: nrec ! number of records - logical, intent(out), optional :: is_compressed ! true if variable is actually compressed - - integer :: vid - character(len=NF_MAX_NAME) :: vname - - __NF_TRY__(nf_inq_varid(ncid,name,vid),iret,7) - if(present(id)) id = vid - iret = inq_compressed_var_i(ncid,vid,vname,xtype,ndims,dimids,dimlens,natts,& - is_dim,has_records,varsize,recsize,nrec,is_compressed) - -7 return -end function - -! ============================================================================ -function inq_compressed_var_i(ncid, vid, name, xtype, ndims, dimids, dimlens, & - natts, is_dim, has_records, varsize, recsize, nrec, is_compressed) result(iret) - integer :: iret - integer, intent(in) :: ncid - integer, intent(in) :: vid - character(*),intent(out), optional :: name - integer, intent(out), optional :: xtype - integer, intent(out), optional :: ndims - integer, intent(out), optional :: dimids(:) - integer, intent(out), optional :: dimlens(:) - integer, intent(out), optional :: natts - logical, intent(out), optional :: is_dim ! true if variable is a dimension variable - logical, intent(out), optional :: has_records ! true if variable depends on record dimension - integer, intent(out), optional :: varsize ! total size of the variable - integer, intent(out), optional :: recsize ! size of a single record - integer, intent(out), optional :: nrec ! number of records - logical, intent(out), optional :: is_compressed ! true if variable is actually compressed - - - integer :: nd0, dids0(NF_MAX_VAR_DIMS),dlens0(NF_MAX_VAR_DIMS) - integer :: nd1, dids1(NF_MAX_VAR_DIMS),dlens1(NF_MAX_VAR_DIMS) - integer :: i,n,unlimdim,vsize,rsize - logical :: compressed - - iret = nfu_inq_var(ncid, vid, name, xtype, nd0, dids0, dlens0, natts, & - is_dim, has_records, varsize, recsize, nrec) - - nd1=1 - if(present(is_compressed)) is_compressed=.false. - do i = 1, nd0 - __NF_TRY__(nfu_inq_dim(ncid,dids0(i),is_compressed=compressed),iret,7) - if (compressed) then - iret = nfu_inq_compressed_dim(ncid,dids0(i),& - ndims=n,dimids=dids1(nd1:),dimlens=dlens1(nd1:)) - if (iret/=NF_NOERR) goto 7 - nd1 = nd1+n - if(present(is_compressed)) is_compressed=.true. - else - dlens1(nd1) = dlens0(i) - dids1(nd1) = dids0(i) - nd1 = nd1+1 - endif - enddo - nd1 = nd1-1 - - if(present(ndims)) ndims = nd1 - if(present(dimids)) dimids = dids1 - if(present(dimlens)) dimlens = dlens1 - if(present(varsize).or.present(recsize)) then - __NF_TRY__(nf_inq_unlimdim(ncid,unlimdim),iret,7) - vsize = 1; rsize=1 - do i = 1,nd1 - vsize = vsize*dlens1(i) - if(dids1(i)/=unlimdim)& - rsize = rsize*dlens1(i) - enddo - if (present(varsize)) varsize=vsize - if (present(recsize)) recsize=rsize - end if -7 return - -end function - -#define __BODY_SECTION__ -#define F90_TYPE real(8) -#define NF_TYPE double -#include "getput_compressed.inc" - -#define F90_TYPE integer -#define NF_TYPE int -#include "getput_compressed.inc" - -end module nfc_mod diff --git a/shared/nf_utils/nfu.F90 b/shared/nf_utils/nfu.F90 deleted file mode 100644 index fb7eba49..00000000 --- a/shared/nf_utils/nfu.F90 +++ /dev/null @@ -1,759 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Land Model 4 (LM4). -!* -!* LM4 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 (at -!* your option) any later version. -!* -!* LM4 is distributed in the hope that it will be useful, but WITHOUT -!* ANY WARRANTY; 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 LM4. If not, see . -!*********************************************************************** -module nfu_mod - -implicit none -private - -! ==== public interfaces ===================================================== -public :: nfu_inq_dim, nfu_inq_var, nfu_inq_att -public :: nfu_def_dim, nfu_def_var -public :: nfu_put_att -public :: nfu_get_dim, nfu_get_dim_bounds -public :: nfu_put_var, nfu_put_rec -public :: nfu_get_var, nfu_get_rec - -public :: nfu_get_valid_range, nfu_is_valid, nfu_validtype, nfu_validtype2ascii -! ==== end of public interfaces ============================================== - -#define __INTERFACE_SECTION__ - -interface nfu_inq_dim - module procedure inq_dim_i - module procedure inq_dim_n -end interface -interface nfu_inq_att - module procedure inq_att_i_n - module procedure inq_att_n_n - module procedure inq_att_i_i - module procedure inq_att_n_i -end interface -interface nfu_inq_var - module procedure inq_var_i - module procedure inq_var_n -end interface -interface nfu_def_dim - module procedure def_dim_0 - module procedure def_dim_r - module procedure def_dim_i -end interface -interface nfu_def_var - module procedure def_var_i, def_var_n, def_var_scalar -end interface -interface nfu_put_att - module procedure put_att_text_i - module procedure put_att_text_n - module procedure put_att_int_i - module procedure put_att_int_n -end interface - -#define F90_TYPE character -#define NF_TYPE text -#include "getput.inc" - -#define F90_TYPE integer -#define NF_TYPE int -#include "getput.inc" - -#define F90_TYPE real(8) -#define NF_TYPE double -#include "getput.inc" - -interface nfu_get_valid_range - module procedure get_valid_range_i - module procedure get_valid_range_n -end interface -interface nfu_is_valid - module procedure nfu_is_valid_i - module procedure nfu_is_valid_r -end interface -#undef __INTERFACE_SECTION__ - -! ---- module types ---------------------------------------------------------- -type nfu_validtype - private - logical :: hasmax = .false. - logical :: hasmin = .false. -! real(kind=8) :: max=HUGE(max),min=-HUGE(min) - real(kind=8) :: max=0,min=0 -end type - -! ---- module variables ------------------------------------------------------ -logical :: module_is_initialized =.FALSE. - -! ==== NetCDF declarations =================================================== -include 'netcdf.inc' -#define __NF_TRY__(err_code,iret,LABEL)iret=err_code;if(iret/=NF_NOERR)goto LABEL -contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- - -#define __BODY_SECTION__ -! ============================================================================ -function inq_dim_n(ncid, name, len, dimid, is_compressed) result (iret) - integer :: iret - integer, intent(in) :: ncid - character(*),intent(in) :: name - integer, intent(out), optional :: len - integer, intent(out), optional :: dimid - logical, intent(out), optional :: is_compressed - - integer :: id,varid,attlen - - __NF_TRY__(nf_inq_dimid(ncid,name, id),iret,7) - if(present(dimid))dimid = id - if(present(len)) & - iret = nf_inq_dimlen(ncid,id,len) - if (present(is_compressed)) then - is_compressed = .FALSE. - if (nf_inq_varid(ncid,name,varid)==NF_NOERR) then - is_compressed=(nf_inq_attlen(ncid,varid,'compress',attlen)==NF_NOERR) - endif - endif -7 return -end function - -! ============================================================================ -function inq_dim_i(ncid, id, name, len, is_compressed) result (iret) - integer :: iret - integer, intent(in) :: ncid - integer, intent(in) :: id - character(*), intent(out), optional :: name - integer , intent(out), optional :: len - logical , intent(out), optional :: is_compressed - - character(len=NF_MAX_NAME) :: dname - integer :: varid,attlen - - __NF_TRY__(nf_inq_dimname(ncid,id,dname),iret,7) - if(present(name)) then - name=dname - endif - if(present(len)) then - __NF_TRY__(nf_inq_dimlen(ncid,id,len),iret,7) - end if - if (present(is_compressed)) then - is_compressed = .FALSE. - if (nf_inq_varid(ncid,dname,varid)==NF_NOERR) then - is_compressed=(nf_inq_attlen(ncid,varid,'compress',attlen)==NF_NOERR) - endif - endif -7 return -end function - -! ============================================================================ -function inq_var_n(ncid, name, id, xtype, ndims, dimids, dimlens, natts, & - is_dim, has_records, varsize, recsize, nrec) result(iret) - integer :: iret - integer, intent(in) :: ncid - character(*),intent(in) :: name - integer, intent(out), optional :: id - integer, intent(out), optional :: xtype - integer, intent(out), optional :: ndims - integer, intent(out), optional :: dimids(:) - integer, intent(out), optional :: dimlens(:) - integer, intent(out), optional :: natts - logical, intent(out), optional :: is_dim ! true if variable is a dimension variable - logical, intent(out), optional :: has_records ! true if variable depends on record dimension - integer, intent(out), optional :: varsize ! total size of the variable - integer, intent(out), optional :: recsize ! size of a single record - integer, intent(out), optional :: nrec ! number of records - - integer :: vid - character(len=NF_MAX_NAME) :: vname - - __NF_TRY__(nf_inq_varid(ncid,name,vid),iret,7) - if(present(id)) id = vid - iret = inq_var_i(ncid,vid,vname,xtype,ndims,dimids,dimlens,natts,& - is_dim,has_records,varsize,recsize,nrec) - -7 return -end function - -! ============================================================================ -function inq_var_i(ncid, vid, name, xtype, ndims, dimids, dimlens,natts, & - is_dim, has_records, varsize, recsize, nrec) result(iret) - integer :: iret - integer, intent(in) :: ncid - integer, intent(in) :: vid - character(*),intent(out), optional :: name - integer, intent(out), optional :: xtype - integer, intent(out), optional :: ndims - integer, intent(out), optional :: dimids(:) - integer, intent(out), optional :: dimlens(:) - integer, intent(out), optional :: natts - logical, intent(out), optional :: is_dim ! true if variable is a dimension variable - logical, intent(out), optional :: has_records ! true if variable depends on record dimension - integer, intent(out), optional :: varsize ! total size of the variable - integer, intent(out), optional :: recsize ! size of a single record - integer, intent(out), optional :: nrec ! number of records - - integer :: vxtype, vndims, vdimids(NF_MAX_VAR_DIMS), vnatts - integer :: vsize, vrecsize - integer :: unlimdim, did, dlen, i - character(len=NF_MAX_NAME) :: vname - - __NF_TRY__(nf_inq_var(ncid,vid,vname,vxtype,vndims,vdimids,vnatts),iret,7) - if (present(name)) name = vname - if (present(xtype)) xtype = vxtype - if (present(ndims)) ndims = vndims - if (present(dimids)) dimids(1:min(vndims,size(dimids))) = & - vdimids(1:min(vndims,size(dimids))) - if (present(natts)) natts = vnatts - if (present(is_dim)) then - is_dim = (nf_inq_dimid(ncid,vname,did)==NF_NOERR) - endif - __NF_TRY__(nf_inq_unlimdim(ncid,unlimdim),iret,7) - if (present(has_records)) then - has_records = ANY(vdimids(1:vndims)==unlimdim) - endif - if (present(varsize).or.present(recsize).or.present(dimlens)) then - vsize = 1; vrecsize=1 - do i = 1,vndims - __NF_TRY__(nf_inq_dimlen(ncid,vdimids(i),dlen),iret,7) - vsize = vsize*dlen - if(vdimids(i)/=unlimdim) vrecsize=vrecsize*dlen - if(present(dimlens)) dimlens(i)=dlen - enddo - if(present(varsize)) varsize=vsize - if(present(recsize)) recsize=vrecsize - endif - if(present(nrec)) then - nrec=1 - if(unlimdim/=-1.and.ANY(vdimids(1:vndims)==unlimdim)) then - __NF_TRY__(nf_inq_dimlen(ncid,unlimdim,nrec),iret,7) - endif - endif - -7 return -end function - -! ============================================================================ -function inq_att_i_n(ncid, varid, att, xtype, len, attid) result (iret) - integer , intent(in) :: ncid - integer , intent(in) :: varid - character(*), intent(in) :: att - integer, optional, intent(out) :: xtype - integer, optional, intent(out) :: len - integer, optional, intent(out) :: attid - integer :: iret - - integer :: xtype_, len_ - - __NF_TRY__(nf_inq_att(ncid,varid,att,xtype_,len_),iret,7) - if(present(attid)) then - __NF_TRY__(nf_inq_attid(ncid,varid,att,attid),iret,7) - endif - if(present(xtype)) xtype = xtype_ - if(present(len)) len = len_ - -7 return -end function - -! ============================================================================ -function inq_att_n_n(ncid, var, att, xtype, len, attid) result (iret) - integer , intent(in) :: ncid - character(*), intent(in) :: var - character(*), intent(in) :: att - integer, optional, intent(out) :: xtype - integer, optional, intent(out) :: len - integer, optional, intent(out) :: attid - integer :: iret - - - integer :: varid - __NF_TRY__(nf_inq_varid(ncid,var,varid),iret,7) - __NF_TRY__(inq_att_i_n(ncid,varid,att,xtype,len,attid),iret,7) -7 return -end function - -! ============================================================================ -function inq_att_i_i(ncid, varid, attid, xtype, len, name) result (iret) - integer, intent(in) :: ncid - integer, intent(in) :: varid - integer, intent(in) :: attid - integer, optional, intent(out) :: xtype - integer, optional, intent(out) :: len - character(*), optional, intent(out) :: name - integer :: iret - - character(NF_MAX_NAME) :: name_ - - __NF_TRY__(nf_inq_attname(ncid,varid,attid,name_),iret,7) - __NF_TRY__(inq_att_i_n(ncid,varid,name_,xtype,len),iret,7) - if(present(name)) name = name_ -7 return -end function - -! ============================================================================ -function inq_att_n_i(ncid, var, attid, xtype, len, name) result (iret) - integer, intent(in) :: ncid - character(*) :: var - integer, intent(in) :: attid - integer, optional, intent(out) :: xtype - integer, optional, intent(out) :: len - character(*), optional, intent(out) :: name - integer :: iret - - integer :: varid - __NF_TRY__(nf_inq_varid(ncid,var,varid),iret,7) - __NF_TRY__(inq_att_i_i(ncid,varid,attid,xtype,len,name),iret,7) -7 return -end function - -! ============================================================================ -function def_dim_0(ncid,name,size,xtype,long_name,units,edges,dimid,varid) & - result (iret) - integer , intent(in) :: ncid ! id of NetCDF file to create - character(len=*), intent(in) :: name ! name of the dimension - integer , intent(in) :: size ! size of the dimension - integer,optional, intent(in) :: xtype ! external type of the associated variable - character(len=*), intent(in), optional :: & - long_name, & - units, & - edges - integer,optional,intent(out) :: dimid,varid - integer :: iret - - integer :: did,vid - - iret = nf_redef(ncid) - - did = -1; vid = -1 - __NF_TRY__(nf_def_dim(ncid,name,size,did),iret,7) - if(present(xtype)) then - __NF_TRY__(nf_def_var(ncid,name,xtype,1,(/did/),vid),iret,7) - if (present(long_name)) then - __NF_TRY__(nfu_put_att(ncid,vid,'long_name',long_name),iret,7) - endif - if (present(units)) then - __NF_TRY__(nfu_put_att(ncid,vid,'units',units),iret,7) - endif - if (present(edges)) then - __NF_TRY__(nfu_put_att(ncid,vid,'edges',edges),iret,7) - endif - endif - if(present(dimid))dimid=did - if(present(varid))varid=vid -7 return -end function - -! ============================================================================ -function def_dim_r(ncid,name,data,long_name,units,edges,dimid,varid) result (iret) - integer :: iret - integer, intent(in) :: ncid - character(len=*), intent(in) :: name - real , intent(in) :: data(:) - character(len=*), intent(in), optional :: long_name, units, edges - integer,optional,intent(out) :: dimid,varid - - integer :: vid - iret = nf_redef(ncid) - - __NF_TRY__(def_dim_0(ncid,name,size(data),NF_DOUBLE,long_name,units,edges,dimid,varid=vid),iret,7) - iret = nf_enddef(ncid) - iret = nf_put_var_double(ncid,vid,data) - if(present(varid)) varid = vid -7 return -end function - -! ============================================================================ -function def_dim_i(ncid,name,data,long_name,units,edges,dimid,varid) result (iret) - integer :: iret - integer, intent(in) :: ncid - character(len=*), intent(in) :: name - integer , intent(in) :: data(:) - character(len=*), intent(in), optional :: long_name, units, edges - integer,optional,intent(out) :: dimid,varid - - integer :: vid - iret = nf_redef(ncid) - - __NF_TRY__(def_dim_0(ncid,name,size(data),NF_INT,long_name,units,edges,dimid,varid=vid),iret,7) - iret = nf_enddef(ncid) - iret = nf_put_var_int(ncid,vid,data) - if(present(varid)) varid = vid -7 return -end function - -! ============================================================================ -function def_var_n(ncid,name,xtype,dims,long_name,units,varid) result(iret) - integer , intent(in) :: ncid - character(len=*), intent(in) :: name ! name of the variable - integer , intent(in) :: xtype ! external type of the var - character(len=*), intent(in) :: & - dims(:) ! vector of dimension names - character(len=*), intent(in), optional :: & - long_name, & ! name of the variable - units ! name of the variable - integer , intent(out), optional :: & - varid ! ID of the defined variable - integer :: iret - - ! ---- local vars - integer :: dimc,dimids(NF_MAX_VAR_DIMS) - integer :: i - - dimc = size(dims) - do i = 1,dimc - __NF_TRY__(nf_inq_dimid(ncid,dims(i),dimids(i)),iret,7) - enddo - iret=def_var_i(ncid,name,xtype,dimids(1:dimc),long_name,units,varid) - -7 return -end function - -! ============================================================================ -function def_var_scalar(ncid,name,xtype,long_name,units,varid) result(iret) - integer , intent(in) :: ncid - character(len=*), intent(in) :: name ! name of the variable - integer , intent(in) :: xtype ! external type of the var - character(len=*), intent(in), optional :: & - long_name, & ! name of the variable - units ! name of the variable - integer , intent(out), optional :: & - varid ! ID of the defined variable - integer :: iret - - ! ---- local vars - integer :: varid_ - - iret = nf_redef(ncid); ! ignore errors here since file can be in define mode already - __NF_TRY__(nf_def_var(ncid,name,xtype,0,(/1/),varid_),iret,7) - if(present(varid)) varid = varid_ - if(present(long_name)) then - __NF_TRY__(nfu_put_att(ncid,varid_,'long_name',long_name),iret,7) - endif - if(present(units)) then - __NF_TRY__(nfu_put_att(ncid,varid_,'units',units),iret,7) - endif - -7 return -end function - -! ============================================================================ -function def_var_i(ncid,name,xtype,dimids,long_name,units,varid) result(iret) - integer , intent(in) :: ncid - character(len=*), intent(in) :: name ! name of the variable - integer , intent(in) :: xtype ! external type of the var - integer , intent(in) :: & - dimids(:) ! vector of dimension ids - character(len=*), intent(in), optional :: & - long_name, & ! name of the variable - units ! name of the variable - integer , intent(out), optional :: & - varid ! ID of the defined variable - integer :: iret - - ! ---- local vars - integer :: dimc,varid_ - - dimc = size(dimids) - iret = nf_redef(ncid); ! ignore errors here since file can be in define mode already - __NF_TRY__(nf_def_var(ncid,name,xtype,dimc,dimids,varid_),iret,7) - if(present(varid)) varid = varid_ - if(present(long_name)) then - __NF_TRY__(nfu_put_att(ncid,varid_,'long_name',long_name),iret,7) - endif - if(present(units)) then - __NF_TRY__(nfu_put_att(ncid,varid_,'units',units),iret,7) - endif - -7 return -end function - -! ============================================================================ -function put_att_text_i(ncid,varid,name,text) result (iret) - integer :: iret - integer , intent(in) :: ncid,varid - character(len=*), intent(in) :: name,text - - iret = nf_redef(ncid) - iret = nf_put_att_text(ncid,varid,name,len(text),text) -end function - -! ============================================================================ -function put_att_text_n(ncid,varname,name,text) result (iret) - integer :: iret - integer , intent(in) :: ncid - character(len=*), intent(in) :: varname,name,text - - integer :: varid - - __NF_TRY__(nf_inq_varid(ncid,varname,varid),iret,7) - iret = nf_redef(ncid) - iret = nf_put_att_text(ncid,varid,name,len(text),text) -7 return -end function - -! ============================================================================ -function put_att_int_i(ncid,varid,name,value) result (iret) - integer :: iret - integer , intent(in) :: ncid,varid - character(len=*), intent(in) :: name - integer , intent(in) :: value - - iret = nf_redef(ncid) - iret = nf_put_att_int(ncid,varid,name,NF_INT,1,value) -end function - -! ============================================================================ -function put_att_int_n(ncid,varname,name,value) result (iret) - integer :: iret - integer , intent(in) :: ncid - character(len=*), intent(in) :: varname,name - integer , intent(in) :: value - - integer :: varid - - __NF_TRY__(nf_inq_varid(ncid,varname,varid),iret,7) - iret = nf_redef(ncid) - iret = nf_put_att_int(ncid,varid,name,NF_INT,1,value) -7 return -end function - -! ============================================================================ -function nfu_get_dim(ncid, dimid, x) result(iret) - integer, intent(in) :: ncid,dimid - real , intent(out) :: x(:) - integer :: iret - - integer :: varid - character(len=NF_MAX_NAME) :: name - - __NF_TRY__(nf_inq_dimname(ncid,dimid,name),iret,7) - __NF_TRY__(nf_inq_varid(ncid,name,varid),iret,7) - __NF_TRY__(nf_get_var_double(ncid,varid,x),iret,7) - -7 return -end function - -! ============================================================================ -function nfu_get_dim_bounds(ncid,dimid,edges)result(iret) - integer, intent(in) :: ncid,dimid - real , intent(out) :: edges(:) - integer :: iret - - ! ---- local vars - character(len=NF_MAX_NAME) :: name, edges_name - real :: x(size(edges)-1) - integer :: varid, len - - __NF_TRY__( nf_inq_dimname(ncid,dimid,name),iret,7 ) - __NF_TRY__( nf_inq_dimlen(ncid,dimid,len),iret,7 ) - __NF_TRY__( nf_inq_varid(ncid,name,varid),iret,7 ) - edges_name = " " - if (nf_get_att_text(ncid,varid,'edges',edges_name)==NF_NOERR) then - __NF_TRY__(nf_inq_varid(ncid,edges_name,varid),iret,7) - __NF_TRY__(nf_get_var_double(ncid,varid,edges),iret,7) - else - __NF_TRY__( nf_get_var_double(ncid,varid,x),iret,7 ) - edges(2:len) = (x(1:len-1)+x(2:len))/2 - edges(1) = x(1)-(edges(2)-x(1)) - edges(len+1) = x(len)+(x(len)-edges(len)) - endif -7 return -end function - - - - - -! ============================================================================ -! nfu_get_var interface -! ============================================================================ -#define F90_TYPE character -#define NF_TYPE text -#include "getput.inc" - -#define F90_TYPE integer -#define NF_TYPE int -#include "getput.inc" - -#define F90_TYPE real(8) -#define NF_TYPE double -#include "getput.inc" - - - -function get_valid_range_n(ncid, varname, v) result (iret) - integer , intent(in) :: ncid - character(*) , intent(in) :: varname - type(nfu_validtype), intent(out) :: v ! validator - - integer :: iret - integer :: varid - - __NF_TRY__(nfu_inq_var(ncid,varname,id=varid),iret,7) - iret = get_valid_range_i(ncid, varid, v) - -7 return -end function - -! ======================================================================== -! based on presence/absence of attributes, defines valid range or missing -! value. For details, see section 8.1 of NetCDF User Guide -function get_valid_range_i(ncid, varid, v) result (iret) - integer , intent(in) :: ncid - integer , intent(in) :: varid - type(nfu_validtype), intent(out) :: v ! validator - - integer :: iret - - integer :: var_T, valid_T, scale_T, T ! types variable and of attributes - real(kind=8) :: scale, offset, fill, r(2) - - ! find the type of the variable - __NF_TRY__(nfu_inq_var(ncid,varid,xtype=var_T),iret,7) - - ! find the widest type of scale and offset; note that the code - ! uses assumption that NetCDF types are arranged in th order of rank, - ! that is NF_BYTE < NF_CHAR < NF_SHORT < NF_INT < NF_FLOAT < NF_DOUBLE - scale = 1; offset = 0; - scale_T = 0 - if(nfu_inq_att(ncid,varid,'scale_factor',xtype=T)==NF_NOERR) then - __NF_TRY__(nf_get_att_double(ncid,varid,'scale_factor',scale),iret,7) - scale_T = T - endif - if(nfu_inq_att(ncid,varid,'add_offset',xtype=T)==NF_NOERR) then - __NF_TRY__(nf_get_att_double(ncid,varid,'add_offset',offset),iret,7) - scale_T = max(scale_T,T) - endif - - ! examine possible range attributes - valid_T = 0; v%hasmax=.false. ; v%hasmin=.false. - if (nfu_inq_att(ncid,varid,'valid_range',xtype=T)==NF_NOERR) then - __NF_TRY__(nf_get_att_double(ncid,varid,'valid_range',r),iret,7) - v%min = r(1) ; v%max = r(2) - v%hasmax = .true. ; v%hasmin = .true. - valid_T = max(valid_T,T) - else if(nfu_inq_att(ncid,varid,'valid_max',xtype=T)==NF_NOERR) then - __NF_TRY__(nf_get_att_double(ncid,varid,'valid_max',v%max),iret,7) - v%hasmax = .true. - valid_T = max(valid_T,T) - else if(nfu_inq_att(ncid,varid,'valid_min',xtype=T)==NF_NOERR) then - __NF_TRY__(nf_get_att_double(ncid,varid,'valid_min',v%min),iret,7) - v%hasmin = .true. - valid_T = max(valid_T,T) - else if(nfu_inq_att(ncid,varid,'missing_value',xtype=T)==NF_NOERR) then - ! here we always scale, since missing_value is supposed to be in - ! external representation - __NF_TRY__(nf_get_att_double(ncid,varid,'missing_value',v%min),iret,7) - v%min = v%min*scale + offset - else - ! as a last resort, define range based on _FillValue - ! get fill value and its type: from var, from file, or default - if(nf_get_att_double(ncid,varid,'_FillValue',fill)/=NF_NOERR) then - if(nf_get_att_double(ncid,NF_GLOBAL,'_FillValue',fill)/=NF_NOERR) then - select case(var_T) - case(NF_CHAR) - fill = NF_FILL_CHAR - case(NF_BYTE) - fill = NF_FILL_BYTE - case(NF_SHORT) - fill = NF_FILL_SHORT - case(NF_INT) - fill = NF_FILL_INT - case(NF_REAL) - fill = NF_FILL_REAL - case(NF_DOUBLE) - fill = NF_FILL_DOUBLE - end select - endif - endif - if(fill>0) then - ! if _FillValue is positive, then it defines valid maximum - v%hasmax = .true. - v%max = fill - select case(T) - case (NF_BYTE,NF_CHAR,NF_SHORT,NF_INT) - v%max = v%max-1 - case (NF_FLOAT) - v%max = nearest(nearest(real(v%max,4),-1.0),-1.0) - case (NF_DOUBLE) - v%max = nearest(nearest(real(v%max,8),-1.0),-1.0) - end select - else - ! if _FillValue is negative or zero, then it defines valid minimum - v%hasmin = .true. - v%min = fill - select case(T) - case (NF_BYTE,NF_CHAR,NF_SHORT,NF_INT) - v%min = v%min+1 - case (NF_FLOAT) - v%min = nearest(nearest(real(v%min,4),+1.0),+1.0) - case (NF_DOUBLE) - v%min = nearest(nearest(real(v%min,8),+1.0),+1.0) - end select - endif - ! NOTE: if we go through _FillValue branch, valid_T is 0, so values - ! are always scaled, as it should be because _FillValue is in external - ! representation - endif - ! If valid_range is the same type as scale_factor (actually the wider of - ! scale_factor and add_offset) and this is wider than the external data, then it - ! will be interpreted as being in the units of the internal (unpacked) data. - ! Otherwise it is in the units of the external (packed) data. - if(.not.((valid_T == scale_T).and.(scale_T>var_T))) then - v%min = v%min*scale + offset - v%max = v%max*scale + offset - endif -7 return -end function - -! ======================================================================== -elemental function nfu_is_valid_r(x, v) result (lret) - real , intent(in) :: x ! real value to be examined - type(nfu_validtype), intent(in) :: v ! validator - logical :: lret - -! if (x is NaN) then -! lret = .false. -! else - if (v%hasmin.or.v%hasmax) then - lret = .not.(((v%hasmin).and.xv%max)) - else - lret = (x /= v%min) - endif -end function - -! ======================================================================== -elemental function nfu_is_valid_i(x, v) result (lret) - integer , intent(in) :: x ! real value to be examined - type(nfu_validtype), intent(in) :: v ! validator - logical :: lret - - lret = nfu_is_valid_r(real(x),v) -end function - -! ======================================================================== -function nfu_validtype2ascii(v) result (string) - character(len=64) :: string - type(nfu_validtype), intent(in) :: v - - if(v%hasmin.and.v%hasmax) then - write(string,'("[",g23.16,",",g23.16,"]")') v%min, v%max - else if (v%hasmin) then - write(string,'("[",g23.16,")")') v%min - else if (v%hasmax) then - write(string,'("(",g23.16,"]")') v%max - else - write(string,'("/=",g23.16)') v%min - endif -end function - -end module nfu_mod diff --git a/snow/snow.F90 b/snow/snow.F90 index 9e32ed40..75bf46b6 100644 --- a/snow/snow.F90 +++ b/snow/snow.F90 @@ -21,14 +21,10 @@ ! ============================================================================ module snow_mod -#ifdef INTERNAL_FILE_NML use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif -use fms_mod, only : error_mesg, file_exist, check_nml_error, & - stdlog, close_file, mpp_pe, mpp_root_pe, FATAL, NOTE +use fms_mod, only : error_mesg, check_nml_error, & + stdlog, mpp_pe, mpp_root_pe, FATAL, NOTE use time_manager_mod, only: time_type_to_real use constants_mod, only: tfreeze, hlv, hlf, PI @@ -109,7 +105,7 @@ module snow_mod ! ============================================================================ subroutine read_snow_namelist() ! ---- local vars - integer :: unit ! unit for namelist i/o + integer :: file_unit ! unit for namelist i/o integer :: io ! i/o status for the namelist integer :: ierr ! error code, returned by i/o routines integer :: l ! layer iterator @@ -118,24 +114,11 @@ subroutine read_snow_namelist() call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML read (input_nml_file, nml=snow_nml, iostat=io) ierr = check_nml_error(io, 'snow_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=snow_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'snow_nml') - enddo -10 continue - call close_file (unit) - endif -#endif if (mpp_pe() == mpp_root_pe()) then - unit=stdlog() - write(unit, nml=snow_nml) + file_unit=stdlog() + write(file_unit, nml=snow_nml) endif ! -------- set up vertical discretization -------- @@ -156,7 +139,7 @@ subroutine snow_init() integer :: k type(land_tile_enum_type) :: ce ! tile list enumerator type(land_tile_type), pointer :: tile ! pointer to current tile - character(*), parameter :: restart_file_name='INPUT/snow.res.nc' + character(*), parameter :: restart_file_name='INPUT/snow.nc' type(land_restart_type) :: restart logical :: restart_exists @@ -217,13 +200,13 @@ subroutine save_snow_restart (tile_dim_length, timestamp) call error_mesg('snow_end','writing NetCDF restart',NOTE) ! Note that filename is updated for tile & rank numbers during file creation - filename = trim(timestamp)//'snow.res.nc' + filename = 'RESTART/'//trim(timestamp)//'snow.nc' call init_land_restart(restart, filename, snow_tile_exists, tile_dim_length) - call add_restart_axis(restart,'zfull',zz(1:num_l),'Z',longname='depth of level centers',sense=-1) + call add_restart_axis(restart,'zfull',zz(1:num_l),.false.,"Z",longname='depth of level centers',units="") - call add_tile_data(restart,'temp','zfull', snow_temp_ptr, 'snow temperature','degrees_K') - call add_tile_data(restart,'wl' ,'zfull', snow_wl_ptr, 'snow liquid water content','kg/m2') - call add_tile_data(restart,'ws' ,'zfull', snow_ws_ptr, 'snow solid water content','kg/m2') + call add_tile_data(restart,'temp','zfull ', snow_temp_ptr, 'snow temperature','degrees_K') + call add_tile_data(restart,'wl' ,'zfull ', snow_wl_ptr, 'snow liquid water content','kg/m2') + call add_tile_data(restart,'ws' ,'zfull ', snow_ws_ptr, 'snow solid water content','kg/m2') call save_land_restart(restart) call free_land_restart(restart) diff --git a/snow/snow_tile.F90 b/snow/snow_tile.F90 index 85156fec..39dca17c 100644 --- a/snow/snow_tile.F90 +++ b/snow/snow_tile.F90 @@ -19,17 +19,12 @@ module snow_tile_mod #include -#ifdef INTERNAL_FILE_NML use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif - -use fms_mod, only : file_exist, check_nml_error, close_file, stdlog -use constants_mod,only: tfreeze, hlf +use fms_mod, only : check_nml_error, stdlog +use constants_mod,only: PI,tfreeze, hlf use land_constants_mod, only : NBANDS use land_tile_selectors_mod, only : tile_selector_type -use land_data_mod, only : log_version +use land_data_mod, only : log_version, lnd implicit none private @@ -65,7 +60,7 @@ module snow_tile_mod integer, parameter, public :: max_lev = 10 -! from the modis brdf/albedo product user's guide: +! from the modis brdf/albedo product users guide: real, parameter :: g_iso = 1. real, parameter :: g_vol = 0.189184 real, parameter :: g_geo = -1.377622 @@ -82,6 +77,8 @@ module snow_tile_mod ! range of temperatures for ramp between "warm" and "cold" albedo real, parameter :: t_range = 10.0 ! degK +real, parameter :: deg2rad = PI/180.0 + ! ==== types ================================================================= type :: snow_tile_type @@ -141,6 +138,11 @@ module snow_tile_mod real :: refl_snow_max_dif_on_glacier(NBANDS) = (/ 0.8, 0.8 /) ! reset to 0.6 for MCM real :: refl_snow_min_dir_on_glacier(NBANDS) = (/ 0.65, 0.65 /) ! reset to 0.45 for MCM real :: refl_snow_min_dif_on_glacier(NBANDS) = (/ 0.65, 0.65 /) ! reset to 0.45 for MCM +! boundaries of the boxes where the snow-on-glacier parameters are applied: by +! default all boxes are empty, except first (initialized later) which covers the +! entire Earth. +integer, parameter :: n_boxes = 2 +real, dimension(n_boxes) :: box_W=0.0, box_E=0.0, box_S=+1.0, box_N=-1.0 namelist /snow_data_nml/use_mcm_masking, w_sat, & psi_sat, k_sat, & @@ -159,7 +161,8 @@ module snow_tile_mod f_iso_cold_on_glacier, f_vol_cold_on_glacier, f_geo_cold_on_glacier, & f_iso_warm_on_glacier, f_vol_warm_on_glacier, f_geo_warm_on_glacier, & refl_snow_max_dir_on_glacier, refl_snow_min_dir_on_glacier, & - refl_snow_max_dif_on_glacier, refl_snow_min_dif_on_glacier + refl_snow_max_dif_on_glacier, refl_snow_min_dif_on_glacier, & + box_W, box_E, box_S, box_N !---- end of namelist -------------------------------------------------------- @@ -178,21 +181,12 @@ subroutine read_snow_data_namelist(snow_num_l, snow_dz, snow_mc_fict) call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML + ! set default values for the first box: it covers the whole Earth unless + ! set otherwise in the namelist. + box_W(1)=-180.0; box_E(1)=180.0; box_S(1)=-90.0; box_N(1)=90.0 + read (input_nml_file, nml=snow_data_nml, iostat=io) ierr = check_nml_error(io, 'snow_data_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=snow_data_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'snow_data_nml') - enddo -10 continue - call close_file (unit) - endif -#endif unit=stdlog() write(unit, nml=snow_data_nml) @@ -203,6 +197,9 @@ subroutine read_snow_data_namelist(snow_num_l, snow_dz, snow_mc_fict) snow_dz = dz snow_mc_fict = mc_fict + ! convert box coordinates to radian + box_W = box_W*deg2rad; box_E = box_E*deg2rad + box_S = box_S*deg2rad; box_N = box_N*deg2rad end subroutine read_snow_data_namelist ! ============================================================================ @@ -347,14 +344,24 @@ end subroutine snow_data_area ! ============================================================================ ! compute snow properties needed to do soil-canopy-atmos energy balance -subroutine snow_radiation ( snow_T, cosz, on_glacier,& +subroutine snow_radiation ( snow_T, cosz, on_glacier, l, & snow_refl_dir, snow_refl_dif, snow_refl_lw, snow_emis ) real, intent(in) :: snow_T ! snow temperature, deg K real, intent(in) :: cosz ! cosine of zenith angle + integer, intent(in) :: l ! grid cell index in unstructured grid logical, intent(in) :: on_glacier ! TRUE if snow is on glacier real, intent(out) :: snow_refl_dir(NBANDS), snow_refl_dif(NBANDS), snow_refl_lw, snow_emis - if (on_glacier.and.distinct_snow_on_glacier) then + logical :: in_box ! true if the current point is within one of the boxes + integer :: i ! box index + + in_box = .FALSE. + if (distinct_snow_on_glacier.and.on_glacier) then + do i = 1,n_boxes + in_box = in_box.or.within_box(lnd%ug_lon(l),lnd%ug_lat(l), box_W(i),box_E(i),box_S(i),box_N(i)) + enddo + endif + if (on_glacier.and.in_box.and.distinct_snow_on_glacier) then call snow_rad_calculations ( snow_T, cosz, & f_iso_warm_on_glacier, f_vol_warm_on_glacier, f_geo_warm_on_glacier, & f_iso_cold_on_glacier, f_vol_cold_on_glacier, f_geo_cold_on_glacier, & @@ -371,6 +378,21 @@ subroutine snow_radiation ( snow_T, cosz, on_glacier,& endif end subroutine snow_radiation +! ============================================================================ +! given coordinates of the point and box boundaries, returns TRUE if the point +! is within the specified box +logical function within_box(lon,lat,W,E,S,N) + real, intent(in) :: lon,lat ! coordinares of the point + real, intent(in) :: W,E,S,N ! bundaries of the box + + real :: lon1 ! longitude converted to the same range as the box boundaries + within_box = (S<=lat).and.(lat<=N) + if (.not.within_box) return ! no need to check anything else + ! convert longitude to the same range as the western boundary of the box + lon1=lon-2*PI*floor((lon-W)/(2*PI)) + within_box = (W<=lon1).and.(lon1<=E) +end function within_box + ! ============================================================================ subroutine snow_rad_calculations ( snow_T, cosz, & f_iso_warm, f_vol_warm, f_geo_warm, & diff --git a/soil/hillslope.F90 b/soil/hillslope.F90 index 26df0c43..eb1ec38b 100644 --- a/soil/hillslope.F90 +++ b/soil/hillslope.F90 @@ -23,14 +23,8 @@ module hillslope_mod #include "../shared/debug.inc" -#ifdef INTERNAL_FILE_NML -use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif - -use mpp_mod, only: mpp_pe, mpp_root_pe -use fms_mod, only: error_mesg, file_exist, close_file, check_nml_error, & +use mpp_mod, only: mpp_pe, mpp_root_pe, input_nml_file +use fms_mod, only: error_mesg, check_nml_error, & stdlog, FATAL, NOTE, WARNING use land_tile_mod, only : land_tile_map, land_tile_type, land_tile_enum_type, & @@ -43,9 +37,7 @@ module hillslope_mod use land_io_mod, only : read_field use land_tile_io_mod, only: land_restart_type, & init_land_restart, open_land_restart, save_land_restart, free_land_restart, & - add_restart_axis, add_int_tile_data, get_int_tile_data, & - print_netcdf_error -use nf_utils_mod, only : nfu_inq_dim + add_restart_axis, add_int_tile_data, get_int_tile_data use land_debug_mod, only : is_watch_point, is_watch_cell, set_current_point use land_transitions_mod, only : do_landuse_change use vegn_harvesting_mod , only : do_harvesting @@ -54,6 +46,8 @@ module hillslope_mod use soil_tile_mod, only : gw_option, GW_TILED, initval, soil_tile_type, & gw_scale_length, gw_scale_relief +use fms2_io_mod, only: close_file, FmsNetcdfFile_t, get_dimension_size, open_file + implicit none private @@ -181,10 +175,6 @@ module hillslope_mod ! ==== end of module variables =============================================== -! ==== NetCDF declarations =================================================== -include 'netcdf.inc' -#define __NF_ASRT__(x) call print_netcdf_error((x),module_name,__LINE__) - contains ! ============================================================================ @@ -196,21 +186,8 @@ subroutine read_hlsp_namelist() call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML read (input_nml_file, nml=hlsp_nml, iostat=io) ierr = check_nml_error(io, 'hlsp_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=hlsp_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'hlsp_nml') - enddo -10 continue - call close_file (unit) - endif -#endif if (mpp_pe() == mpp_root_pe()) then unit=stdlog() write(unit, nml=hlsp_nml) @@ -266,11 +243,12 @@ subroutine read_hillslope_surfdat ( ls, le, num_topo_hlsps, frac_topo_hlsps, soi integer, allocatable :: ibuffer(:,:) real , allocatable :: rbuffer(:,:) integer :: ierr, ncid, totnumhlsps ! err, file id and tot # of hillslopes per gcell on surfdata + type(FmsNetcdfFile_t) :: fileobj + logical :: exists ! Check length of nhlsps dimension on input file. - __NF_ASRT__(nf_open(hillslope_surfdata, NF_NOWRITE,ncid)) - ierr = nfu_inq_dim(ncid, hlsp_surf_dimname, totnumhlsps) - __NF_ASRT__(nf_close(ncid)) + exists = open_file(fileobj, hillslope_surfdata, "read") + call get_dimension_size(fileobj, hlsp_surf_dimname, totnumhlsps) !write(*,*)'totnumhlsps = ',totnumhlsps,', max_num_topo_hlsps = ', & ! max_num_topo_hlsps if (ierr > 0) call error_mesg(module_name, 'Error reading file '// hillslope_surfdata // ','// & @@ -289,53 +267,57 @@ subroutine read_hillslope_surfdat ( ls, le, num_topo_hlsps, frac_topo_hlsps, soi 'is not on the native grid.', NOTE) ! Note: this function is not currently a robust "nearest" interpolation for cubic-sphere ! grids and will need to be updated. + if (.not. exists) then + call error_mesg("read_hillslope_surfdat", trim(hillslope_surfdata)//" does not exist.", & + fatal) + endif - call read_field( hillslope_surfdata, 'NUM_TOPO_HLSPS', num_topo_hlsps, interp='nearest' ) + call read_field( fileobj, 'NUM_TOPO_HLSPS', num_topo_hlsps, interp='nearest' ) - call read_field( hillslope_surfdata, 'FRAC_TOPO_HLSPS', rbuffer, interp='nearest' ) + call read_field( fileobj, 'FRAC_TOPO_HLSPS', rbuffer, interp='nearest' ) frac_topo_hlsps(:,:) = rbuffer(:,1:max_num_topo_hlsps) if (.not. use_geohydrodata) then - call read_field( hillslope_surfdata, 'SOIL_E_DEPTH', rbuffer, interp=hlsp_interpmethod ) + call read_field( fileobj, 'SOIL_E_DEPTH', rbuffer, interp=hlsp_interpmethod ) soil_e_depth(:,:) = rbuffer(:,1:max_num_topo_hlsps) else soil_e_depth(:,:) = initval ! will not be used end if - call read_field( hillslope_surfdata, 'MICROTOPO', rbuffer, interp=hlsp_interpmethod ) + call read_field( fileobj, 'MICROTOPO', rbuffer, interp=hlsp_interpmethod ) microtopo(:,:) = rbuffer(:,1:max_num_topo_hlsps) - call read_field( hillslope_surfdata, 'HLSP_LENGTH', rbuffer, interp=hlsp_interpmethod ) + call read_field( fileobj, 'HLSP_LENGTH', rbuffer, interp=hlsp_interpmethod ) hlsp_length(:,:) = rbuffer(:,1:max_num_topo_hlsps) if (use_geohydrodata) hlsp_length(:,:) = hlsp_length(:,:)*gw_scale_length - call read_field( hillslope_surfdata, 'HLSP_SLOPE', rbuffer, interp=hlsp_interpmethod ) + call read_field( fileobj, 'HLSP_SLOPE', rbuffer, interp=hlsp_interpmethod ) ! Hillslope elevation at top divided by hillslope length hlsp_slope(:,:) = rbuffer(:,1:max_num_topo_hlsps) if (use_geohydrodata) hlsp_slope(:,:) = hlsp_slope(:,:)*gw_scale_relief - call read_field( hillslope_surfdata, 'HLSP_SLOPE_EXP', rbuffer, interp=hlsp_interpmethod ) + call read_field( fileobj, 'HLSP_SLOPE_EXP', rbuffer, interp=hlsp_interpmethod ) ! Hillslope profile will follow equation z = H(x/L)^a, where a=hlsp_slope_exp, ! H = max elevation, and L = max length from stream. hlsp_slope_exp(:,:) = rbuffer(:,1:max_num_topo_hlsps) -! call read_field( hillslope_surfdata, 'HLSP_STREAM_WIDTH', rbuffer, interp=hlsp_interpmethod ) +! call read_field( fileobj, 'HLSP_STREAM_WIDTH', rbuffer, interp=hlsp_interpmethod ) ! hlsp_stream_width(:,:,:) = rbuffer(:,:,1:max_num_topo_hlsps) - call read_field( hillslope_surfdata, 'HLSP_TOP_WIDTH', rbuffer, interp=hlsp_interpmethod ) + call read_field( fileobj, 'HLSP_TOP_WIDTH', rbuffer, interp=hlsp_interpmethod ) hlsp_top_width(:,:) = rbuffer(:,1:max_num_topo_hlsps) if (.not. use_geohydrodata) then - call read_field( hillslope_surfdata, 'BEDROCK_KSAT', rbuffer, interp=hlsp_interpmethod ) + call read_field( fileobj, 'BEDROCK_KSAT', rbuffer, interp=hlsp_interpmethod ) k_sat_gw(:,:) = rbuffer(:,1:max_num_topo_hlsps) else k_sat_gw(:,:) = initval ! will not be used end if if (present(soiltype)) then - call read_field( hillslope_surfdata, 'SOILTYPE', ibuffer, interp='nearest') + call read_field( fileobj, 'SOILTYPE', ibuffer, interp='nearest') soiltype(:,:) = ibuffer(:,1:max_num_topo_hlsps) end if - + call close_file(fileobj) deallocate(rbuffer, ibuffer) end subroutine read_hillslope_surfdat diff --git a/soil/soil.F90 b/soil/soil.F90 index 24ce0dc3..ed54b641 100644 --- a/soil/soil.F90 +++ b/soil/soil.F90 @@ -23,14 +23,10 @@ module soil_mod #include "../shared/debug.inc" -#ifdef INTERNAL_FILE_NML use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif -use fms_mod, only: error_mesg, file_exist, check_nml_error, & - stdlog, close_file, mpp_pe, mpp_root_pe, FATAL, WARNING, NOTE +use fms_mod, only: error_mesg, check_nml_error, & + stdlog, mpp_pe, mpp_root_pe, FATAL, WARNING, NOTE use time_manager_mod, only: time_type_to_real use diag_manager_mod, only: diag_axis_init use constants_mod, only: tfreeze, hlv, hlf, dens_h2o @@ -92,6 +88,9 @@ module soil_mod ! Test tridiagonal solution for advection use land_numerics_mod, only : tridiag + +use fms2_io_mod, only: close_file, FmsNetcdfFile_t, open_file + implicit none private @@ -310,21 +309,8 @@ subroutine read_soil_namelist() call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML read (input_nml_file, nml=soil_nml, iostat=io) ierr = check_nml_error(io, 'soil_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=soil_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'soil_nml') - enddo -10 continue - call close_file (unit) - endif -#endif if (mpp_pe() == mpp_root_pe()) then unit=stdlog() write(unit, nml=soil_nml) @@ -398,7 +384,9 @@ subroutine soil_init (predefined_tiles, id_ug,id_band,id_zfull) type(land_restart_type) :: restart, restart1 logical :: restart_exists - character(*), parameter :: restart_file_name = 'INPUT/soil.res.nc' + character(*), parameter :: restart_file_name = 'INPUT/soil.nc' + type(FmsNetcdfFile_t) :: fileobj + logical :: exists module_is_initialized = .TRUE. delta_time = time_type_to_real(lnd%dt_fast) @@ -438,16 +426,27 @@ subroutine soil_init (predefined_tiles, id_ug,id_band,id_zfull) select case (gw_option) case (GW_LINEAR,GW_LM2) allocate(gw_param(lnd%ls:lnd%le)) - call read_field( 'INPUT/groundwater_residence.nc','tau', gw_param, interp='bilinear' ) + exists = open_file(fileobj, "INPUT/groundwater_residence.nc", "read") + if (.not. exists) then + call error_mesg("soil_init", "INPUT/groundwater_residence.nc does not exist", & + fatal) + endif + call read_field( fileobj, 'tau', gw_param, interp='bilinear' ) + call close_file(fileobj) call put_to_tiles_r0d_fptr( gw_param, land_tile_map, soil_tau_groundwater_ptr ) deallocate(gw_param) case (GW_HILL, GW_HILL_AR5) allocate(gw_param (lnd%ls:lnd%le)) allocate(gw_param2(lnd%ls:lnd%le)) allocate(gw_param3(lnd%ls:lnd%le)) - call read_field( 'INPUT/geohydrology.nc','hillslope_length', gw_param, interp='bilinear' ) + exists = open_file(fileobj, "INPUT/geohydrology.nc", "read") + if (.not. exists) then + call error_mesg("soil_init", "INPUT/geohydrology.nc does not exist", & + fatal) + endif + call read_field( fileobj, 'hillslope_length', gw_param, interp='bilinear' ) call put_to_tiles_r0d_fptr( gw_param*gw_scale_length, land_tile_map, soil_hillslope_length_ptr ) - call read_field( 'INPUT/geohydrology.nc','slope', gw_param2, interp='bilinear' ) + call read_field( fileobj, 'slope', gw_param2, interp='bilinear' ) gw_param = gw_param*gw_param2 call put_to_tiles_r0d_fptr( gw_param*gw_scale_relief, land_tile_map, soil_hillslope_relief_ptr ) @@ -456,20 +455,20 @@ subroutine soil_init (predefined_tiles, id_ug,id_band,id_zfull) call put_to_tiles_r0d_fptr( gw_param, land_tile_map, soil_hillslope_a_ptr ) gw_param = 1. call put_to_tiles_r0d_fptr( gw_param, land_tile_map, soil_hillslope_n_ptr ) -! call read_field( 'INPUT/geohydrology.nc','hillslope_zeta_bar', & +! call read_field( fileobj, 'hillslope_zeta_bar', & ! lnd%sg_lon, lnd%sg_lat, gw_param, interp='bilinear' ) gw_param = 0.5 call put_to_tiles_r0d_fptr( gw_param, land_tile_map, soil_hillslope_zeta_bar_ptr ) else - call read_field( 'INPUT/geohydrology.nc','hillslope_a', gw_param, interp='bilinear' ) + call read_field( fileobj, 'hillslope_a', gw_param, interp='bilinear' ) call put_to_tiles_r0d_fptr( gw_param, land_tile_map, soil_hillslope_a_ptr ) - call read_field( 'INPUT/geohydrology.nc','hillslope_n', gw_param2, interp='bilinear' ) + call read_field( fileobj, 'hillslope_n', gw_param2, interp='bilinear' ) call put_to_tiles_r0d_fptr( gw_param2, land_tile_map, soil_hillslope_n_ptr ) gw_param3 = (1./(gw_param2+1.)+gw_param/(gw_param2+2.))/(1.+gw_param/2.) call put_to_tiles_r0d_fptr( gw_param3, land_tile_map, soil_hillslope_zeta_bar_ptr ) endif - call read_field( 'INPUT/geohydrology.nc','soil_e_depth', gw_param, interp='bilinear' ) + call read_field( fileobj, 'soil_e_depth', gw_param, interp='bilinear' ) if (slope_exp.gt.0.01) then call put_to_tiles_r0d_fptr( gw_param*gw_scale_soil_depth*(0.08/gw_param2)**slope_exp, & land_tile_map, soil_soil_e_depth_ptr ) @@ -477,7 +476,7 @@ subroutine soil_init (predefined_tiles, id_ug,id_band,id_zfull) call put_to_tiles_r0d_fptr( gw_param*gw_scale_soil_depth, land_tile_map, soil_soil_e_depth_ptr ) endif if (gw_option /= GW_HILL_AR5) then - call read_field( 'INPUT/geohydrology.nc','perm', gw_param, interp='bilinear' ) + call read_field( fileobj, 'perm', gw_param, interp='bilinear' ) call put_to_tiles_r0d_fptr(9.8e9*gw_scale_perm*gw_param, land_tile_map, & soil_k_sat_gw_ptr ) endif @@ -492,18 +491,24 @@ subroutine soil_init (predefined_tiles, id_ug,id_band,id_zfull) call soil_data_init_derive_subsurf_pars_ar5(tile%soil) end select enddo + call close_file(fileobj) case (GW_TILED) if (use_geohydrodata) then + exists = open_file(fileobj, "INPUT/geohydrology.nc", "read") + if (.not. exists) then + call error_mesg("soil_init", "INPUT/geohydrology.nc does not exist", & + fatal) + endif allocate(gw_param (lnd%ls:lnd%le), gw_param2(lnd%ls:lnd%le)) - call read_field( 'INPUT/geohydrology.nc','hillslope_length', gw_param, interp='bilinear' ) + call read_field( fileobj, 'hillslope_length', gw_param, interp='bilinear' ) call put_to_tiles_r0d_fptr( gw_param*gw_scale_length, land_tile_map, soil_hillslope_length_ptr ) - call read_field( 'INPUT/geohydrology.nc','slope', gw_param2, interp='bilinear' ) + call read_field( fileobj, 'slope', gw_param2, interp='bilinear' ) gw_param = gw_param*gw_param2 call put_to_tiles_r0d_fptr( gw_param*gw_scale_relief, land_tile_map, soil_hillslope_relief_ptr ) - call read_field( 'INPUT/geohydrology.nc','hillslope_zeta_bar', gw_param, interp='bilinear' ) + call read_field( fileobj, 'hillslope_zeta_bar', gw_param, interp='bilinear' ) if (zeta_bar_override.gt.0.) gw_param=zeta_bar_override call put_to_tiles_r0d_fptr( gw_param, land_tile_map, soil_hillslope_zeta_bar_ptr ) - call read_field( 'INPUT/geohydrology.nc','soil_e_depth', gw_param, interp='bilinear' ) + call read_field( fileobj, 'soil_e_depth', gw_param, interp='bilinear' ) if (slope_exp.gt.0.01) then ! ZMS It's probably inconsistent to leave in this if statement. @@ -514,10 +519,11 @@ subroutine soil_init (predefined_tiles, id_ug,id_band,id_zfull) else call put_to_tiles_r0d_fptr( gw_param*gw_scale_soil_depth, land_tile_map, soil_soil_e_depth_ptr ) endif - call read_field( 'INPUT/geohydrology.nc','perm', gw_param, interp='bilinear' ) + call read_field( fileobj, 'perm', gw_param, interp='bilinear' ) call put_to_tiles_r0d_fptr(9.8e9*gw_scale_perm*gw_param, land_tile_map, & soil_k_sat_gw_ptr ) deallocate(gw_param, gw_param2) + call close_file(fileobj) end if ce = first_elmt(land_tile_map) do while(loop_over_tiles(ce,tile)) @@ -530,8 +536,14 @@ subroutine soil_init (predefined_tiles, id_ug,id_band,id_zfull) ! -------- set dry soil albedo values, if requested if (trim(albedo_to_use)=='albedo-map') then allocate(albedo(lnd%ls:lnd%le,NBANDS)) - call read_field( 'INPUT/soil_albedo.nc','SOIL_ALBEDO_VIS', albedo(:,BAND_VIS),'bilinear') - call read_field( 'INPUT/soil_albedo.nc','SOIL_ALBEDO_NIR', albedo(:,BAND_NIR),'bilinear') + exists = open_file(fileobj, "INPUT/soil_albedo.nc", "read") + if (.not. exists) then + call error_mesg("soil_init", "INPUT/soil_albedo.nc does not exist", & + fatal) + endif + call read_field( fileobj, 'SOIL_ALBEDO_VIS', albedo(:,BAND_VIS),'bilinear') + call read_field( fileobj, 'SOIL_ALBEDO_NIR', albedo(:,BAND_NIR),'bilinear') + call close_file(fileobj) call put_to_tiles_r1d_fptr( albedo, land_tile_map, soil_refl_dry_dir_ptr ) call put_to_tiles_r1d_fptr( albedo, land_tile_map, soil_refl_dry_dif_ptr ) ! for now, put the same value into the saturated soil albedo, so that @@ -545,12 +557,18 @@ subroutine soil_init (predefined_tiles, id_ug,id_band,id_zfull) allocate( f_vol(lnd%ls:lnd%le,NBANDS)) allocate( f_geo(lnd%ls:lnd%le,NBANDS)) allocate(refl_dif(lnd%ls:lnd%le,NBANDS)) - call read_field( 'INPUT/soil_brdf.nc','f_iso_vis', f_iso(:,BAND_VIS),'bilinear') - call read_field( 'INPUT/soil_brdf.nc','f_vol_vis', f_vol(:,BAND_VIS),'bilinear') - call read_field( 'INPUT/soil_brdf.nc','f_geo_vis', f_geo(:,BAND_VIS),'bilinear') - call read_field( 'INPUT/soil_brdf.nc','f_iso_nir', f_iso(:,BAND_NIR),'bilinear') - call read_field( 'INPUT/soil_brdf.nc','f_vol_nir', f_vol(:,BAND_NIR),'bilinear') - call read_field( 'INPUT/soil_brdf.nc','f_geo_nir', f_geo(:,BAND_NIR),'bilinear') + exists = open_file(fileobj, "INPUT/soil_brdf.nc", "read") + if (.not. exists) then + call error_mesg("soil_init", "INPUT/soil_brdf.nc does not exist.", & + fatal) + endif + call read_field( fileobj, 'f_iso_vis', f_iso(:,BAND_VIS),'bilinear') + call read_field( fileobj, 'f_vol_vis', f_vol(:,BAND_VIS),'bilinear') + call read_field( fileobj, 'f_geo_vis', f_geo(:,BAND_VIS),'bilinear') + call read_field( fileobj, 'f_iso_nir', f_iso(:,BAND_NIR),'bilinear') + call read_field( fileobj, 'f_vol_nir', f_vol(:,BAND_NIR),'bilinear') + call read_field( fileobj, 'f_geo_nir', f_geo(:,BAND_NIR),'bilinear') + call close_file(fileobj) refl_dif = g_iso*f_iso + g_vol*f_vol + g_geo*f_geo call put_to_tiles_r1d_fptr( f_iso, land_tile_map, soil_f_iso_dry_ptr ) call put_to_tiles_r1d_fptr( f_vol, land_tile_map, soil_f_vol_dry_ptr ) @@ -579,8 +597,14 @@ subroutine soil_init (predefined_tiles, id_ug,id_band,id_zfull) if (use_coldstart_wtt_data) then allocate(ref_soil_t(lnd%ls:lnd%le), wetmask(lnd%ls:lnd%le)) - call read_field( coldstart_datafile, 'REFSOILT', ref_soil_t, interp='bilinear' ) - call read_field( coldstart_datafile, 'WETMASK', wetmask, interp='bilinear' ) + exists = open_file(fileobj, coldstart_datafile, "read") + if (.not. exists) then + call error_mesg("soil_init", trim(coldstart_datafile)//" does not exist.", & + fatal) + endif + call read_field( fileobj, 'REFSOILT', ref_soil_t, interp='bilinear' ) + call read_field( fileobj, 'WETMASK', wetmask, interp='bilinear' ) + call close_file(fileobj) end if ! -------- initialize soil state -------- @@ -1435,24 +1459,24 @@ subroutine save_soil_restart (tile_dim_length, timestamp) call error_mesg('soil_end','writing NetCDF restart',NOTE) ! must set domain so that io_domain is available ! Note that filename is updated for tile & rank numbers during file creation - filename = trim(timestamp)//'soil.res.nc' + filename = 'RESTART/'//trim(timestamp)//'soil.nc' call init_land_restart(restart, filename, soil_tile_exists, tile_dim_length) - call add_restart_axis(restart,'zfull',zfull(1:num_l),'Z','m','full level',sense=-1) + call add_restart_axis(restart,'zfull',zfull(1:num_l),.false.,"Z",'m','full level') if (soil_carbon_option==SOILC_CORPSE) then - call add_restart_axis(restart,'soilCCohort',(/(float(i),i=1,soilMaxCohorts)/),'CC') + call add_restart_axis(restart,'soilCCohort',(/(float(i),i=1,soilMaxCohorts)/), .false.) endif ! write out fields - call add_tile_data(restart,'temp' , 'zfull', soil_T_ptr, 'soil temperature','degrees_K') - call add_tile_data(restart,'wl' , 'zfull', soil_wl_ptr, 'liquid water content','kg/m2') - call add_tile_data(restart,'ws' , 'zfull', soil_ws_ptr, 'solid water content','kg/m2') - call add_tile_data(restart,'groundwater' , 'zfull', soil_groundwater_ptr, units='kg/m2' ) - call add_tile_data(restart,'groundwater_T', 'zfull', soil_groundwater_T_ptr, 'groundwater temperature','degrees_K' ) + call add_tile_data(restart,'temp' , 'zfull ', soil_T_ptr, 'soil temperature','degrees_K') + call add_tile_data(restart,'wl' , 'zfull ', soil_wl_ptr, 'liquid water content','kg/m2') + call add_tile_data(restart,'ws' , 'zfull ', soil_ws_ptr, 'solid water content','kg/m2') + call add_tile_data(restart,'groundwater' , 'zfull ', soil_groundwater_ptr, units='kg/m2' ) + call add_tile_data(restart,'groundwater_T', 'zfull ', soil_groundwater_T_ptr, 'groundwater temperature','degrees_K' ) call add_tile_data(restart,'uptake_T', soil_uptake_T_ptr, 'temperature of transpiring water', 'degrees_K') select case(soil_carbon_option) case (SOILC_CENTURY, SOILC_CENTURY_BY_LAYER) - call add_tile_data(restart,'fsc', 'zfull', soil_fast_soil_C_ptr ,'fast soil carbon', 'kg C/m2') - call add_tile_data(restart,'ssc', 'zfull', soil_slow_soil_C_ptr ,'slow soil carbon', 'kg C/m2') + call add_tile_data(restart,'fsc', 'zfull ', soil_fast_soil_C_ptr ,'fast soil carbon', 'kg C/m2') + call add_tile_data(restart,'ssc', 'zfull ', soil_slow_soil_C_ptr ,'slow soil carbon', 'kg C/m2') case (SOILC_CORPSE) ce = first_elmt(land_tile_map) do while(loop_over_tiles(ce,tile)) @@ -1465,31 +1489,31 @@ subroutine save_soil_restart (tile_dim_length, timestamp) enddo end do - call add_tile_data(restart,'fast_soil_C','zfull','soilCCohort', & + call add_tile_data(restart,'fast_soil_C','zfull ','soilCCohort ', & sc_soil_C_ptr,C_CEL,'Fast soil carbon','kg/m2') - call add_tile_data(restart,'slow_soil_C', 'zfull','soilCCohort', & + call add_tile_data(restart,'slow_soil_C', 'zfull ','soilCCohort ', & sc_soil_C_ptr,C_LIG,'Slow soil carbon','kg/m2') - call add_tile_data(restart,'deadMic', 'zfull','soilCCohort', & + call add_tile_data(restart,'deadMic', 'zfull ','soilCCohort ', & sc_soil_C_ptr,C_MIC,'Dead microbe carbon','kg/m2') - call add_tile_data(restart,'fastProtectedC', 'zfull','soilCCohort', & + call add_tile_data(restart,'fastProtectedC', 'zfull ','soilCCohort ', & sc_protected_C_ptr,C_CEL,'Protected fast carbon','kg/m2') - call add_tile_data(restart,'slowProtectedC', 'zfull','soilCCohort', & + call add_tile_data(restart,'slowProtectedC', 'zfull ','soilCCohort ', & sc_protected_C_ptr,C_LIG,'Protected slow carbon','kg/m2') - call add_tile_data(restart,'deadMicrobeProtectedC', 'zfull','soilCCohort', & + call add_tile_data(restart,'deadMicrobeProtectedC', 'zfull ','soilCCohort ', & sc_protected_C_ptr,C_MIC,'Protected dead microbe carbon','kg/m2') - call add_tile_data(restart,'liveMic', 'zfull','soilCCohort', & + call add_tile_data(restart,'liveMic', 'zfull ','soilCCohort ', & soilc_livingMicrobeC_ptr,'Living microbial carbon','kg/m2') - call add_tile_data(restart,'CO2', 'zfull','soilCCohort', & + call add_tile_data(restart,'CO2', 'zfull ','soilCCohort ', & soilc_CO2_ptr,'Cohort CO2 generated','kg/m2') - call add_tile_data(restart,'Rtot', 'zfull','soilCCohort', & + call add_tile_data(restart,'Rtot', 'zfull ','soilCCohort ', & soilc_Rtot_ptr,'Total degradation','kg/m2') - call add_tile_data(restart,'originalCohortC', 'zfull','soilCCohort', & + call add_tile_data(restart,'originalCohortC', 'zfull ','soilCCohort ', & soilc_originalLitterC_ptr,'Cohort original carbon','g/m2') - call add_tile_data(restart,'soil_DOC_fast', 'zfull', soil_fast_DOC_ptr ,'Dissolved fast carbon','kg/m2') - call add_tile_data(restart,'soil_DOC_slow', 'zfull', soil_slow_DOC_ptr ,'Dissolved slow carbon','kg/m2') - call add_tile_data(restart,'soil_DOC_deadmic', 'zfull', & + call add_tile_data(restart,'soil_DOC_fast', 'zfull ', soil_fast_DOC_ptr ,'Dissolved fast carbon','kg/m2') + call add_tile_data(restart,'soil_DOC_slow', 'zfull ', soil_slow_DOC_ptr ,'Dissolved slow carbon','kg/m2') + call add_tile_data(restart,'soil_DOC_deadmic', 'zfull ', & soil_deadmicrobe_DOC_ptr ,'Dissolved dead microbe carbon','kg/m2') call add_tile_data(restart,'fast_DOC_leached', soil_fast_DOC_leached_ptr, & @@ -1499,17 +1523,17 @@ subroutine save_soil_restart (tile_dim_length, timestamp) call add_tile_data(restart,'deadmic_DOC_leached', soil_deadmic_DOC_leached_ptr, & 'Cumulative dead microbe DOC leached out of the column', 'kg/m2') - call add_tile_data(restart,'leaf_litter_fast_C', 'soilCCohort', & + call add_tile_data(restart,'leaf_litter_fast_C', 'soilCCohort ', & soilc_leafLitter_litterC_ptr,C_CEL,'Leaf litter fast C','kg/m2') - call add_tile_data(restart,'leaf_litter_slow_C', 'soilCCohort', & + call add_tile_data(restart,'leaf_litter_slow_C', 'soilCCohort ', & soilc_leafLitter_litterC_ptr,C_LIG,'Leaf litter slow C','kg/m2') - call add_tile_data(restart,'leaf_litter_deadMic_C', 'soilCCohort', & + call add_tile_data(restart,'leaf_litter_deadMic_C', 'soilCCohort ', & soilc_leafLitter_litterC_ptr,C_MIC,'Leaf litter dead microbe C','kg/m2') - call add_tile_data(restart,'leaf_litter_liveMic_C','soilCCohort', & + call add_tile_data(restart,'leaf_litter_liveMic_C','soilCCohort ', & soilc_leafLitter_livingMicrobeC_ptr,'Leaf litter live microbe C','kg/m2') - call add_tile_data(restart,'leaf_litter_CO2','soilCCohort', & + call add_tile_data(restart,'leaf_litter_CO2','soilCCohort ', & soilc_leafLitter_CO2_ptr,'Leaf litter CO2 generated','kg/m2') - call add_tile_data(restart,'leaf_litter_Rtot','soilCCohort', & + call add_tile_data(restart,'leaf_litter_Rtot','soilCCohort ', & soilc_leafLitter_Rtot_ptr,'Leaf litter total degradation','kg/m2') call add_tile_data(restart,'leaf_litter_originalCohortC','soilCCohort', & soilc_leafLitter_originalLitterC_ptr,'Leaf litter cohort original carbon','kg/m2') @@ -1524,17 +1548,17 @@ subroutine save_soil_restart (tile_dim_length, timestamp) call add_tile_data(restart,'leaf_litter_DOC_slow',soilc_leafLitter_DOC_ptr,C_LIG,'Dissolved leaf litter slow carbon','kg/m2') call add_tile_data(restart,'leaf_litter_DOC_deadmic',soilc_leafLitter_DOC_ptr,C_MIC,'Dissolved leaf litter dead microbe carbon','kg/m2') - call add_tile_data(restart,'fineWood_litter_fast_C', 'soilCCohort', & + call add_tile_data(restart,'fineWood_litter_fast_C', 'soilCCohort ', & soilc_fineWoodLitter_litterC_ptr,C_CEL,'Fine wood litter fast C','kg/m2') - call add_tile_data(restart,'fineWood_litter_slow_C', 'soilCCohort', & + call add_tile_data(restart,'fineWood_litter_slow_C', 'soilCCohort ', & soilc_fineWoodLitter_litterC_ptr,C_LIG,'Fine wood litter slow C','kg/m2') - call add_tile_data(restart,'fineWood_litter_deadMic_C', 'soilCCohort', & + call add_tile_data(restart,'fineWood_litter_deadMic_C', 'soilCCohort ', & soilc_fineWoodLitter_litterC_ptr,C_MIC,'Fine wood litter dead microbe C','kg/m2') - call add_tile_data(restart,'fineWood_litter_liveMic_C', 'soilCCohort', & + call add_tile_data(restart,'fineWood_litter_liveMic_C', 'soilCCohort ', & soilc_fineWoodLitter_livingMicrobeC_ptr,'Fine wood litter live microbe C','kg/m2') - call add_tile_data(restart,'fineWood_litter_CO2','soilCCohort', & + call add_tile_data(restart,'fineWood_litter_CO2','soilCCohort ', & soilc_fineWoodLitter_CO2_ptr,'Fine wood litter CO2 generated','kg/m2') - call add_tile_data(restart,'fineWood_litter_Rtot','soilCCohort', & + call add_tile_data(restart,'fineWood_litter_Rtot','soilCCohort ', & soilc_fineWoodLitter_Rtot_ptr,'Fine wood litter total degradation','kg/m2') call add_tile_data(restart,'fineWood_litter_originalCohortC','soilCCohort', & soilc_fineWoodLitter_originalLitterC_ptr,'Fine wood litter cohort original carbon','kg/m2') @@ -1552,17 +1576,17 @@ subroutine save_soil_restart (tile_dim_length, timestamp) call add_tile_data(restart,'fineWood_litter_DOC_deadmic',soilc_fineWoodLitter_DOC_ptr,C_MIC,& 'Dissolved fine wood litter dead microbe carbon','kg/m2') - call add_tile_data(restart,'coarseWood_litter_fast_C', 'soilCCohort', & + call add_tile_data(restart,'coarseWood_litter_fast_C', 'soilCCohort ', & soilc_coarseWoodLitter_litterC_ptr,C_CEL,'Coarse wood litter fast C','kg/m2') - call add_tile_data(restart,'coarseWood_litter_slow_C', 'soilCCohort', & + call add_tile_data(restart,'coarseWood_litter_slow_C', 'soilCCohort ', & soilc_coarseWoodLitter_litterC_ptr,C_LIG,'Coarse wood litter slow C','kg/m2') - call add_tile_data(restart,'coarseWood_litter_deadMic_C', 'soilCCohort', & + call add_tile_data(restart,'coarseWood_litter_deadMic_C', 'soilCCohort ', & soilc_coarseWoodLitter_litterC_ptr,C_MIC,'Coarse wood litter dead microbe C','kg/m2') - call add_tile_data(restart,'coarseWood_litter_liveMic_C', 'soilCCohort', & + call add_tile_data(restart,'coarseWood_litter_liveMic_C', 'soilCCohort ', & soilc_coarseWoodLitter_livingMicrobeC_ptr,'Coarse wood litter live microbe C','kg/m2') - call add_tile_data(restart,'coarseWood_litter_CO2','soilCCohort', & + call add_tile_data(restart,'coarseWood_litter_CO2','soilCCohort ', & soilc_coarseWoodLitter_CO2_ptr,'Coarse wood litter CO2 generated','kg/m2') - call add_tile_data(restart,'coarseWood_litter_Rtot','soilCCohort', & + call add_tile_data(restart,'coarseWood_litter_Rtot','soilCCohort ', & soilc_coarseWoodLitter_Rtot_ptr,'Coarse wood litter total degradation','kg/m2') call add_tile_data(restart,'coarseWood_litter_originalCohortC','soilCCohort', & soilc_coarseWoodLitter_originalLitterC_ptr,'Coarse wood litter cohort original carbon','kg/m2') @@ -1580,7 +1604,7 @@ subroutine save_soil_restart (tile_dim_length, timestamp) call add_tile_data(restart,'coarseWood_litter_DOC_deadmic',soilc_coarseWoodLitter_DOC_ptr,C_MIC, & 'Dissolved coarse wood litter dead microbe carbon','kg/m2') - call add_int_tile_data(restart,'is_peat', 'zfull', soil_is_peat_ptr ,'Is layer peat?','Boolean') + call add_int_tile_data(restart,'is_peat', 'zfull ', soil_is_peat_ptr ,'Is layer peat?','Boolean') case default call error_mesg('save_soil_restart','soil_carbon_option is invalid. This should never happen. Contact developer', FATAL) end select @@ -1588,33 +1612,33 @@ subroutine save_soil_restart (tile_dim_length, timestamp) call free_land_restart(restart) if (write_soil_carbon_restart) then - filename = trim(timestamp)//'soil_carbon.res.nc' + filename = 'RESTART/'//trim(timestamp)//'soil_carbon.nc' call init_land_restart(restart, filename, soil_tile_exists, tile_dim_length) - call add_restart_axis(restart,'zfull',zfull(1:num_l),'Z','m','full level',sense=-1) + call add_restart_axis(restart,'zfull ',zfull(1:num_l),.false.,"Z",'m','full level') - call add_tile_data(restart,'asoil_in', 'zfull', soil_asoil_in_ptr ,'aerobic activity modifier', 'unitless') - call add_tile_data(restart,'fsc_in', 'zfull', soil_fsc_in_ptr ,'fast soil carbon input', 'kg C/m2') - call add_tile_data(restart,'ssc_in', 'zfull', soil_ssc_in_ptr ,'slow soil carbon input', 'kg C/m2') + call add_tile_data(restart,'asoil_in', 'zfull ', soil_asoil_in_ptr ,'aerobic activity modifier', 'unitless') + call add_tile_data(restart,'fsc_in', 'zfull ', soil_fsc_in_ptr ,'fast soil carbon input', 'kg C/m2') + call add_tile_data(restart,'ssc_in', 'zfull ', soil_ssc_in_ptr ,'slow soil carbon input', 'kg C/m2') if (soil_carbon_option == SOILC_CORPSE) then - call add_tile_data(restart,'deadmic_in', 'zfull', & + call add_tile_data(restart,'deadmic_in', 'zfull ', & soil_deadmic_in_ptr ,'dead microbe soil carbon input', 'kg C/m2') - call add_tile_data(restart,'fast_protected_in', 'zfull', & + call add_tile_data(restart,'fast_protected_in', 'zfull ', & soil_fast_protected_in_ptr ,'protected fast soil carbon input', 'kg C/m2') - call add_tile_data(restart,'slow_protected_in', 'zfull', & + call add_tile_data(restart,'slow_protected_in', 'zfull ', & soil_slow_protected_in_ptr ,'protected slow soil carbon input', 'kg C/m2') - call add_tile_data(restart,'deadmic_protected_in', 'zfull', & + call add_tile_data(restart,'deadmic_protected_in', 'zfull ', & soil_deadmic_protected_in_ptr ,'protected dead microbe soil carbon input', 'kg C/m2') - call add_tile_data(restart,'fast_turnover_accumulated', 'zfull', & + call add_tile_data(restart,'fast_turnover_accumulated', 'zfull ', & soil_fast_turnover_accumulated_ptr ,'fast soil carbon turnover', 'year-1') - call add_tile_data(restart,'slow_turnover_accumulated', 'zfull', & + call add_tile_data(restart,'slow_turnover_accumulated', 'zfull ', & soil_slow_turnover_accumulated_ptr ,'slow soil carbon turnover', 'year-1') - call add_tile_data(restart,'deadmic_turnover_accumulated', 'zfull', & + call add_tile_data(restart,'deadmic_turnover_accumulated', 'zfull ', & soil_deadmic_turnover_accumulated_ptr ,'dead microbe soil carbon turnover', 'year-1') - call add_tile_data(restart,'fast_protected_turnover_accumulated', 'zfull', & + call add_tile_data(restart,'fast_protected_turnover_accumulated', 'zfull ', & soil_fast_protected_turnover_accumulated_ptr ,'fast protected soil carbon turnover', 'year-1') - call add_tile_data(restart,'slow_protected_turnover_accumulated', 'zfull', & + call add_tile_data(restart,'slow_protected_turnover_accumulated', 'zfull ', & soil_slow_protected_turnover_accumulated_ptr ,'slow protected soil carbon turnover', 'year-1') - call add_tile_data(restart,'deadmic_protected_turnover_accumulated', 'zfull', & + call add_tile_data(restart,'deadmic_protected_turnover_accumulated', 'zfull ', & soil_deadmic_protected_turnover_accumulated_ptr ,'dead microbe protected soil carbon turnover', 'year-1') call add_tile_data(restart,'leaflitter_fast_turnover_accumulated',& diff --git a/soil/soil_carbon.F90 b/soil/soil_carbon.F90 index 4b3c42f4..7545e412 100644 --- a/soil/soil_carbon.F90 +++ b/soil/soil_carbon.F90 @@ -25,7 +25,7 @@ module soil_carbon_mod use constants_mod, only : pi, dens_h2o use land_constants_mod, only : Rugas, seconds_per_year -use fms_mod, only: check_nml_error, file_exist, close_file, & +use fms_mod, only: check_nml_error, & stdlog, mpp_pe, mpp_root_pe, error_mesg, FATAL, NOTE use vegn_data_mod, only: K1,K2 use land_numerics_mod,only: tridiag @@ -192,7 +192,7 @@ end subroutine init_soil_carbon ! ============================================================================= #ifndef STANDALONE_SOIL_CARBON subroutine read_soil_carbon_namelist - integer :: unit ! unit for namelist i/o + integer :: file_unit ! unit for namelist i/o integer :: io ! i/o status for the namelist integer :: ierr ! error code, returned by i/o routines integer :: i @@ -200,24 +200,12 @@ subroutine read_soil_carbon_namelist call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML read (input_nml_file, nml=soil_carbon_nml, iostat=io) ierr = check_nml_error(io, 'soil_carbon_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=soil_carbon_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'soil_carbon_nml') - enddo -10 continue - call close_file (unit) - endif -#endif + if (mpp_pe() == mpp_root_pe()) then - unit=stdlog() - write(unit, nml=soil_carbon_nml) + file_unit=stdlog() + write(file_unit, nml=soil_carbon_nml) endif diff --git a/soil/soil_tile.F90 b/soil/soil_tile.F90 index 5ddbfa4e..ff2bc136 100644 --- a/soil/soil_tile.F90 +++ b/soil/soil_tile.F90 @@ -19,19 +19,9 @@ module soil_tile_mod #include -#ifdef INTERNAL_FILE_NML +use fms_mod, only : check_nml_error, & + stdlog, error_mesg, FATAL use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif - -use mpp_io_mod, only : & - mpp_open, mpp_close, MPP_NETCDF, MPP_MULTI, MPP_SINGLE, MPP_RDONLY, & - mpp_get_fields, mpp_get_atts, mpp_get_field_index, fieldtype, & - axistype, mpp_get_info - -use fms_mod, only : file_exist, check_nml_error, & - close_file, stdlog, read_data, error_mesg, FATAL use constants_mod, only : & pi, tfreeze, rvgas, grav, dens_h2o, hlf, epsln use land_constants_mod, only : BAND_VIS, BAND_NIR, NBANDS @@ -44,6 +34,9 @@ module soil_tile_mod use tiling_input_types_mod, only : soil_predefined_type use land_debug_mod, only : is_watch_point +use fms2_io_mod, only: close_file, FmsNetcdfFile_t, get_variable_size, & + open_file, read_data, get_variable_num_dimensions + implicit none private @@ -574,26 +567,15 @@ subroutine read_soil_data_namelist(soil_num_l, soil_dz, soil_single_geo, & integer :: i, rcode, input_unit, varid, dimids(3) integer :: ndim, nvar, natt, timelen - type(fieldtype), allocatable :: Fields(:) - type(axistype), allocatable :: axes(:) + type(FmsNetcdfFile_t) :: fileobj + logical :: exists + integer, dimension(:), allocatable :: dimlens + integer :: ndims call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML read (input_nml_file, nml=soil_data_nml, iostat=io) ierr = check_nml_error(io, 'soil_data_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=soil_data_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'soil_data_nml') - enddo -10 continue - call close_file (unit) - endif -#endif unit=stdlog() write(unit, nml=soil_data_nml) @@ -654,24 +636,29 @@ subroutine read_soil_data_namelist(soil_num_l, soil_dz, soil_single_geo, & if (gw_option==GW_HILL_AR5.and..not.use_single_geo) then num_storage_pts = 26 - call read_data('INPUT/geohydrology_table.nc', 'gw_flux_norm', & - gw_flux_table, no_domain=.true.) - call read_data('INPUT/geohydrology_table.nc', 'gw_area_norm', & - gw_area_table, no_domain=.true.) + exists = open_file(fileobj, "INPUT/geohydrology_table.nc", "read") + if (.not. exists) then + call error_mesg("read_soil_data_namelist", & + "file INPUT/geohydrology_table.nc does not exist.", & + fatal) + endif + call read_data(fileobj, "gw_flux_norm", gw_flux_table) + call read_data(fileobj, "gw_area_norm", gw_area_table) + call close_file(fileobj) else if (gw_option==GW_HILL) then - call mpp_open(input_unit, 'INPUT/geohydrology_table_2a2n.nc', action=MPP_RDONLY, form=MPP_NETCDF, & - threading=MPP_MULTI, fileset=MPP_SINGLE, iostat=ierr) - call mpp_get_info(input_unit,ndim,nvar,natt,timelen) - allocate(Fields(nvar)) - call mpp_get_fields(input_unit, Fields) - call mpp_get_atts(Fields(mpp_get_field_index(Fields, 'log_rho_a0n1')), ndim=ndim) - allocate (axes(ndim)) - call mpp_get_atts(Fields(mpp_get_field_index(Fields, 'log_rho_a0n1')), axes=axes) - call mpp_get_atts(axes(1), len=num_storage_pts) - call mpp_get_atts(axes(2), len=num_tau_pts) - call mpp_get_atts(axes(3), len=num_zeta_pts) - call mpp_close(input_unit) - deallocate (Fields, axes) + exists = open_file(fileobj, 'INPUT/geohydrology_table_2a2n.nc', "read") + if (.not. exists) then + call error_mesg("read_soil_data_namelist", & + "file INPUT/geohydrology_table_2a2n.nc does not exist.", & + fatal) + endif + ndims = get_variable_num_dimensions(fileobj, "log_rho_a0n1") + allocate(dimlens(ndims)) + call get_variable_size(fileobj, "log_rho_a0n1", dimlens) + num_storage_pts = dimlens(1) + num_tau_pts = dimlens(2) + num_zeta_pts = dimlens(3) + deallocate(dimlens) allocate (log_rho_table(num_storage_pts, num_tau_pts, num_zeta_pts, 2, 2)) allocate (log_deficit_list(num_storage_pts)) @@ -679,24 +666,17 @@ subroutine read_soil_data_namelist(soil_num_l, soil_dz, soil_single_geo, & allocate (log_zeta_s(num_zeta_pts)) if (.not.retro_a0n1) then - call read_data('INPUT/geohydrology_table_2a2n.nc', 'log_rho_a0n1', & - log_rho_table(:,:,:,1,1), no_domain=.true.) + call read_data(fileobj, "log_rho_a0n1", log_rho_table(:,:,:,1,1)) else - call read_data('INPUT/geohydrology_table_2a2n.nc', 'retro_log_rho_a0n1', & - log_rho_table(:,:,:,1,1), no_domain=.true.) + call read_data(fileobj, "retro_log_rho_a0n1", log_rho_table(:,:,:,1,1)) endif - call read_data('INPUT/geohydrology_table_2a2n.nc', 'log_rho_a0n2', & - log_rho_table(:,:,:,1,2), no_domain=.true.) - call read_data('INPUT/geohydrology_table_2a2n.nc', 'log_rho_a1n1', & - log_rho_table(:,:,:,2,1), no_domain=.true.) - call read_data('INPUT/geohydrology_table_2a2n.nc', 'log_rho_a1n2', & - log_rho_table(:,:,:,2,2), no_domain=.true.) - call read_data('INPUT/geohydrology_table_2a2n.nc', 'log_deficit', & - log_deficit_list, no_domain=.true.) - call read_data('INPUT/geohydrology_table_2a2n.nc', 'log_tau', & - log_tau, no_domain=.true.) - call read_data('INPUT/geohydrology_table_2a2n.nc', 'log_zeta_s', & - log_zeta_s, no_domain=.true.) + call read_data(fileobj, "log_rho_a0n2", log_rho_table(:,:,:,1,2)) + call read_data(fileobj, "log_rho_a1n1", log_rho_table(:,:,:,2,1)) + call read_data(fileobj, "log_rho_a1n2", log_rho_table(:,:,:,2,2)) + call read_data(fileobj, "log_deficit", log_deficit_list) + call read_data(fileobj, "log_tau", log_tau) + call read_data(fileobj, "log_zeta_s", log_zeta_s) + call close_file(fileobj) endif diff --git a/topo_rough/topo_rough.F90 b/topo_rough/topo_rough.F90 index d92fbe38..c0dd12d2 100644 --- a/topo_rough/topo_rough.F90 +++ b/topo_rough/topo_rough.F90 @@ -24,20 +24,15 @@ module topo_rough_mod use time_manager_mod, only : time_type use mpp_domains_mod, only : domain2d, domainUG, mpp_pass_SG_to_UG, mpp_get_ug_compute_domain, & mpp_get_compute_domain - -#ifdef INTERNAL_FILE_NML -use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif use fms_mod, only : error_mesg, FATAL, NOTE, & - open_restart_file, read_data, & - write_data, close_file, file_exist, check_nml_error, mpp_pe, & + check_nml_error, mpp_pe, & mpp_root_pe, stdlog + use mpp_mod, only: input_nml_file use diag_manager_mod, only : register_static_field, send_data use topography_mod, only : get_topog_stdev use land_data_mod, only : log_version - + use fms2_io_mod, only : open_file, close_file, register_axis, register_field, FmsNetcdfDomainFile_t, read_data + use fms2_io_mod, only : get_variable_num_dimensions, get_variable_dimension_names implicit none private ! ==== public interface ====================================================== @@ -93,9 +88,6 @@ module topo_rough_mod real, allocatable, save ::topo_stdev(:) logical :: module_is_initialized = .FALSE. -! ==== NetCDF declarations =================================================== -include 'netcdf.inc' - contains ! ################################################################### subroutine topo_rough_init(time, lonb, latb, SG_domain, UG_domain, id_ug) @@ -122,25 +114,16 @@ subroutine topo_rough_init(time, lonb, latb, SG_domain, UG_domain, id_ug) real, allocatable :: topo_stdev_SG(:,:) logical :: used, got_stdev + type(FmsNetcdfDomainFile_t) :: topo_rough_fileobj + integer :: ndims + character(len=20), allocatable :: dimnames(:) + call log_version(version, module_name, & __FILE__) ! read and write (to logfile) namelist variables -#ifdef INTERNAL_FILE_NML read (input_nml_file, nml=topo_rough_nml, iostat=io) ierr = check_nml_error(io, 'topo_rough_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file ( ) - ierr = 1; - do while (ierr /= 0) - read (unit, nml=topo_rough_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'topo_rough_nml') - enddo -10 continue - call close_file (unit) - endif -#endif if (mpp_pe() == mpp_root_pe()) then unit=stdlog() @@ -163,12 +146,19 @@ subroutine topo_rough_init(time, lonb, latb, SG_domain, UG_domain, id_ug) else if (trim(topo_rough_source)=='input') then call error_mesg('topo_rough_init','reading topography standard deviation from "'& //trim(topo_rough_file)//'"',NOTE) - if(.not.file_exist(topo_rough_file,SG_domain))& + if (.not. open_file(topo_rough_fileobj, topo_rough_file, "read", SG_domain)) & call error_mesg('topo_rough_init', & 'input file for topography standard deviation "'// & trim(topo_rough_file)//'" does not exist', FATAL) - - call read_data(topo_rough_file,topo_rough_var,topo_stdev_SG,domain=SG_domain) + ndims = get_variable_num_dimensions(topo_rough_fileobj, topo_rough_var) + allocate(dimnames(ndims)) + call get_variable_dimension_names(topo_rough_fileobj, topo_rough_var, dimnames) + call register_axis(topo_rough_fileobj, dimnames(1), "x") + call register_axis(topo_rough_fileobj, dimnames(2), "y") + call register_field(topo_rough_fileobj, topo_rough_var, "double", dimnames) + call read_data(topo_rough_fileobj, topo_rough_var, topo_stdev_SG) + deallocate(dimnames) + call close_file(topo_rough_fileobj) else call error_mesg('topo_rough_init','"'//trim(topo_rough_source)//& '" is not a valid value for topo_rough_source', FATAL) diff --git a/transitions/transitions.F90 b/transitions/transitions.F90 index 592a786f..9b3b0af8 100644 --- a/transitions/transitions.F90 +++ b/transitions/transitions.F90 @@ -21,25 +21,24 @@ module land_transitions_mod #include "../shared/debug.inc" +use netcdf, only: nf90_max_name + use constants_mod, only : PI -#ifdef INTERNAL_FILE_NML -use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif use mpp_domains_mod, only : mpp_pass_ug_to_sg -use mpp_io_mod, only : fieldtype, mpp_get_info, mpp_get_fields -use mpp_io_mod, only : mpp_get_axes, mpp_get_axis_data, mpp_read, validtype, mpp_is_valid -use mpp_io_mod, only : mpp_get_atts, MPP_RDONLY, MPP_NETCDF, MPP_MULTI, MPP_SINGLE, axistype -use mpp_io_mod, only : mpp_get_times, mpp_open, mpp_close, MPP_ASCII, mpp_get_field_index - -use axis_utils_mod, only : get_axis_bounds use fms_mod, only : string, error_mesg, FATAL, WARNING, NOTE, & - mpp_pe, lowercase, file_exist, close_file, & + mpp_pe, lowercase, get_unit, & check_nml_error, stdlog, mpp_root_pe, fms_error_handler +use mpp_mod, only: input_nml_file +use fms2_io_mod, only: FmsNetcdfFile_t, Valid_t, file_exists, read_data, open_file, close_file, & + get_valid, is_valid, variable_exists, get_variable_size, & + get_unlimited_dimension_name, get_dimension_size, get_variable_attribute, & + get_variable_dimension_names, get_variable_num_dimensions +use axis_utils2_mod, only: axis_edges + + use time_manager_mod, only : time_type, set_date, get_date, set_time, & operator(+), operator(-), operator(>), operator(<), operator(<=), operator(/), & operator(//), operator(==), days_in_year, print_date, increment_date, get_time, & @@ -50,9 +49,6 @@ module land_transitions_mod use time_interp_mod, only : time_interp use diag_manager_mod, only : register_diag_field, send_data, diag_field_add_attribute -use nfu_mod, only : nfu_validtype, nfu_inq_var, nfu_get_dim_bounds, nfu_get_rec, & - nfu_get_dim, nfu_get_var, nfu_get_valid_range, nfu_is_valid - use vegn_data_mod, only : & N_LU_TYPES, LU_PAST, LU_CROP, LU_NTRL, LU_SCND, landuse_name, landuse_longname @@ -68,7 +64,6 @@ module land_transitions_mod empty, erase, remove, insert, land_tiles_can_be_merged, merge_land_tiles, & get_tile_water, land_tile_carbon, land_tile_heat use land_tile_diag_mod, only : cmor_name -use land_tile_io_mod, only : print_netcdf_error use land_data_mod, only : lnd, log_version, horiz_interp_ug use vegn_harvesting_mod, only : vegn_cut_forest @@ -108,16 +103,12 @@ module land_transitions_mod ! TODO: describe differences between data sets -! ==== NetCDF declarations =================================================== -include 'netcdf.inc' -#define __NF_ASRT__(x) call print_netcdf_error((x),module_name,__LINE__) - ! ==== data types =========================================================== ! set of variables that are summed up on input type :: var_set_type character(64) :: name = '' ! internal lm3 name of the field integer :: nvars = 0 ! number of variable ids - integer, allocatable :: id(:) ! ids of the input fields + character(len=nf90_max_name), dimension(:), allocatable :: names ! names of the input fields end type ! a description of single transition @@ -130,8 +121,8 @@ module land_transitions_mod ! ==== module data ========================================================== logical :: module_is_initialized = .FALSE. -integer :: tran_ncid = -1 ! netcdf id of the input file -integer :: state_ncid = -1 ! netcdf id of the input file, if any +type(FmsNetcdfFile_t) :: fileobj_tran ! netcdf input file +type(FmsNetcdfFile_t) :: fileobj_state ! netcdf input file integer :: nlon_in, nlat_in type(var_set_type) :: input_tran (N_LU_TYPES,N_LU_TYPES) ! input transition rate fields @@ -177,6 +168,7 @@ module land_transitions_mod ! translation table: model land use types -> LUMIP types: for each of the model ! LU types it lists the corresponding LUMIP type. integer, parameter :: lu2lumip(N_LU_TYPES) = [LUMIP_PST, LUMIP_CRP, LUMIP_PSL, LUMIP_PSL, LUMIP_URB] +logical :: close_state_file = .false. ! ---- namelist variables --------------------------------------------------- logical, protected, public :: do_landuse_change = .FALSE. ! if true, then the landuse changes with time @@ -210,20 +202,25 @@ subroutine land_transitions_init(id_ug, id_cellarea) integer, intent(in) :: id_cellarea !0) then - id = input_tran(k1,k2)%id(k3) + if (.not.allocated(input_tran(k1,k2)%names)) cycle + do k3 = 1,size(input_tran(k1,k2)%names(:)) + if (input_tran(k1,k2)%names(k3) .ne. "") then + name = input_tran(k1,k2)%names(k3) exit l1 ! from all loops endif enddo enddo enddo l1 - if (id<=0) call error_mesg('land_transitions_init',& + if (name .eq. "") call error_mesg('land_transitions_init',& 'could not find any land transition fields in the input file', FATAL) ! we assume that all transition rate fields are specified on the same grid, ! in both horizontal and time "directions". Therefore there is a single grid ! for all fields, initialized only once. - - __NF_ASRT__(nfu_inq_var(tran_ncid,id,dimids=dimids,dimlens=dimlens)) + ndims = get_variable_num_dimensions(fileobj_tran, name) + allocate(dimlens(ndims)) + call get_variable_size(fileobj_tran, name, dimlens) nlon_in = dimlens(1); nlat_in=dimlens(2) + deallocate(dimlens) ! allocate temporary variables allocate(buffer_in(nlon_in,nlat_in), & mask_in(nlon_in,nlat_in), & @@ -466,16 +456,19 @@ subroutine land_transitions_init(id_ug, id_cellarea) ! get the boundaries of the horizontal axes and initialize horizontal ! interpolator - __NF_ASRT__(nfu_get_dim_bounds(tran_ncid, dimids(1), lon_in(:,1))) - __NF_ASRT__(nfu_get_dim_bounds(tran_ncid, dimids(2), lat_in(1,:))) + allocate(dimnames(ndims)) + call get_variable_dimension_names(fileobj_tran, name, dimnames) + call axis_edges(fileobj_tran, dimnames(1), lon_in(:,1)) + call axis_edges(fileobj_tran, dimnames(2), lat_in(1,:)) + deallocate(dimnames) ! get the first record from variable and obtain the mask of valid data ! assume that valid mask does not change with time - __NF_ASRT__(nfu_get_rec(tran_ncid,id,1,buffer_in)) + call read_data(fileobj_tran, name, buffer_in, unlim_dim_level=1) ! get the valid range for the variable - __NF_ASRT__(nfu_get_valid_range(tran_ncid,id,v)) + v = get_valid(fileobj_tran, name) ! get the mask - where (nfu_is_valid(buffer_in,v)) + where (is_valid(buffer_in,v)) mask_in = 1 elsewhere mask_in = 0 @@ -492,18 +485,18 @@ subroutine land_transitions_init(id_ug, id_cellarea) ! LUH2 data are in [fraction of cell area per year] if (trim(static_file)=='') call error_mesg('land_transitions_init', & 'using LUH2 data set, but static data file is not specified', FATAL) - ierr=nf_open(static_file,NF_NOWRITE,ncid1) - if(ierr/=NF_NOERR) call error_mesg('land_transitions_init', & + exists = open_file(fileobj_static, static_file, "read") + if (.not. exists) call error_mesg('land_transitions_init', & 'using LUH2 data set, but static data file "'// & - trim(static_file)//'" could not be opened because '//nf_strerror(ierr), FATAL) - __NF_ASRT__(nfu_get_var(ncid1,'landfrac',buffer_in)) + trim(static_file)//'" could not be opened.', FATAL) + call read_data(fileobj_static, 'landfrac', buffer_in) where (buffer_in > 0.0) norm_in = 1.0/buffer_in elsewhere norm_in = 0.0 mask_in = 0 end where - ierr = nf_close(ncid1) + call close_file(fileobj_static) case default call error_mesg('land_transitions_init','unknown data_type "'& //trim(data_type)//'", use "luh1" or "luh2"', FATAL) @@ -521,29 +514,23 @@ subroutine land_transitions_init(id_ug, id_cellarea) end subroutine land_transitions_init ! ============================================================================ -subroutine get_time_axis(ncid, time_in) - integer, intent(in) :: ncid +subroutine get_time_axis(fileobj, time_in) + type(FmsNetcdfFile_t), intent(in) :: fileobj type(time_type), allocatable :: time_in(:) - integer :: timedim ! id of the record (time) dimension - integer :: timevar ! id of the time variable - character(len=NF_MAX_NAME) :: timename ! name of the time variable - character(len=256) :: timeunits ! units ot time in the file + character(len=nf90_max_name) :: timename ! name of the time variable + character(len=256) :: timeunits ! units ot time in the file character(len=24) :: calendar ! model calendar real, allocatable :: time(:) ! real values of time coordinate integer :: i, nrec ! get the time axis - __NF_ASRT__(nf_inq_unlimdim(ncid, timedim)) - __NF_ASRT__(nf_inq_dimlen(ncid, timedim, nrec)) + call get_unlimited_dimension_name(fileobj, timename) + call get_dimension_size(fileobj, timename, nrec) allocate(time(nrec), time_in(nrec)) - __NF_ASRT__(nfu_get_dim(ncid, timedim, time)) - ! get units of time - __NF_ASRT__(nf_inq_dimname(ncid, timedim, timename)) - __NF_ASRT__(nf_inq_varid(ncid, timename, timevar)) + call read_data(fileobj, timename, time) timeunits = ' ' - __NF_ASRT__(nf_get_att_text(ncid,timevar,'units',timeunits)) - ! get model calendar + call get_variable_attribute(fileobj, timename, "units", timeunits) calendar=valid_calendar_types(get_calendar_type()) ! loop through the time axis and get time_type values in time_in @@ -565,56 +552,49 @@ subroutine land_transitions_end() module_is_initialized=.FALSE. if (do_landuse_change) call horiz_interp_del(interp) if(allocated(time_in)) deallocate(time_in) + call close_file(fileobj_tran) + if (close_state_file) then + call close_file(fileobj_state) + endif end subroutine land_transitions_end ! ============================================================================ -subroutine add_var_to_varset(varset,ncid,filename,varname) +subroutine add_var_to_varset(varset, fileobj, filename, varname) type(var_set_type), intent(inout) :: varset - integer , intent(in) :: ncid ! id of netcdf file + type(FmsNetcdfFile_t), intent(in) :: fileobj ! handle of netcdf file character(*), intent(in) :: filename ! name of the file (for reporting problems only) character(*), intent(in) :: varname ! name of the variable - integer, allocatable :: id(:) - integer :: varid, ierr + character(len=nf90_max_name), allocatable, dimension(:) :: names - if (.not.allocated(varset%id)) then - allocate(varset%id(10)) - varset%id(:) = -1 + if (.not.allocated(varset%names)) then + allocate(varset%names(10)) + varset%names(:) = "" endif - if (varset%nvars >= size(varset%id)) then + if (varset%nvars >= size(varset%names)) then ! make space for new variables - allocate(id(size(varset%id)+10)) - id(:) = -1 - id(1:varset%nvars) = varset%id(1:varset%nvars) - call move_alloc(id,varset%id) + allocate(names(size(varset%names)+10)) + names(:) = "" + names(1:varset%nvars) = varset%names(1:varset%nvars) + call move_alloc(names,varset%names) endif - ierr = nfu_inq_var(ncid, trim(varname), id=varid) - select case(ierr) - case (NF_NOERR) + if (variable_exists(fileobj, varname)) then call error_mesg('land_transitions_init',& 'adding field "'//trim(varname)//'" from file "'//trim(filename)//'"'//& ' to transition "'//trim(varset%name)//'"',& NOTE) varset%nvars = varset%nvars+1 - varset%id(varset%nvars) = varid - case (NF_ENOTVAR) -! call error_mesg('land_transitions_init',& -! 'field "'//trim(varname)//'" not found in file "'//trim(filename)//'"',& -! NOTE) - case default - call error_mesg('land_transitions_init',& - 'error initializing field "'//varname//& - '" from file "'//trim(filename)//'" : '//nf_strerror(ierr), FATAL) - end select + varset%names(varset%nvars) = varname + endif end subroutine add_var_to_varset ! ============================================================================ ! read, aggregate, and interpolate set of transitions -subroutine get_varset_data(ncid,varset,rec,frac) - integer, intent(in) :: ncid +subroutine get_varset_data(fileobj, varset, rec, frac) + type(FmsNetcdfFile_t), intent(in) :: fileobj type(var_set_type), intent(in) :: varset integer, intent(in) :: rec real, intent(out) :: frac(:) @@ -626,8 +606,8 @@ subroutine get_varset_data(ncid,varset,rec,frac) frac = 0.0 buff1 = 0.0 do i = 1,varset%nvars - if (varset%id(i)>0) then - __NF_ASRT__(nfu_get_rec(ncid,varset%id(i),rec,buff0)) + if (varset%names(i) .ne. "") then + call read_data(fileobj, varset%names(i), buff0, unlim_dim_level=rec) buff1 = buff1 + buff0 endif enddo @@ -636,12 +616,10 @@ end subroutine get_varset_data ! ============================================================================ ! returns a string representing the parts of the transition -function varset_descr(ncid,varset) result(str) +function varset_descr(varset) result(str) character(:), allocatable :: str - integer, intent(in) :: ncid type(var_set_type), intent(in) :: varset - character(NF_MAX_NAME) :: varname integer :: i str = trim(varset%name)//' = ' @@ -649,11 +627,10 @@ function varset_descr(ncid,varset) result(str) str = str//'0' else do i = 1, varset%nvars - __NF_ASRT__(nf_inq_varname(ncid,varset%id(i),varname)) if (i==1) then - str = str//trim(varname) + str = str//trim(varset%names(i)) else - str = str//' + '//trim(varname) + str = str//' + '//trim(varset%names(i)) endif enddo endif @@ -665,13 +642,14 @@ subroutine save_land_transitions_restart(timestamp) integer :: unit,year,month,day,hour,min,sec - call mpp_open( unit, 'RESTART/'//trim(timestamp)//'landuse.res', nohdrs=.TRUE. ) if (mpp_pe() == mpp_root_pe()) then + unit = get_unit() + open(unit=unit, file='RESTART/'//trim(timestamp)//'landuse.res', action="write") call get_date(time0, year,month,day,hour,min,sec) write(unit,'(6i6,8x,a)') year,month,day,hour,min,sec, & 'Time of previous landuse transition calculation' + close(unit) endif - call mpp_close(unit) end subroutine save_land_transitions_restart @@ -712,12 +690,12 @@ subroutine land_transitions (time) do k2 = 1,N_LU_TYPES ! get transition rate for this specific transition frac(:) = 0.0 - if (time0==set_date(0001,01,01).and.state_ncid>0) then + if (time0==set_date(0001,01,01) .and. file_exists(fileobj_state%path)) then ! read initial transition from state file call time_interp(time, state_time_in, w, i1,i2) - call get_varset_data(state_ncid,input_state(k1,k2),i1,frac) + call get_varset_data(fileobj_state, input_state(k1,k2), i1, frac) else - if (any(input_tran(k1,k2)%id(:)>0)) then + if (any(input_tran(k1,k2)%names(:) .ne. "")) then call integral_transition(time0,time,input_tran(k1,k2),frac) endif endif @@ -1352,12 +1330,12 @@ subroutine integral_transition(t1, t2, tran, frac, err_msg) if(msg /= '') then if(fms_error_handler('integral_transition','Message from time_interp: '//trim(msg),err_msg)) return endif - call get_varset_data(tran_ncid,tran,i1,frac) + call get_varset_data(fileobj_tran, tran, i1, frac) dt = (time_in(i2)-time_in(i1))//set_time(0,days_in_year((time_in(i2)+time_in(i1))/2)) sum = -frac*w*dt do while(time_in(i2)<=te) - call get_varset_data(tran_ncid,tran,i1,frac) + call get_varset_data(fileobj_tran, tran, i1, frac) dt = (time_in(i2)-time_in(i1))//set_time(0,days_in_year((time_in(i2)+time_in(i1))/2)) sum = sum+frac*dt i2 = i2+1 @@ -1369,7 +1347,7 @@ subroutine integral_transition(t1, t2, tran, frac, err_msg) if(msg /= '') then if(fms_error_handler('integral_transition','Message from time_interp: '//trim(msg),err_msg)) return endif - call get_varset_data(tran_ncid,tran,i1,frac) + call get_varset_data(fileobj_tran, tran, i1, frac) dt = (time_in(i2)-time_in(i1))//set_time(0,days_in_year((time_in(i2)+time_in(i1))/2)) frac = sum+frac*w*dt ! check the transition rate validity diff --git a/vegetation/read_remap_cohort_data.inc b/vegetation/read_remap_cohort_data.inc deleted file mode 100644 index ab76aeee..00000000 --- a/vegetation/read_remap_cohort_data.inc +++ /dev/null @@ -1,128 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Flexible Modeling System (FMS). -!* -!* FMS 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 (at -!* your option) any later version. -!* -!* FMS is distributed in the hope that it will be useful, but WITHOUT -!* ANY WARRANTY; 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 FMS. If not, see . -!*********************************************************************** -! -*-f90-*- -! $Id$ - -! some sanity checks -#ifndef F90_TYPE -#error F90_TYPE is not defined: must be one of FORTRAN 90 types -#endif - -#ifndef READ_REMAP_SUB -#error name of READ_REMAP_SUB is not defined -#endif - -! ============================================================================ -subroutine READ_REMAP_SUB(ncid,name,fptr,map_i,map_j,rec) - integer , intent(in) :: ncid ! netcdf id - character(len=*) , intent(in) :: name ! name of the variable to read - integer , intent(in) :: map_i(lnd%ls:) ! re-mapping index - integer , intent(in) :: map_j(lnd%ls:) ! re-mapping index - integer, optional , intent(in) :: rec ! record number (in case there are - ! several in the file) - ! subroutine returning the pointer to the data to be written - interface - subroutine fptr(cohort, ptr) - use vegn_cohort_mod, only : vegn_cohort_type - type(vegn_cohort_type), pointer :: cohort ! input - F90_TYPE , pointer :: ptr ! returned pointer to the data - end subroutine fptr - end interface - - ! ---- local constants - character(*), parameter :: module_name = "read_remap_cohort_data" - - ! ---- local vars - integer :: i,j,k,n,ii,jj,ndims, iret, l - integer :: rec_ ! record number - type(land_tile_enum_type) :: ce, te - type(land_tile_type) , pointer :: tile - type(vegn_cohort_type) , pointer :: cohort - F90_TYPE, pointer :: ptr ! pointer to the individual cohort data - F90_TYPE, allocatable :: data(:,:,:,:) ! buffer for input data - logical, allocatable :: mask(:,:,:,:) ! validity mask for input data - logical :: has_records, is_compressed - integer :: dimlens(NF_MAX_VAR_DIMS) - type(nfu_validtype) :: v - - ! assign the internal record number - if(present(rec)) then - rec_ = rec - else - rec_ = 1 - endif - - ! get the size of dimensions - iret=nfu_inq_compressed_var(ncid, name, ndims=ndims, dimlens=dimlens,& - has_records=has_records, is_compressed=is_compressed) - __NF_ASRT__(iret) - - ! calculate the dimensions of input buffers, based on the dimensions of - ! input variable - if(has_records)ndims = ndims-1 - do i = ndims+1,4 - dimlens(i) = 1 - enddo - - ! allocate input buffers - allocate(data(dimlens(1),dimlens(2),dimlens(3),dimlens(4))) - allocate(mask(dimlens(1),dimlens(2),dimlens(3),dimlens(4))) - ! lon lat tile cohort - - mask = .FALSE. - __NF_ASRT__(nfu_get_compressed_rec(ncid,name,rec_,data,mask)) - if (.not.is_compressed) then - __NF_ASRT__( nfu_get_valid_range(ncid,name,v) ) - mask=nfu_is_valid(data,v) - endif - - ! distribute data over cohorts. NOTE that this is slightly different from the restart - ! reading procedure. On reading the restart, all the tiles are counted in sequence, - ! while here only tne vegetation tiles. - do l = lnd%ls, lnd%le - ii = map_i(l); jj = map_j(l) - if ((ii.le.0).or.(jj.le.0)) cycle ! skip un-mapped points - if (.not.any(mask(ii,jj,:,:))) cycle ! skip points where there is no data - - ce = first_elmt (land_tile_map(l)) - te = tail_elmt (land_tile_map(l)) - k = 1 -tile_loop: do while(ce/=te.and.k<=dimlens(3)) - tile=>current_tile(ce); ce=next_elmt(ce); - if (.not.associated(tile%vegn)) cycle - ! find index of the next valid tile in the input data - do while(.not.any(mask(ii,jj,k,:))) - k=k+1 ! go to the next tile if there's no data (i.e. all mask - ! values are false for this tile) - if(k>dimlens(3)) exit tile_loop - enddo - - do n = 1,min(size(tile%vegn%cohorts(:)),dimlens(4)) - cohort=>tile%vegn%cohorts(n) - call fptr(cohort,ptr) - if(associated(ptr).and.mask(ii,jj,k,n)) ptr = data(ii,jj,k,n) - enddo - k = k+1 ! go to the next tile in input data - enddo tile_loop - enddo - - ! free allocated memory - deallocate(data,mask) - -end subroutine diff --git a/vegetation/read_remap_cohort_data_new.inc b/vegetation/read_remap_cohort_data_new.inc index f6750600..4cab67ff 100644 --- a/vegetation/read_remap_cohort_data_new.inc +++ b/vegetation/read_remap_cohort_data_new.inc @@ -29,8 +29,9 @@ #endif ! ============================================================================ -subroutine READ_REMAP_SUB(Field, fptr, map_i, map_j, cidx, compressed_data) - type(fieldtype), intent(in) :: Field +subroutine READ_REMAP_SUB(fileobj, name, fptr, map_i, map_j, cidx, compressed_data) + class(FmsNetcdfFile_t), intent(in) :: fileobj + character(len=*), intent(in) :: name integer , intent(in) :: map_i(lnd%ls:) ! re-mapping index integer , intent(in) :: map_j(lnd%ls:) ! re-mapping index integer , intent(in) :: cidx(:) @@ -57,30 +58,24 @@ subroutine READ_REMAP_SUB(Field, fptr, map_i, map_j, cidx, compressed_data) F90_TYPE, allocatable :: expanded_data(:,:,:,:) ! buffer for input data logical, allocatable :: mask(:,:,:,:) ! validity mask for input data logical :: is_compressed - integer :: dimlens(1024) - type(axistype), allocatable :: Axes(:) - character(len=256) :: att_name, dim_name - type(axistype) :: Axis - character(len=256) :: default_string, compress_att, string + integer, dimension(4) :: dimlens + character(len=256) :: dim_name + character(len=256) :: compress_att, string ! get the size of dimensions - call mpp_get_atts(Field, ndim=ndims) - allocate(Axes(ndims)) - call mpp_get_atts(Field, axes=Axes) - call mpp_get_atts(default_axis, compressed=default_string) - is_compressed = .FALSE. - do n=1,ndims - call mpp_get_atts(Axes(n), name=att_name) - if(trim(att_name) == 'cohort_index') then - call mpp_get_atts(Axes(n), compressed=compress_att) - if(compress_att /= default_string) is_compressed = .TRUE. + is_compressed = .false. + if (variable_exists(fileobj, "cohort_index")) then + if (variable_att_exists(fileobj, "cohort_index", "compress")) then + call get_variable_attribute(fileobj, "cohort_index", "compress", compress_att) + if (trim(compress_att) .ne. "unspecified") then + is_compressed = .true. + endif endif - enddo + endif if(.not.is_compressed) then - call mpp_get_atts(Field, name=string) call error_mesg(module_name, & - 'compress attribute not found for cohort_index. Therefore, do not know how to decompress '//trim(string)//' (pjp)',FATAL) + 'compress attribute not found for cohort_index. Therefore, do not know how to decompress '//trim(name)//' (pjp)',FATAL) endif ! Get size of each dimension specified by compress_att @@ -88,8 +83,7 @@ subroutine READ_REMAP_SUB(Field, fptr, map_i, map_j, cidx, compressed_data) do n=1,4 npos = scan(string, ' ') dim_name = string(1:npos-1) - Axis = mpp_get_axis_by_name(input_unit,trim(dim_name)) - call mpp_get_atts(Axis, len=dimlens(n)) + call get_dimension_size(fileobj, dim_name, dimlens(n)) string = string(npos+1:len_trim(string)) npos = verify(string, ' ') if(npos == 0) exit diff --git a/vegetation/vegetation.F90 b/vegetation/vegetation.F90 index d0d29299..e2f857d3 100644 --- a/vegetation/vegetation.F90 +++ b/vegetation/vegetation.F90 @@ -26,7 +26,7 @@ module vegetation_mod use fms_mod, only: open_namelist_file #endif -use fms_mod, only: error_mesg, NOTE,FATAL, file_exist, close_file, & +use fms_mod, only: error_mesg, NOTE,FATAL, & check_nml_error, stdlog use mpp_mod, only: mpp_sum, mpp_max, mpp_pe, mpp_root_pe, mpp_sync, stdout use time_manager_mod, only: time_type, time_type_to_real, get_date, operator(-) @@ -83,7 +83,7 @@ module vegetation_mod soil_carbon_option, SOILC_CENTURY, SOILC_CENTURY_BY_LAYER, SOILC_CORPSE use soil_mod, only : add_root_litter, redistribute_peat_carbon -use fms_io_mod, only: fms_io_unstructured_read +use fms2_io_mod, only: close_file, FmsNetcdfFile_t, open_file, read_data implicit none private @@ -207,21 +207,8 @@ subroutine read_vegn_namelist() call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml=vegn_nml, iostat=io) - ierr = check_nml_error(io, 'vegn_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=vegn_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'vegn_nml') - enddo -10 continue - call close_file (unit) - endif -#endif + read (input_nml_file, nml=vegn_nml, iostat=io) + ierr = check_nml_error(io, 'vegn_nml') unit=stdlog() @@ -268,6 +255,8 @@ subroutine vegn_init(id_ug,id_band) real, allocatable :: t_ann(:),t_cold(:),p_ann(:),ncm(:) ! buffers for biodata reading logical :: did_read_biodata integer :: i,j,l ! indices of current tile + logical :: exists + type(FmsNetcdfFile_t) :: fileobj module_is_initialized = .TRUE. @@ -279,8 +268,8 @@ subroutine vegn_init(id_ug,id_band) ! ---- initialize vegn state --------------------------------------------- n_accum = 0 nmn_acm = 0 - call open_land_restart(restart1,'INPUT/vegn1.res.nc',restart_1_exists) - call open_land_restart(restart2,'INPUT/vegn2.res.nc',restart_2_exists) + call open_land_restart(restart1,'INPUT/vegn1.nc',restart_1_exists) + call open_land_restart(restart2,'INPUT/vegn2.nc',restart_2_exists) if (restart_1_exists) then call error_mesg('vegn_init',& 'reading NetCDF restarts "INPUT/vegn1.res.nc" and "INPUT/vegn2.res.nc"',& @@ -303,14 +292,8 @@ subroutine vegn_init(id_ug,id_band) ! read global variables - call fms_io_unstructured_read(restart2%basename, & - "n_accum", & - n_accum, & - lnd%ug_domain) - call fms_io_unstructured_read(restart2%basename, & - "nmn_acm", & - nmn_acm, & - lnd%ug_domain) + call read_data(restart2%rhandle, "n_accum", n_accum) + call read_data(restart2%rhandle, "nmn_acm", nmn_acm) call get_int_cohort_data(restart2, 'species', cohort_species_ptr) call get_cohort_data(restart2, 'hite', cohort_height_ptr) @@ -393,22 +376,25 @@ subroutine vegn_init(id_ug,id_band) call free_land_restart(restart2) ! read climatological fields for initialization of species distribution - if (file_exist('INPUT/biodata.nc'))then + exists = open_file(fileobj, "INPUT/biodata.nc", mode="read") + if (exists) then allocate(& t_ann (lnd%ls:lnd%le),& t_cold(lnd%ls:lnd%le),& p_ann (lnd%ls:lnd%le),& ncm (lnd%ls:lnd%le) ) - call read_field( 'INPUT/biodata.nc','T_ANN', t_ann, interp='nearest') - call read_field( 'INPUT/biodata.nc','T_COLD', t_cold, interp='nearest') - call read_field( 'INPUT/biodata.nc','P_ANN', p_ann, interp='nearest') - call read_field( 'INPUT/biodata.nc','NCM', ncm, interp='nearest') + call read_field(fileobj, 'T_ANN', t_ann, interp='nearest') + call read_field(fileobj, 'T_COLD', t_cold, interp='nearest') + call read_field(fileobj, 'P_ANN', p_ann, interp='nearest') + call read_field(fileobj, 'NCM', ncm, interp='nearest') did_read_biodata = .TRUE. call error_mesg('vegn_init','did read INPUT/biodata.nc',NOTE) + call close_file(fileobj) else did_read_biodata = .FALSE. call error_mesg('vegn_init','did NOT read INPUT/biodata.nc',NOTE) endif + ! Go through all tiles and initialize the cohorts that have not been initialized yet -- ! this allows to read partial restarts. Also initialize accumulation counters to zero ! or the values from the restarts. @@ -799,7 +785,7 @@ subroutine save_vegn_restart(tile_dim_length,timestamp) call error_mesg('vegn_end','writing NetCDF restart',NOTE) ! create output file, including internal structure necessary for tile output - filename = trim(timestamp)//'vegn1.res.nc' + filename = 'RESTART/'//trim(timestamp)//'vegn1.nc' call init_land_restart(restart1, filename, vegn_tile_exists, tile_dim_length) ! create compressed dimension for vegetation cohorts -- must be called even @@ -814,7 +800,7 @@ subroutine save_vegn_restart(tile_dim_length,timestamp) call free_land_restart(restart1) - filename = trim(timestamp)//'vegn2.res.nc' + filename = 'RESTART/'//trim(timestamp)//'vegn2.nc' call init_land_restart(restart2, filename, vegn_tile_exists, tile_dim_length) ! create compressed dimension for vegetation cohorts -- see note above call create_cohort_dimension(restart2) @@ -832,10 +818,10 @@ subroutine save_vegn_restart(tile_dim_length,timestamp) ! n_accum and nmn_acm are currently the same for all tiles; we only call mpp_max ! to handle the situation when there are no tiles in the current domain call mpp_max(n_accum); call mpp_max(nmn_acm) - call add_scalar_data(restart2,'n_accum',n_accum,'number of accumulated steps') + call add_scalar_data(restart2,'n_accum',n_accum,'number of accumulated steps', 'none') - call add_scalar_data(restart2,'nmn_acm',nmn_acm,'number of accumulated months') - call add_int_cohort_data(restart2,'species', cohort_species_ptr, 'vegetation species') + call add_scalar_data(restart2,'nmn_acm',nmn_acm,'number of accumulated months', 'none') + call add_int_cohort_data(restart2,'species', cohort_species_ptr, 'vegetation species', 'none') call add_cohort_data(restart2,'hite', cohort_height_ptr, 'vegetation height','m') call add_cohort_data(restart2,'bl', cohort_bl_ptr, 'biomass of leaves per individual','kg C/m2') call add_cohort_data(restart2,'blv', cohort_blv_ptr, 'biomass of virtual leaves (labile store) per individual','kg C/m2') @@ -843,7 +829,7 @@ subroutine save_vegn_restart(tile_dim_length,timestamp) call add_cohort_data(restart2,'bsw', cohort_bsw_ptr, 'biomass of sapwood per individual','kg C/m2') call add_cohort_data(restart2,'bwood', cohort_bwood_ptr, 'biomass of heartwood per individual','kg C/m2') call add_cohort_data(restart2,'bliving', cohort_bliving_ptr, 'total living biomass per individual','kg C/m2') - call add_int_cohort_data(restart2,'status', cohort_status_ptr, 'leaf status') + call add_int_cohort_data(restart2,'status', cohort_status_ptr, 'leaf status', 'none') call add_cohort_data(restart2,'leaf_age',cohort_leaf_age_ptr, 'age of leaves since bud burst', 'days') !#### MODIFIED BY PPG 2016-12-01 @@ -853,7 +839,7 @@ subroutine save_vegn_restart(tile_dim_length,timestamp) call add_cohort_data(restart2,'npp_prev_day', cohort_npp_previous_day_ptr, 'previous day NPP','kg C/(m2 year)') - call add_int_tile_data(restart2,'landuse',vegn_landuse_ptr,'vegetation land use type') + call add_int_tile_data(restart2,'landuse',vegn_landuse_ptr,'vegetation land use type', 'none') call add_tile_data(restart2,'age',vegn_age_ptr,'vegetation age', 'yr') call add_tile_data(restart2,'fsc_pool_ag',vegn_fsc_pool_ag_ptr, & 'intermediate pool for AG fast soil carbon input', 'kg C/m2') @@ -883,23 +869,23 @@ subroutine save_vegn_restart(tile_dim_length,timestamp) ! monthly-mean values call add_tile_data(restart2,'tc_av', vegn_tc_av_ptr,'average canopy air temperature','degK') - call add_tile_data(restart2,'theta_av_phen', vegn_theta_av_phen_ptr,'average soil moisture for phenology') - call add_tile_data(restart2,'theta_av_fire', vegn_theta_av_fire_ptr,'average soil moisture for fire') - call add_tile_data(restart2,'psist_av', vegn_psist_av_ptr,'average soil-water-stress index') + call add_tile_data(restart2,'theta_av_phen', vegn_theta_av_phen_ptr,'average soil moisture for phenology', 'none') + call add_tile_data(restart2,'theta_av_fire', vegn_theta_av_fire_ptr,'average soil moisture for fire', 'none') + call add_tile_data(restart2,'psist_av', vegn_psist_av_ptr,'average soil-water-stress index', 'none') call add_tile_data(restart2,'tsoil_av', vegn_tsoil_av_ptr,'average bulk soil temperature for soil carbon','degK') call add_tile_data(restart2,'precip_av', vegn_precip_av_ptr,'average total precipitation','kg/(m2 s)') - call add_tile_data(restart2,'lambda', vegn_lambda_ptr,'dryness parameter') + call add_tile_data(restart2,'lambda', vegn_lambda_ptr,'dryness parameter', 'none') call add_tile_data(restart2,'fuel', vegn_fuel_ptr,'fuel density','kg C/m2') ! annual-mean values call add_tile_data(restart2,'t_ann', vegn_t_ann_ptr,'average annual canopy air temperature','degK') call add_tile_data(restart2,'t_cold', vegn_t_cold_ptr,'average canopy air temperature of coldest month','degK') call add_tile_data(restart2,'p_ann', vegn_p_ann_ptr,'average annual precipitation','kg/(m2 s)') - call add_tile_data(restart2,'ncm', vegn_ncm_ptr,'number of cold months') + call add_tile_data(restart2,'ncm', vegn_ncm_ptr,'number of cold months', 'none') ! accumulated values for annual averaging call add_tile_data(restart2,'t_ann_acm', vegn_t_ann_acm_ptr,'accumulated annual canopy air temperature','degK') call add_tile_data(restart2,'t_cold_acm', vegn_t_cold_acm_ptr,'accumulated temperature of coldest month','degK') call add_tile_data(restart2,'p_ann_acm', vegn_p_ann_acm_ptr,'accumulated precipitation','kg/(m2 s)') - call add_tile_data(restart2,'ncm_acm', vegn_ncm_acm_ptr,'accumulated number of cold months') + call add_tile_data(restart2,'ncm_acm', vegn_ncm_acm_ptr,'accumulated number of cold months', 'none') ! burned carbon pool and rate call add_tile_data(restart2,'csmoke_pool',vegn_csmoke_pool_ptr,'carbon lost through fires', 'kg C/m2') diff --git a/vegetation/vegn_cohort_io.F90 b/vegetation/vegn_cohort_io.F90 index e44083ea..e3962906 100644 --- a/vegetation/vegn_cohort_io.F90 +++ b/vegetation/vegn_cohort_io.F90 @@ -18,15 +18,11 @@ !*********************************************************************** module cohort_io_mod -use fms_mod, only : error_mesg, FATAL, WARNING, get_mosaic_tile_file -use fms_io_mod, only : restart_file_type, get_instance_filename -use mpp_mod, only : mpp_pe, mpp_max, mpp_send, mpp_recv, mpp_sync, & - COMM_TAG_1, COMM_TAG_2, COMM_TAG_3, COMM_TAG_4, & - mpp_sync_self, stdout -use nf_utils_mod, only : nfu_inq_dim, nfu_get_var, nfu_put_var, & - nfu_get_rec, nfu_put_rec, nfu_def_dim, nfu_def_var, nfu_put_att, & - nfu_inq_var -use land_io_mod, only : print_netcdf_error, input_buf_size, new_land_io +use netcdf, only: NF90_FILL_DOUBLE, NF90_FILL_INT + +use fms_mod, only : error_mesg, FATAL, WARNING +use mpp_mod, only : mpp_max +use land_io_mod, only : input_buf_size use land_tile_mod, only : land_tile_map, land_tile_type, land_tile_list_type, & land_tile_enum_type, first_elmt, tail_elmt, next_elmt, & current_tile, operator(/=), nitems, loop_over_tiles @@ -39,10 +35,12 @@ module cohort_io_mod use vegn_cohort_mod, only: vegn_cohort_type use land_data_mod, only : lnd -use fms_io_mod, only: fms_io_unstructured_register_restart_axis -use fms_io_mod, only: fms_io_unstructured_register_restart_field -use fms_io_mod, only: HIDX -use fms_io_mod, only: fms_io_unstructured_read + +use fms2_io_mod, only: compressed_start_and_count, FmsNetcdfUnstructuredDomainFile_t, & + register_axis, register_field, register_variable_attribute, & + read_data, write_data, get_instance_filename +use mpp_mod, only : mpp_chksum +use land_chksum_mod implicit none private @@ -53,9 +51,8 @@ module cohort_io_mod public :: add_cohort_data, add_int_cohort_data public :: get_cohort_data, get_int_cohort_data ! remove when cleaning up: -public :: write_cohort_data_r0d, write_cohort_data_i0d public :: gather_cohort_index, gather_cohort_data -public :: create_cohort_dimension_new, create_cohort_dimension_orig +public :: create_cohort_dimension_new ! ==== end of public interfaces ============================================== interface gather_cohort_data @@ -86,9 +83,6 @@ subroutine cptr_i0(tile, ptr) integer , pointer :: ptr ! returned pointer to the data end subroutine cptr_i0 end interface -! ==== NetCDF declarations =================================================== -include 'netcdf.inc' -#define __NF_ASRT__(x) call print_netcdf_error((x),module_name,__LINE__) contains ! -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- @@ -122,89 +116,11 @@ end subroutine get_cohort_by_idx subroutine read_create_cohorts(restart) type(land_restart_type), intent(inout) :: restart - if (new_land_io) then - if (.not.allocated(restart%cidx)) call error_mesg('read_create_cohorts', & - 'cohort index not found in file "'//restart%filename//'"',FATAL) - call read_create_cohorts_new(restart%cidx,restart%tile_dim_length) - else - call read_create_cohorts_orig(restart%ncid,restart%filename) - endif + if (.not.allocated(restart%cidx)) call error_mesg('read_create_cohorts', & + 'cohort index not found in file "'//restart%filename//'"',FATAL) + call read_create_cohorts_new(restart%cidx,restart%tile_dim_length) end subroutine -! ============================================================================ -subroutine read_create_cohorts_orig(ncid, filename) - integer, intent(in) :: ncid - character(*), intent(in) :: filename - - integer :: ncohorts ! total number of cohorts in restart file - integer :: nlon, nlat, ntiles ! size of respective dimensions - - integer, allocatable :: idx(:) - integer :: i,j,t,k,m, n, nn, idxid, ierr - integer :: bufsize, npts,g,l - type(land_tile_enum_type) :: ce, te - type(land_tile_type), pointer :: tile - character(len=64) :: info ! for error message - - ! get the size of dimensions - nlon = lnd%nlon ; nlat = lnd%nlat - ierr = nfu_inq_dim(ncid,'tile',len=ntiles) - if (ierr/=NF_NOERR) call error_mesg('read_create_cohorts_orig', & - 'dimension "tile" not found in file "'//trim(filename)//'"', FATAL) - - ! read the cohort index - ierr = nfu_inq_dim(ncid,cohort_index_name,len=ncohorts) - if (ierr/=NF_NOERR) call error_mesg('read_create_cohorts_orig', & - 'dimension "'//trim(cohort_index_name)//'" not found in file "'//trim(filename)//'"', FATAL) - ierr = nfu_inq_var(ncid,cohort_index_name,id=idxid) - if (ierr/=NF_NOERR) call error_mesg('read_create_cohorts_orig', & - 'variable "'//trim(cohort_index_name)//'" not found in file "'//trim(filename)//'"', FATAL) - bufsize = min(input_buf_size,ncohorts) - allocate(idx(bufsize)) - - npts = nlon*nlat - do nn = 1, ncohorts, bufsize - __NF_ASRT__(nf_get_vara_int(ncid,idxid,nn,min(bufsize,ncohorts-nn+1),idx)) - - do n = 1,min(bufsize,ncohorts-nn+1) - k = idx(n) - g = modulo(k,npts)+1 - if(glnd%ge) cycle ! skip points outside of domain - l = lnd%l_index(g) - k = k/npts - t = modulo(k,ntiles)+1 ; k = k/ntiles - k = k+1 - ce = first_elmt(land_tile_map(l)) - do m = 1,t-1 - ce=next_elmt(ce) - enddo - tile=>current_tile(ce) - if(.not.associated(tile%vegn)) then - i = lnd%i_index(i) - j = lnd%j_index(j) - info = '' - write(info,'("(",3i3,")")')i,j,t - call error_mesg('read_create_cohort',& - 'vegn tile'//trim(info)//' does not exist, but is necessary to create a cohort', & - WARNING) - else - tile%vegn%n_cohorts = tile%vegn%n_cohorts + 1 - endif - enddo - enddo - - ! go through all tiles in the domain and allocate requested numner of cohorts - ce = first_elmt(land_tile_map); te = tail_elmt(land_tile_map) - do while (ce/=te) - tile=>current_tile(ce); ce = next_elmt(ce) - if(.not.associated(tile%vegn))cycle - allocate(tile%vegn%cohorts(tile%vegn%n_cohorts)) - enddo - - ! clean up memory - deallocate(idx) -end subroutine read_create_cohorts_orig - ! ============================================================================ subroutine read_create_cohorts_new(idx,ntiles) integer, intent(in) :: idx(:) @@ -271,11 +187,7 @@ end subroutine read_create_cohorts_new subroutine create_cohort_dimension(restart) type(land_restart_type), intent(inout) :: restart - if (new_land_io) then - call create_cohort_dimension_new(restart%rhandle,restart%cidx,restart%basename,restart%tile_dim_length) - else - call create_cohort_dimension_orig(restart%ncid,restart%cidx,restart%tile_dim_length) - endif + call create_cohort_dimension_new(restart%rhandle,restart%cidx,restart%basename,restart%tile_dim_length) end subroutine create_cohort_dimension ! ============================================================================ @@ -284,58 +196,8 @@ end subroutine create_cohort_dimension ! (because, for example, there happen to be no vegetation in a certain domain), ! for the reason that it calls mpp_max, and that should be called for each ! processor to work. -subroutine create_cohort_dimension_orig(ncid,cidx,tile_dim_length) - integer, intent(in) :: ncid - integer, allocatable, intent(out) :: cidx(:) - integer, intent(in) :: tile_dim_length - - ! ---- local vars - integer :: i,k,max_cohorts,p - integer :: iret - integer, allocatable :: ncohorts(:) ! array of idx sizes from all PEs in io_domain - integer, allocatable :: idx2(:) ! array of cohort indices from all PEs in io_domain - - call gather_cohort_index(tile_dim_length,cidx) - max_cohorts = global_max_cohorts() - - if (mpp_pe()/=lnd%io_pelist(1)) then - ! if this processor is not doing io (that is, it's not root io_domain - ! processor), simply send the data to the root io_domain PE - call mpp_send(size(cidx), plen=1, to_pe=lnd%io_pelist(1), tag=COMM_TAG_1) - call mpp_send(cidx(1), plen=size(cidx), to_pe=lnd%io_pelist(1), tag=COMM_TAG_2) - else - ! gather the array of cohort index sizes - allocate(ncohorts(size(lnd%io_pelist))) - ncohorts(1) = size(cidx) - do p = 2,size(lnd%io_pelist) - call mpp_recv(ncohorts(p), from_pe=lnd%io_pelist(p), glen=1, tag=COMM_TAG_1) - enddo - ! gather cohort index from the processors in our io_domain - allocate(idx2(sum(ncohorts(:)))) - idx2(1:ncohorts(1))=cidx(:) - k=ncohorts(1)+1 - do p = 2,size(lnd%io_pelist) - call mpp_recv(idx2(k), from_pe=lnd%io_pelist(p), glen=ncohorts(p), tag=COMM_TAG_2) - k = k+ncohorts(p) - enddo - ! create cohort dimension in the output file - iret = nf_redef(ncid) - __NF_ASRT__(nfu_def_dim(ncid,'cohort',(/(i,i=1,max_cohorts)/),'cohort number within tile')) - ! create cohort index - __NF_ASRT__(nfu_def_dim(ncid,cohort_index_name,idx2,'compressed vegetation cohort index')) - __NF_ASRT__(nfu_put_att(ncid,cohort_index_name,'compress','cohort tile lat lon')) - __NF_ASRT__(nfu_put_att(ncid,cohort_index_name,'valid_min',0)) - - ! deallocate the data we no longer need - deallocate(ncohorts,idx2) - ! leave the define mode to commit the new definitions to the disk - iret = nf_enddef(ncid) - endif - call mpp_sync_self() -end subroutine create_cohort_dimension_orig - subroutine create_cohort_dimension_new(rhandle,cidx,name,tile_dim_length) - type(restart_file_type), intent(inout) :: rhandle ! restart file handle + type(FmsNetcdfUnstructuredDomainFile_t), intent(inout) :: rhandle ! fms_io restart file data type integer, allocatable, intent(out) :: cidx(:) ! rank local tile index vector character(len=*), intent(in) :: name ! name of the restart file integer, intent(in) :: tile_dim_length ! length of tile axis @@ -349,35 +211,47 @@ subroutine create_cohort_dimension_new(rhandle,cidx,name,tile_dim_length) end subroutine create_cohort_dimension_new subroutine create_cohort_out_file_idx(rhandle,name,cidx,cohorts_dim_length) - type(restart_file_type), intent(inout) :: rhandle ! restart file handle + type(FmsNetcdfUnstructuredDomainFile_t),intent(inout) :: rhandle ! fms_io restart file data type character(len=*), intent(in) :: name ! name of the file to create integer , intent(in) :: cidx(:) ! integer compressed index of tiles (local) integer , intent(in) :: cohorts_dim_length ! length of cohorts axis ! ---- local vars character(256) :: file_name ! full name of the file, including the processor number + integer :: ncidx + integer, dimension(:), allocatable :: npes_cidx !Cohort index length of each pe in file's pelist. + integer, dimension(:), allocatable :: npes_cidx_start !Offset of cohort index of each pe in file's pelist. + integer, dimension(cohorts_dim_length) :: buffer + integer :: i ! form the full name of the file call get_instance_filename(trim(name), file_name) - call get_mosaic_tile_file(trim(file_name),file_name,lnd%ug_domain) ! the size of tile dimension really does not matter for the output, but it does ! matter for uncompressing utility, since it uses it as a size of the array to ! unpack to create tile index dimension and variable. - call fms_io_unstructured_register_restart_axis(rhandle, & - name, & - trim(cohort_index_name), & - cidx, & - "cohort tile lat lon", & - "H", & - cohorts_dim_length, & - lnd%ug_domain, & - dimlen_name="cohort", & - dimlen_lname="cohort number within tile", & - units="none", & - longname="compressed vegetation cohort index", & - imin=0) - + call register_axis(rhandle, "cohort", cohorts_dim_length) + call register_field(rhandle, "cohort", "int", (/"cohort"/)) + call register_variable_attribute(rhandle, "cohort", "long_name", "cohort number within tile", & + str_len=len(trim("cohort number within tile"))) + do i = 1, cohorts_dim_length + buffer(i) = i + enddo + call write_data(rhandle, "cohort", buffer) + + ncidx = size(cidx) + call compressed_start_and_count(rhandle, ncidx, npes_cidx_start, npes_cidx) + call register_axis(rhandle, cohort_index_name, npes_corner=npes_cidx_start, npes_nelems=npes_cidx) + deallocate(npes_cidx_start) + deallocate(npes_cidx) + call register_field(rhandle, cohort_index_name, "int", (/cohort_index_name/)) + call register_variable_attribute(rhandle, cohort_index_name, "compress", "cohort tile lat lon", & + str_len=len(trim("cohort tile lat lon"))) + call register_variable_attribute(rhandle, cohort_index_name, "units", "none", str_len=len(trim("none"))) + call register_variable_attribute(rhandle, cohort_index_name, "long_name", "compressed vegetation cohort index", & + str_len=len(trim("compressed vegetation cohort index"))) + call register_variable_attribute(rhandle, cohort_index_name, "valid_min", 0) + call write_data(rhandle, cohort_index_name, cidx) end subroutine create_cohort_out_file_idx subroutine distrib_cohort_data_i0d(fptr,idx,ntiles,data) @@ -485,7 +359,7 @@ subroutine gather_cohort_data_i0d(fptr,idx,ntiles,data) ! gather data into an array along the cohort dimension do i = 1, size(idx) call get_cohort_by_idx ( idx(i), ntiles, cohort) - data(i) = NF_FILL_INT + data(i) = NF90_FILL_INT if (associated(cohort)) then call fptr(cohort, ptr) if(associated(ptr)) data(i) = ptr @@ -507,7 +381,7 @@ subroutine gather_cohort_data_r0d(fptr,idx,ntiles,data) ! gather data into an array along the cohort dimension do i = 1, size(idx) call get_cohort_by_idx ( idx(i), ntiles, cohort) - data(i) = NF_FILL_DOUBLE + data(i) = NF90_FILL_DOUBLE if (associated(cohort)) then call fptr(cohort, ptr) if(associated(ptr)) data(i) = ptr @@ -521,20 +395,25 @@ subroutine add_cohort_data(restart,varname,fptr,longname,units) character(len=*), intent(in) :: varname ! name of the variable to write procedure(cptr_r0) :: fptr ! subroutine returning pointer to the data character(len=*), intent(in), optional :: units, longname - + character(len=32) :: chksum + real, pointer :: r(:) - integer :: id_restart allocate(r(size(restart%cidx))) call gather_cohort_data_r0d(fptr,restart%cidx,restart%tile_dim_length,r) - if (new_land_io) then - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, & - restart%basename, varname, r, (/HIDX/), lnd%ug_domain, & - longname=longname, units=units, restart_owns_data=.true.) - else - call write_cohort_data_r0d(restart%ncid,varname,r,longname,units) - deallocate(r) + call register_field(restart%rhandle, varname, "double", (/cohort_index_name, "Time"/)) + call register_variable_attribute(restart%rhandle, varname, "_FillValue", NF90_FILL_DOUBLE) + if (present(units)) then + call register_variable_attribute(restart%rhandle, varname, "units", trim(units), str_len=len(trim(units))) + endif + if (present(longname)) then + call register_variable_attribute(restart%rhandle, varname, "long_name", trim(longname), str_len=len(trim(longname))) endif + + call get_land_chksum(r,chksum) + call register_variable_attribute(restart%rhandle, varname, "checksum", trim(chksum), str_len=len(trim(chksum))) + call write_data(restart%rhandle, varname, r) + deallocate(r) end subroutine add_cohort_data ! ============================================================================ @@ -544,19 +423,25 @@ subroutine add_int_cohort_data(restart,varname,fptr,longname,units) procedure(cptr_i0) :: fptr ! subroutine returning pointer to the data character(len=*), intent(in), optional :: units, longname + character(len=32) :: chksum integer, pointer :: r(:) integer :: id_restart allocate(r(size(restart%cidx))) call gather_cohort_data_i0d(fptr,restart%cidx,restart%tile_dim_length,r) - if (new_land_io) then - id_restart = fms_io_unstructured_register_restart_field(restart%rhandle, & - restart%basename, varname, r, (/HIDX/), lnd%ug_domain, & - longname=longname, units=units, restart_owns_data=.true.) - else - call write_cohort_data_i0d(restart%ncid,varname,r,longname,units) - deallocate(r) + call register_field(restart%rhandle, varname, "int", (/cohort_index_name, "Time"/)) + call register_variable_attribute(restart%rhandle, varname, "_FillValue", NF90_FILL_INT) + if (present(units)) then + call register_variable_attribute(restart%rhandle, varname, "units", trim(units), str_len=len(trim(units))) + endif + if (present(longname)) then + call register_variable_attribute(restart%rhandle, varname, "long_name", trim(longname), str_len=len(trim(longname))) endif + + call get_land_chksum(r,chksum) + call register_variable_attribute(restart%rhandle, varname, "checksum", trim(chksum), str_len=len(trim(chksum))) + call write_data(restart%rhandle, varname, r) + deallocate(r) end subroutine add_int_cohort_data ! ============================================================================ @@ -566,16 +451,13 @@ subroutine get_cohort_data(restart,varname,fptr) procedure(cptr_r0) :: fptr ! subroutine returning pointer to the data real, allocatable :: r(:) - if (new_land_io) then - if (.not.allocated(restart%cidx)) call error_mesg('read_create_cohorts', & - 'cohort index not found in file "'//restart%filename//'"',FATAL) - allocate(r(size(restart%cidx))) - call fms_io_unstructured_read(restart%basename, varname, r, lnd%ug_domain, timelevel=1) - call distrib_cohort_data_r0d(fptr,restart%cidx,restart%tile_dim_length,r) - deallocate(r) - else - call read_cohort_data_r0d_fptr(restart%ncid,varname,fptr) - endif + + if (.not.allocated(restart%cidx)) call error_mesg('read_create_cohorts', & + 'cohort index not found in file "'//restart%filename//'"',FATAL) + allocate(r(size(restart%cidx))) + call read_data(restart%rhandle, varname, r) + call distrib_cohort_data_r0d(fptr,restart%cidx,restart%tile_dim_length,r) + deallocate(r) end subroutine get_cohort_data ! ============================================================================ @@ -585,32 +467,13 @@ subroutine get_int_cohort_data(restart,varname,fptr) procedure(cptr_i0) :: fptr ! subroutine returning pointer to the data integer, allocatable :: r(:) - if (new_land_io) then - if (.not.allocated(restart%cidx)) call error_mesg('read_create_cohorts', & - 'cohort index not found in file "'//restart%filename//'"',FATAL) - allocate(r(size(restart%cidx))) - call fms_io_unstructured_read(restart%basename, varname, r, lnd%ug_domain, timelevel=1) - call distrib_cohort_data_i0d(fptr,restart%cidx,restart%tile_dim_length,r) - deallocate(r) - else - call read_cohort_data_i0d_fptr(restart%ncid,varname,fptr) - endif -end subroutine get_int_cohort_data -#define F90_TYPE real -#define NF_TYPE NF_DOUBLE -#define NF_FILL_VALUE NF_FILL_DOUBLE -#define READ_0D_FPTR read_cohort_data_r0d_fptr -#define WRITE_0D_FPTR write_cohort_data_r0d_fptr -#define WRITE_0D write_cohort_data_r0d -#include "vegn_cohort_io.inc" - -#define F90_TYPE integer -#define NF_TYPE NF_INT -#define NF_FILL_VALUE NF_FILL_INT -#define READ_0D_FPTR read_cohort_data_i0d_fptr -#define WRITE_0D_FPTR write_cohort_data_i0d_fptr -#define WRITE_0D write_cohort_data_i0d -#include "vegn_cohort_io.inc" + if (.not.allocated(restart%cidx)) call error_mesg('read_create_cohorts', & + 'cohort index not found in file "'//restart%filename//'"',FATAL) + allocate(r(size(restart%cidx))) + call read_data(restart%rhandle, varname, r) + call distrib_cohort_data_i0d(fptr,restart%cidx,restart%tile_dim_length,r) + deallocate(r) +end subroutine get_int_cohort_data end module cohort_io_mod diff --git a/vegetation/vegn_cohort_io.inc b/vegetation/vegn_cohort_io.inc deleted file mode 100644 index cd950c8e..00000000 --- a/vegetation/vegn_cohort_io.inc +++ /dev/null @@ -1,168 +0,0 @@ -!*********************************************************************** -!* GNU Lesser General Public License -!* -!* This file is part of the GFDL Flexible Modeling System (FMS). -!* -!* FMS 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 (at -!* your option) any later version. -!* -!* FMS is distributed in the hope that it will be useful, but WITHOUT -!* ANY WARRANTY; 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 FMS. If not, see . -!*********************************************************************** -! -*-f90-*- -! $Id$ - -! some sanity checks -#ifndef F90_TYPE -#error F90_TYPE is not defined: must be one of FORTRAN 90 types -#endif - -#ifndef NF_TYPE -#error NF_TYPE is not defined: must be netcdf type name corresponding to F90_TYPE -#endif - -#ifndef READ_0D_FPTR -#error name of subroutine READ_0D_FPTR is not defined -#endif - -#ifndef WRITE_0D_FPTR -#error name of subroutine WRITE_0D_FPTR is not defined -#endif - -! ============================================================================ -subroutine READ_0D_FPTR(ncid,name,fptr,rec) - integer , intent(in) :: ncid ! netcdf id - character(len=*) , intent(in) :: name ! name of the variable to read - integer, optional , intent(in) :: rec ! record number (in case there are - ! several in the file) - ! subroutine returning the pointer to the data to be written - interface ; subroutine fptr(cohort, ptr) - use vegn_cohort_mod, only : vegn_cohort_type - type(vegn_cohort_type), pointer :: cohort ! input - F90_TYPE, pointer :: ptr ! returned pointer to the data - end subroutine fptr - end interface - - ! ---- local constants - character(*), parameter :: module_name = 'read_cohort_data_r0d_fptr' - - ! ---- local vars - integer :: i, n - integer :: rec_ ! record number - integer :: ntiles ! size of the tile dimension in restart file - integer :: ncohorts ! total number of cohorts in restart file - integer :: bufsize ! size of the input buffer - integer :: idxid ! id of the index dimension - integer :: start(1),count(1) ! definition of slab for reading - integer, allocatable :: idx(:) ! index dimension - F90_TYPE, allocatable :: data(:) ! data to be read - F90_TYPE, pointer :: ptr ! pointer to the individual cohort data - type(vegn_cohort_type), pointer :: cohort - - ! assign the internal record number - if(present(rec)) then - rec_ = rec - else - rec_ = 1 - endif - - ! get the size of the tile dimension - __NF_ASRT__(nfu_inq_dim(ncid,'tile',len=ntiles)) - - ! get the length of cohort compressed index - __NF_ASRT__(nfu_inq_dim(ncid,cohort_index_name,len=ncohorts)) - __NF_ASRT__(nfu_inq_var(ncid,cohort_index_name,id=idxid)) - - ! allocate data - bufsize=min(input_buf_size,ncohorts) - allocate(data(bufsize),idx(bufsize)) - - do n = 1, ncohorts, bufsize - ! read the cohort index - __NF_ASRT__(nf_get_vara_int(ncid,idxid,n,min(bufsize,ncohorts-n+1),idx)) - ! read the data - start(1) = n; count(1) = min(bufsize,ncohorts-n+1) - __NF_ASRT__(nfu_get_rec(ncid,name,rec_,data,start,count)) - - ! distribute data over cohorts - do i = 1, size(idx) - call get_cohort_by_idx ( idx(i), ntiles, cohort) - if (associated(cohort)) then - call fptr(cohort, ptr) - if(associated(ptr)) ptr = data(i) - endif - enddo - enddo - - ! free allocated memory - deallocate(data,idx) - -end subroutine READ_0D_FPTR - -! ============================================================================ -subroutine WRITE_0D(ncid,name,data,long_name,units,record) - integer , intent(in) :: ncid ! netcdf id - character(len=*), intent(in) :: name ! name of the variable to write - F90_TYPE , intent(in) :: data(:) ! data to be written - character(len=*), intent(in), optional :: units, long_name - integer , intent(in), optional :: record - - ! ---- local vars - integer :: iret, varid, record_, p, k - F90_TYPE, allocatable :: buffer(:) ! input buffer for data from other PEs - integer, allocatable :: nc(:) ! number of cohorts per PE in IO domain - integer :: dimids(2), ndims - - ! if this processor isn't the root IO processor, simply send data to the root - ! IO processor and return from the subroutine - if (mpp_pe()/=lnd%io_pelist(1)) then - call mpp_send(size(data), plen=1, to_pe=lnd%io_pelist(1), tag=COMM_TAG_1) - call mpp_send(data(1), plen=size(data), to_pe=lnd%io_pelist(1), tag=COMM_TAG_2) - else - allocate(nc(size(lnd%io_pelist))) - nc(1) = size(data) - do p = 2,size(lnd%io_pelist) - call mpp_recv(nc(p), from_pe=lnd%io_pelist(p), glen=1, tag=COMM_TAG_1) - enddo - ! gather data from the processors in io_domain - allocate(buffer(sum(nc(:)))) - buffer(1:nc(1)) = data(:) - k=nc(1)+1 - do p = 2,size(lnd%io_pelist) - call mpp_recv(buffer(k), glen=nc(p), from_pe=lnd%io_pelist(p), tag=COMM_TAG_2) - k = k+nc(p) - enddo - - ! create variable, if it does not exist - if(nf_inq_varid(ncid,name,varid)/=NF_NOERR) then - ! get the ID of cohort dimension - __NF_ASRT__(nf_inq_dimid(ncid,cohort_index_name,dimids(1))) - - ndims = 1 - if(present(record)) then - if(nf_inq_unlimdim(ncid,dimids(2))==NF_NOERR) then - ndims = 2 - endif - endif - __NF_ASRT__(nfu_def_var(ncid,name,NF_TYPE,dimids(1:ndims),long_name,units)) - endif - ! write data - iret = nf_enddef(ncid) ! ignore errors (file may be in data mode already) - record_ = 1 - if(present(record)) record_ = record - __NF_ASRT__(nfu_put_rec(ncid,name,record_,buffer)) - deallocate(buffer) - endif - ! wait for all PEs to finish: necessary because mpp_send does not seem to - ! copy the data, and therefore on non-root io_domain PE there would be a chance - ! that the data and mask are destroyed before they are actually sent. - call mpp_sync() - ! free allocated memory -end subroutine WRITE_0D diff --git a/vegetation/vegn_data.F90 b/vegetation/vegn_data.F90 index 0ddd3fac..02042ea6 100644 --- a/vegetation/vegn_data.F90 +++ b/vegetation/vegn_data.F90 @@ -18,14 +18,9 @@ !*********************************************************************** module vegn_data_mod -#ifdef INTERNAL_FILE_NML use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif - -use fms_mod, only : file_exist, check_nml_error, & - close_file, stdlog, stdout +use fms_mod, only : check_nml_error, & + stdlog, stdout use land_constants_mod, only : NBANDS, BAND_VIS, BAND_NIR use land_tile_selectors_mod, only : & @@ -483,7 +478,7 @@ module vegn_data_mod ! ============================================================================ subroutine read_vegn_data_namelist() ! ---- local vars - integer :: unit ! unit for namelist i/o + integer :: file_unit ! unit for namelist i/o integer :: io ! i/o status for the namelist integer :: ierr ! error code, returned by i/o routines integer :: i @@ -492,35 +487,22 @@ subroutine read_vegn_data_namelist() call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML read (input_nml_file, nml=vegn_data_nml, iostat=io) ierr = check_nml_error(io, 'vegn_data_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=vegn_data_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'vegn_data_nml') - enddo -10 continue - call close_file (unit) - endif -#endif - - unit=stdlog() + + file_unit=stdlog() ! reconcile values of fact_crit_phen and cnst_crit_phen cnst_crit_phen = max(0.0,min(1.0,cnst_crit_phen)) fact_crit_phen = max(0.0,fact_crit_phen) where (cnst_crit_phen/=0) fact_crit_phen=0.0 - write(unit,*)'reconciled fact_crit_phen and cnst_crit_phen' + write(file_unit,*)'reconciled fact_crit_phen and cnst_crit_phen' ! do the same for fire cnst_crit_fire = max(0.0,min(1.0,cnst_crit_fire)) fact_crit_fire = max(0.0,fact_crit_fire) where (cnst_crit_fire/=0) fact_crit_fire=0.0 - write(unit,*)'reconciled fact_crit_fire and cnst_crit_fire' + write(file_unit,*)'reconciled fact_crit_fire and cnst_crit_fire' ! initialize vegetation data structure @@ -602,7 +584,7 @@ subroutine read_vegn_data_namelist() call register_tile_selector('ntrlgrass', long_name='natural (non-human-maintained) grass',& tag = SEL_VEGN, idata1 = NG_SEL_TAG) - write (unit, nml=vegn_data_nml) + write (file_unit, nml=vegn_data_nml) call init_with_headers(table,species_name) call add_row(table,'Treefall dist. rate', spdata(:)%treefall_disturbance_rate) @@ -674,7 +656,7 @@ subroutine read_vegn_data_namelist() call add_row(table,'tracer_cuticular_cond',spdata(:)%tracer_cuticular_cond) call print(table,stdout()) - call print(table,unit) + call print(table,file_unit) end subroutine diff --git a/vegetation/vegn_harvesting.F90 b/vegetation/vegn_harvesting.F90 index 4befb5cb..aa3dab22 100644 --- a/vegetation/vegn_harvesting.F90 +++ b/vegetation/vegn_harvesting.F90 @@ -18,17 +18,10 @@ !*********************************************************************** module vegn_harvesting_mod -#ifdef INTERNAL_FILE_NML -use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif - use fms_mod, only : string, error_mesg, FATAL, NOTE, & - mpp_pe, file_exist, close_file, & + mpp_pe, & check_nml_error, stdlog, mpp_root_pe -use mpp_io_mod, only : axistype, mpp_get_atts, mpp_get_axis_data, & - mpp_open, mpp_close, MPP_RDONLY, MPP_WRONLY, MPP_ASCII +use mpp_mod, only: input_nml_file use vegn_data_mod, only : N_LU_TYPES, LU_PAST, LU_CROP, LU_NTRL, LU_SCND, & HARV_POOL_PAST, HARV_POOL_CROP, HARV_POOL_CLEARED, HARV_POOL_WOOD_FAST, & HARV_POOL_WOOD_MED, HARV_POOL_WOOD_SLOW, & @@ -101,21 +94,8 @@ subroutine vegn_harvesting_init call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML read (input_nml_file, nml=harvesting_nml, iostat=io) ierr = check_nml_error(io, 'harvesting_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file ( ) - ierr = 1; - do while (ierr /= 0) - read (unit, nml=harvesting_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'harvesting_nml') - enddo -10 continue - call close_file (unit) - endif -#endif if (mpp_pe() == mpp_root_pe()) then unit=stdlog() diff --git a/vegetation/vegn_photosynthesis.F90 b/vegetation/vegn_photosynthesis.F90 index cd493864..cca7427a 100644 --- a/vegetation/vegn_photosynthesis.F90 +++ b/vegetation/vegn_photosynthesis.F90 @@ -20,12 +20,8 @@ module vegn_photosynthesis_mod #include "../shared/debug.inc" -#ifdef INTERNAL_FILE_NML use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif -use fms_mod, only: error_mesg, FATAL, file_exist, close_file, check_nml_error, stdlog, & +use fms_mod, only: error_mesg, FATAL, check_nml_error, stdlog, & mpp_pe, mpp_root_pe, lowercase use constants_mod, only : TFREEZE use sphum_mod, only : qscomp @@ -104,31 +100,18 @@ module vegn_photosynthesis_mod ! ============================================================================ subroutine vegn_photosynthesis_init() ! ---- local vars - integer :: unit ! unit for namelist i/o + integer :: file_unit ! unit for namelist i/o integer :: io ! i/o status for the namelist integer :: ierr ! error code, returned by i/o routines call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml=photosynthesis_nml, iostat=io) - ierr = check_nml_error(io, 'photosynthesis_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file() - ierr = 1; - do while (ierr /= 0) - read (unit, nml=photosynthesis_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'photosynthesis_nml') - enddo -10 continue - call close_file (unit) - endif -#endif + read (input_nml_file, nml=photosynthesis_nml, iostat=io) + ierr = check_nml_error(io, 'photosynthesis_nml') - unit=stdlog() + file_unit=stdlog() if (mpp_pe() == mpp_root_pe()) then - write(unit, nml=photosynthesis_nml) + write(file_unit, nml=photosynthesis_nml) endif ! convert symbolic names of photosynthesis options into numeric IDs to diff --git a/vegetation/vegn_radiation.F90 b/vegetation/vegn_radiation.F90 index ae109a3c..2969cca8 100644 --- a/vegetation/vegn_radiation.F90 +++ b/vegetation/vegn_radiation.F90 @@ -236,7 +236,7 @@ subroutine vegn_rad_properties_twostream( cohort, cosz, & end select ! get the snow radiative properties for current canopy temperature - call snow_radiation ( cohort%Tv, cosz, .FALSE., snow_refl_dir, snow_refl_dif, snow_refl_lw, snow_emis ) + call snow_radiation ( cohort%Tv, cosz, .FALSE., -1, snow_refl_dir, snow_refl_dif, snow_refl_lw, snow_emis ) sp = cohort%species do i = 1, NBANDS diff --git a/vegetation/vegn_static_override.F90 b/vegetation/vegn_static_override.F90 index 2d24cee5..dbceda32 100644 --- a/vegetation/vegn_static_override.F90 +++ b/vegetation/vegn_static_override.F90 @@ -19,49 +19,32 @@ module static_vegn_mod use constants_mod, only : pi -use mpp_mod, only : mpp_max, mpp_sum -use mpp_io_mod, only : fieldtype, axistype, mpp_get_atts, mpp_open, MPP_RDONLY, & - MPP_NETCDF, MPP_MULTI, MPP_SINGLE, mpp_get_axis_by_name, default_axis, & - mpp_get_info, mpp_get_times, mpp_get_fields, mpp_get_axis_data, mpp_get_axis_data, & - validtype, mpp_is_valid, mpp_get_time_axis -use fms_io_mod, only : restart_file_type, set_domain, nullify_domain, & - get_file_name +use mpp_mod, only : mpp_max, mpp_sum, input_nml_file use time_manager_mod, only : time_type, set_date, time_type_to_real, & get_calendar_type, valid_calendar_types, operator(-), get_date use get_cal_time_mod, only : get_cal_time -#ifdef INTERNAL_FILE_NML -use mpp_mod, only: input_nml_file -#else -use fms_mod, only: open_namelist_file -#endif - use fms_mod, only : error_mesg, FATAL, NOTE, & - mpp_pe, file_exist, close_file, check_nml_error, stdlog, lowercase, & - mpp_root_pe, get_mosaic_tile_file, fms_error_handler + mpp_pe, check_nml_error, stdlog, lowercase, & + mpp_root_pe, fms_error_handler use time_interp_mod, only : time_interp use diag_manager_mod, only : get_base_date -use nf_utils_mod, only : nfu_inq_dim, nfu_get_dim, nfu_def_dim, & - nfu_inq_compressed_var, nfu_get_compressed_rec, nfu_validtype, & - nfu_get_valid_range, nfu_is_valid, nfu_put_rec, nfu_put_att use land_data_mod, only : log_version, lnd -use land_io_mod, only : print_netcdf_error, new_land_io use land_numerics_mod, only : nearest use land_tile_io_mod, only : create_tile_out_file, gather_tile_index use land_tile_mod, only : land_tile_map, land_tile_type, land_tile_enum_type, first_elmt, & tail_elmt, next_elmt, current_tile, operator(/=), nitems use vegn_cohort_mod, only : vegn_cohort_type -use cohort_io_mod, only : create_cohort_dimension_new, create_cohort_dimension_orig, gather_cohort_data, & - write_cohort_data_i0d, write_cohort_data_r0d, gather_cohort_index +use cohort_io_mod, only : create_cohort_dimension_new, gather_cohort_data, & + gather_cohort_index -use fms_io_mod, only: fms_io_unstructured_register_restart_axis -use fms_io_mod, only: fms_io_unstructured_register_restart_field -use fms_io_mod, only: fms_io_unstructured_save_restart -use fms_io_mod, only: HIDX -use fms_io_mod, only: fms_io_unstructured_get_field_size -use fms_io_mod, only: fms_io_unstructured_read -use fms_io_mod, only: get_field_size,read_compressed +use fms2_io_mod, only: FmsNetcdfUnstructuredDomainFile_t, register_axis, & + register_field, register_variable_attribute, unlimited, & + register_restart_field, write_restart, get_dimension_size, & + get_variable_size, read_data, FmsNetcdfFile_t, open_file, & + close_file, variable_exists, variable_att_exists, & + get_variable_attribute, get_variable_num_dimensions, get_unlimited_dimension_name implicit none private @@ -90,10 +73,9 @@ module static_vegn_mod ! land grid cells in current domain they hold indices of corresponding points ! in the input grid. type(time_type) :: base_time ! model base time for static vegetation output -type(fieldtype), allocatable :: Fields(:) -integer :: input_unit, ispecies, ibl, iblv, ibr, ibsw, ibwood, ibliving, istatus +integer :: ispecies, ibl, iblv, ibr, ibsw, ibwood, ibliving, istatus -type(restart_file_type) :: static_veg_file ! handle of output file, for new IO +type(FmsNetcdfUnstructuredDomainFile_t) :: static_veg_file ! handle of output file, for new IO integer :: ncid2 ! netcdf id of the output file, for old IO integer :: tile_dim_length ! length of tile dimension in output files. global max of number of tiles per gridcell integer, allocatable :: cidx(:) ! cohort compression index, local for current PE @@ -119,11 +101,8 @@ module static_vegn_mod fill_land_mask, write_static_veg, static_veg_freq logical :: input_is_multiface ! TRUE if the input files are face-specific - -! ==== NetCDF declarations ================================================== -include 'netcdf.inc' -#define __NF_ASRT__(x) call print_netcdf_error((x),__FILE__,__LINE__) - +type(FmsNetcdfFile_t) :: fileobj +type(FmsNetcdfUnstructuredDomainFile_t) :: fileobj_domainug contains @@ -137,21 +116,8 @@ subroutine read_static_vegn_namelist(static_veg_used) call log_version(version, module_name, & __FILE__) -#ifdef INTERNAL_FILE_NML read (input_nml_file, nml=static_veg_nml, iostat=io) ierr = check_nml_error(io, 'static_veg_nml') -#else - if (file_exist('input.nml')) then - unit = open_namelist_file ( ) - ierr = 1; - do while (ierr /= 0) - read (unit, nml=static_veg_nml, iostat=io, end=10) - ierr = check_nml_error (io, 'static_veg_nml') - enddo -10 continue - call close_file (unit) - endif -#endif if (mpp_pe() == mpp_root_pe()) then unit=stdlog() @@ -176,268 +142,135 @@ end subroutine read_static_vegn_namelist subroutine static_vegn_init( ) ! ---- local vars - integer :: unlimdim, timelen, timeid - integer :: i,j,k,iret - character(len=NF_MAX_NAME) :: dimname ! name of the dimension variable : time, lon, and lat - integer :: ndims ! rank of input vars - integer :: dimids (NF_MAX_VAR_DIMS) ! netcdf IDs of input var dimensions - integer :: dimlens(NF_MAX_VAR_DIMS) ! sizes of respective dimensions - real, allocatable :: t(:) ! temporary real timeline + integer :: i,j,k + integer, dimension(5) :: dimlens ! sizes of respective dimensions (lon, lat, tile, cohort, time) character(len=256) :: units ! units of time in the file character(len=256) :: calendar ! calendar of the data real, allocatable :: in_lon(:)! longitude coordinates in input file real, allocatable :: in_lat(:)! latitude coordinates in input file logical, allocatable :: mask(:,:)! mask of valid points in input data - integer, allocatable :: data(:,:,:,:) ! temporary array used to calculate the mask of - ! valid input data - logical :: has_records ! true if input variable has records - integer :: m, n, siz(4), ndim, nvar, natt, l - character(len=1024) :: actual_input_file, actual_input_file2 + integer :: m, n, l + integer, dimension(:), allocatable :: siz ! logical :: input_is_multiface ! TRUE if the input files are face-specific - logical :: found_file, read_dist, io_domain_exist - type(axistype) :: Lon_axis, Lat_axis, Tile_axis, Cohort_axis - type(axistype) :: Time_axis - character(len=256) :: name integer, allocatable :: cidx(:), idata(:) + logical:: exists + real, dimension(:), allocatable :: t + integer :: ndims + character(len=256) :: dimension_name !NAME OF UNLIMITED DIMENSION (i.e "time") if(module_is_initialized) return if(use_static_veg) then - ! SET UP LOOP BOUNDARIES - ts = set_date(start_loop(1),start_loop(2),start_loop(3), start_loop(4),start_loop(5),start_loop(6)) - te = set_date(end_loop(1) ,end_loop(2) ,end_loop(3) , end_loop(4) ,end_loop(5) ,end_loop(6) ) + ! SET UP LOOP BOUNDARIES + ts = set_date(start_loop(1),start_loop(2),start_loop(3), start_loop(4),start_loop(5),start_loop(6)) + te = set_date(end_loop(1) ,end_loop(2) ,end_loop(3) , end_loop(4) ,end_loop(5) ,end_loop(6) ) - if(new_land_io) then - ! OPEN INPUT FILE - if(file_exist(trim(input_file),no_domain=.true.)) then - call mpp_open(input_unit, trim(input_file), action=MPP_RDONLY, form=MPP_NETCDF, & - threading=MPP_MULTI, fileset=MPP_SINGLE) - call error_mesg('static_vegn_init','Reading global static vegetation file "'& - //trim(input_file)//'"', NOTE) - input_is_multiface = .FALSE. - actual_input_file = input_file + ! OPEN INPUT FILE + exists = open_file(fileobj, input_file, "read") + if (exists) then + call error_mesg('static_vegn_init','Reading global static vegetation file "'& + //trim(input_file)//'"', NOTE) + input_is_multiface = .FALSE. + else + if(lnd%nfaces==1) then + ! for 1-face grid we cannot use multi-face input, even if it exists + call error_mesg('static_vegn_init','input file "'//trim(input_file)& + //'" does not exist', FATAL) else - if(lnd%nfaces==1) then - ! for 1-face grid we cannot use multi-face input, even if it exists - call error_mesg('static_vegn_init','input file "'//trim(input_file)& - //'" does not exist', FATAL) - else - ! if there is more then one face, try opening face-specific input with consideration of io_layout - call get_mosaic_tile_file(trim(input_file),actual_input_file2,.FALSE.,lnd%sg_domain) - found_file = get_file_name(input_file, actual_input_file, read_dist, io_domain_exist, & - domain=lnd%sg_domain) - if(.not.found_file) call error_mesg('static_vegn_init','"'//trim(actual_input_file2)// & - '" and corresponding distributed file are not found', FATAL) - if(read_dist) then - call mpp_open(input_unit, trim(actual_input_file), action=MPP_RDONLY, form=MPP_NETCDF, & - threading=MPP_MULTI, fileset=MPP_MULTI, domain=lnd%sg_domain) - else - call mpp_open(input_unit, trim(actual_input_file), action=MPP_RDONLY, form=MPP_NETCDF, & - threading=MPP_MULTI, fileset=MPP_SINGLE) - endif - call error_mesg('static_vegn_init','Reading face-specific vegetation file "'& - //trim(actual_input_file)//'"', NOTE) - input_is_multiface = .TRUE. - endif - endif - - call mpp_get_info(input_unit,ndim,nvar,natt,timelen) - call mpp_get_time_axis(input_unit, Time_axis) - - ! READ TIME AXIS DATA - allocate(t(timelen)) - call mpp_get_times(input_unit, t) - - allocate(Fields(nvar)) - call mpp_get_fields(input_unit, Fields) - do i=1,nvar - call mpp_get_atts(Fields(i), name=name) - select case (name) - case ('species') - ispecies = i - case ('bl') - ibl = i - case ('blv') - iblv = i - case ('br') - ibr = i - case ('bsw') - ibsw = i - case ('bwood') - ibwood = i - case ('bliving') - ibliving = i - case ('status') - istatus = i - end select - enddo - - ! GET UNITS OF THE TIME AND CALENDAR OF THE DATA - units = ' ' - calendar = 'JULIAN' - call mpp_get_atts(Time_axis, units=units, calendar=calendar) - - ! CONVERT TIME TO THE FMS TIME_TYPE AND STORE IT IN THE TIMELINE FOR THE DATA SET - allocate(time_line(timelen)) - do i = 1, size(t) - ! set the respective value in the timeline - time_line(i) = get_cal_time(t(i),units,calendar) - enddo + ! if there is more then one face, try opening face-specific input with consideration of io_layout + exists = open_file(fileobj_domainug, input_file, "read", lnd%ug_domain) + if (.not. exists) then + call error_mesg('static_vegn_init','"'//trim(input_file)// & + '" and corresponding distributed file are not found', FATAL) - ! READ HORIZONTAL COORDINATES - Lon_axis = mpp_get_axis_by_name(input_unit,'lon') - call mpp_get_atts(Lon_axis, len=dimlens(1)) - allocate(in_lon(dimlens(1))) - call mpp_get_axis_data(Lon_axis, in_lon) - - Lat_axis = mpp_get_axis_by_name(input_unit,'lat') - call mpp_get_atts(Lat_axis, len=dimlens(2)) - allocate(in_lat(dimlens(2))) - call mpp_get_axis_data(Lat_axis, in_lat) - - in_lon = in_lon*PI/180.0 ; in_lat = in_lat*PI/180.0 - - ! COMPUTE INDEX REMAPPING ARRAY - allocate(map_i(lnd%ls:lnd%le)) - allocate(map_j(lnd%ls:lnd%le)) - map_i = -1 - map_j = -1 - if( .not. input_is_multiface ) then - allocate(mask(size(in_lon),size(in_lat))) - mask = .false. - - if(fill_land_mask) then - ! READ THE FIRST RECORD AND CALCULATE THE MASK OF THE VALID INPUT DATA - Tile_axis = mpp_get_axis_by_name(input_unit,'tile') - call mpp_get_atts(Tile_axis, len=dimlens(3)) - Cohort_axis = mpp_get_axis_by_name(input_unit,'cohort') - call mpp_get_atts(Cohort_axis, len=dimlens(4)) - ! Note: The input file used for initial testing had - ! lon = 144, lat = 90, tile = 2, cohort = 1 - call get_field_size(trim(input_file),'cohort_index',siz, domain=lnd%sg_domain) - allocate(cidx(siz(1)), idata(siz(1))) - call set_domain(lnd%sg_domain) - call read_compressed(trim(input_file),'cohort_index',cidx,timelevel=1) - call read_compressed(trim(input_file),'species',idata,timelevel=1) - do n = 1,size(cidx) - m = cidx(n) - i = modulo(m,dimlens(1))+1 - m = m/dimlens(1) - j = modulo(m,dimlens(2))+1 - m = m/dimlens(2) - ! k = modulo(m,dimlens(3))+1 ! This is how to get tile number, if it were needed. - m = m/dimlens(3) - ! L = m+1 ! This is how to get cohort number, if it were needed. No need to do - ! modulo with dimlens(4) because at this point m is always < dimlens(4) - if(idata(n)>=0 .or. mask(i,j)) then - mask(i,j) = .TRUE. ! If species exists in any cohort of this grid cell then mask is .TRUE. - endif - enddo - deallocate(idata) - else - mask(:,:) = .TRUE. - endif - endif - else ! original code below here. i.e. if(.not.new_land_io) - ! OPEN INPUT FILE - if (nf_open(input_file,NF_NOWRITE,ncid)/=NF_NOERR) then - if(lnd%nfaces==1) then - ! for 1-face grid we cannot use multi-face input, even if it exists - call error_mesg('static_vegn_init','input file "'//trim(input_file)& - //'" does not exist', FATAL) - else - ! if there is more then one face, try opening face-specific input - call get_mosaic_tile_file(trim(input_file),actual_input_file,lnd%ug_domain) - if (nf_open(actual_input_file,NF_NOWRITE,ncid)/=NF_NOERR) then - call error_mesg('static_vegn_init','Neither "'//trim(input_file)& - //'" nor "'//trim(actual_input_file)//'" files exist', FATAL) - else - call error_mesg('static_vegn_init','Reading face-specific vegetation file "'& - //trim(actual_input_file)//'"', NOTE) - input_is_multiface = .TRUE. - endif endif - else - call error_mesg('static_vegn_init','Reading global static vegetation file "'& + call error_mesg('static_vegn_init','Reading face-specific vegetation file "'& //trim(input_file)//'"', NOTE) - input_is_multiface = .FALSE. - actual_input_file = input_file - endif - - ! READ TIME AXIS DATA - if(nf_inq_unlimdim( ncid, unlimdim )/=NF_NOERR) then - call error_mesg('static_vegn_init',& - 'Input file "'//trim(actual_input_file)//'" lacks record dimension.', FATAL) + input_is_multiface = .TRUE. endif - __NF_ASRT__(nf_inq_dimname ( ncid, unlimdim, dimname )) - __NF_ASRT__(nf_inq_varid ( ncid, dimname, timeid )) - __NF_ASRT__(nf_inq_dimlen( ncid, unlimdim, timelen )) - allocate (time_line(timelen), t(timelen)) - __NF_ASRT__(nf_get_var_double (ncid, timeid, t )) - - ! GET UNITS OF THE TIME - units = ' ' - if (nf_get_att_text(ncid, timeid,'units',units)/=NF_NOERR) then - call error_mesg('static_vegn_init',& - 'Cannot read time units from file "'//trim(actual_input_file)//'"', FATAL) - endif - - ! GET CALENDAR OF THE DATA - calendar = ' ' - iret = nf_get_att_text(ncid, timeid, 'calendar',calendar) - if(iret/=NF_NOERR) & - iret = nf_get_att_text(ncid, timeid,'calendar_type',calendar) - if(iret/=NF_NOERR) & - calendar='JULIAN' ! use model calendar? how to get the name of the model calendar? - - ! CONVERT TIME TO THE FMS TIME_TYPE AND STORE IT IN THE TIMELINE FOR THE - ! DATA SET - do i = 1, size(t) - ! set the respective value in the timeline - time_line(i) = get_cal_time(t(i),units,calendar) - enddo + endif - ! READ HORIZONTAL COORDINATES - iret = nfu_inq_compressed_var(ncid,'species',ndims=ndims,dimids=dimids,dimlens=dimlens,& - has_records=has_records) - if (iret/=NF_NOERR) then - call error_mesg('static_vegn_init',& - 'Cannot read compression information from file "'//trim(actual_input_file)//& - '": check that all dimensions listed in "compress" attributes are present in the file.', FATAL) - endif - __NF_ASRT__(iret) - allocate(in_lon(dimlens(1)),in_lat(dimlens(2))) - __NF_ASRT__(nfu_get_dim(ncid,dimids(1),in_lon)) ! get longitude - __NF_ASRT__(nfu_get_dim(ncid,dimids(2),in_lat)) ! get latitude - in_lon = in_lon*PI/180.0 ; in_lat = in_lat*PI/180.0 - - ! COMPUTE INDEX REMAPPING ARRAY - allocate(map_i(lnd%ls:lnd%le)) - allocate(map_j(lnd%ls:lnd%le)) + units = ' ' + calendar = 'JULIAN' + + ! READ TIME AXIS DATA + ! GET UNITS OF THE TIME AND CALENDAR OF THE DATA + ! CONVERT TIME TO THE FMS TIME_TYPE AND STORE IT IN THE TIMELINE FOR THE DATA SET + ! READ HORIZONTAL COORDINATES + if (input_is_multiface) then + call get_unlimited_dimension_name(fileobj_domainug, dimension_name) + call get_variable_attribute(fileobj_domainug, dimension_name, "units", units) + call get_variable_attribute(fileobj_domainug, dimension_name, "calendar", calendar) + call get_dimension_size(fileobj_domainug, dimension_name, dimlens(5)) + call get_dimension_size(fileobj_domainug, "lon", dimlens(1)) + call get_dimension_size(fileobj_domainug, "lat", dimlens(2)) + else + call get_unlimited_dimension_name(fileobj, dimension_name) + call get_variable_attribute(fileobj, dimension_name, "units", units) + call get_variable_attribute(fileobj, dimension_name, "calendar", calendar) + call get_dimension_size(fileobj, dimension_name, dimlens(5)) + call get_dimension_size(fileobj, "lon", dimlens(1)) + call get_dimension_size(fileobj, "lat", dimlens(2)) + endif + allocate(t(dimlens(5))) + allocate(time_line(dimlens(5))) + allocate(in_lon(dimlens(1))) + allocate(in_lat(dimlens(2))) + if (input_is_multiface) then + call read_data(fileobj_domainug, dimension_name, t) + call read_data(fileobj_domainug, "lon", in_lon) + call read_data(fileobj_domainug, "lat", in_lat) + else + call read_data(fileobj, dimension_name, t) + call read_data(fileobj, "lon", in_lon) + call read_data(fileobj, "lat", in_lat) + endif + do i = 1, dimlens(5) + ! set the respective value in the timeline + time_line(i) = get_cal_time(t(i), units, calendar) + enddo + in_lon = in_lon*PI/180.0 + in_lat = in_lat*PI/180.0 + + ! COMPUTE INDEX REMAPPING ARRAY + allocate(map_i(lnd%ls:lnd%le)) + allocate(map_j(lnd%ls:lnd%le)) + map_i = -1 + map_j = -1 + if( .not. input_is_multiface ) then allocate(mask(size(in_lon),size(in_lat))) - - map_i = -1 - map_j = -1 mask = .false. if(fill_land_mask) then - ! CALCULATE THE DIMENSIONS OF THE BUFFER FOR THE INPUT DATA - if (has_records) ndims=ndims-1 - do i = ndims+1,4 - dimlens(i) = 1 - enddo ! READ THE FIRST RECORD AND CALCULATE THE MASK OF THE VALID INPUT DATA - allocate(data(dimlens(1),dimlens(2),dimlens(3),dimlens(4))) - ! lon lat tile cohort - data(:,:,:,:) = -1 - __NF_ASRT__(nfu_get_compressed_rec(ncid,'species',1,data)) - do j = 1,size(data,2) - do i = 1,size(data,1) - mask(i,j) = any(data(i,j,:,:)>=0) - enddo + call get_dimension_size(fileobj, "tile", dimlens(3)) + call get_dimension_size(fileobj, "cohort", dimlens(4)) + + ! Note: The input file used for initial testing had + ! lon = 144, lat = 90, tile = 2, cohort = 1 + ndims = get_variable_num_dimensions(fileobj, "cohort_index") + allocate(siz(ndims)) + call get_variable_size(fileobj, "cohort_index", siz) + allocate(cidx(siz(1)), idata(siz(1))) + deallocate(siz) + call read_data(fileobj, 'cohort_index',cidx) !, unlim_dim_level=1) + call read_data(fileobj, 'species', idata, unlim_dim_level=1) + do n = 1,size(cidx) + m = cidx(n) + i = modulo(m,dimlens(1))+1 + m = m/dimlens(1) + j = modulo(m,dimlens(2))+1 + m = m/dimlens(2) + ! k = modulo(m,dimlens(3))+1 ! This is how to get tile number, if it were needed. + m = m/dimlens(3) + ! L = m+1 ! This is how to get cohort number, if it were needed. No need to do + ! modulo with dimlens(4) because at this point m is always < dimlens(4) + if(idata(n)>=0 .or. mask(i,j)) then + mask(i,j) = .TRUE. ! If species exists in any cohort of this grid cell then mask is .TRUE. + endif enddo - deallocate(data) + deallocate(idata) else mask(:,:) = .TRUE. endif @@ -461,7 +294,6 @@ subroutine static_vegn_init( ) endif deallocate (in_lon,in_lat) if(allocated(mask)) deallocate(mask) - deallocate(t) endif if(write_static_veg) & @@ -501,56 +333,65 @@ subroutine init_writing_static_veg() base_time = set_date(year, month, day, hour, minute, sec) write(units, 11) year, month, day, hour, minute, sec - if(new_land_io) then - call create_tile_out_file(static_veg_file, 'static_veg_out.nc', tidx, tile_dim_length) - call create_cohort_dimension_new(static_veg_file, cidx, 'static_veg_out.nc', tile_dim_length) - call fms_io_unstructured_register_restart_axis(static_veg_file, "static_veg_out.nc", & - "time",(/0.0/), "T", lnd%ug_domain, units=units, calendar=valid_calendar_types(get_calendar_type())) - k = fms_io_unstructured_register_restart_field(static_veg_file, "static_veg_out.nc", & - "species", species, (/HIDX/), lnd%ug_domain, longname="vegetation species") - k = fms_io_unstructured_register_restart_field(static_veg_file, "static_veg_out.nc", & - "bl", bl, (/HIDX/), lnd%ug_domain, longname="biomass of leaves per individual", units="kg C/m2") - k = fms_io_unstructured_register_restart_field(static_veg_file, "static_veg_out.nc", & - "blv", blv, (/HIDX/), lnd%ug_domain, longname="biomass of virtual leaves (labile store) per individual", units="kg C/m2") - k = fms_io_unstructured_register_restart_field(static_veg_file, "static_veg_out.nc", & - "br", br, (/HIDX/), lnd%ug_domain, longname="biomass of fine roots per individual", units="kg C/m2") - k = fms_io_unstructured_register_restart_field(static_veg_file, "static_veg_out.nc", & - "bsw", bsw, (/HIDX/), lnd%ug_domain, longname="biomass of sapwood per individual", units="kg C/m2") - k = fms_io_unstructured_register_restart_field(static_veg_file, "static_veg_out.nc", & - "bwood", bwood, (/HIDX/), lnd%ug_domain, longname="biomass of heartwood per individual", units="kg C/m2") - k = fms_io_unstructured_register_restart_field(static_veg_file, "static_veg_out.nc", & - "bliving", bliving, (/HIDX/), lnd%ug_domain, longname="total living biomass per individual", units="") - k = fms_io_unstructured_register_restart_field(static_veg_file, "static_veg_out.nc", & - "status", status, (/HIDX/), lnd%ug_domain, longname="leaf status", units="") - call fms_io_unstructured_save_restart(static_veg_file, directory="", time_level=-1.0) - else - call create_tile_out_file(ncid2,'static_veg_out.nc', tidx, tile_dim_length, & - lnd%coord_glon, lnd%coord_glat) - ! create compressed dimension for vegetation cohorts - call create_cohort_dimension_orig(ncid2, cidx, tile_dim_length) - ! get the base date of the simulation - if(mpp_pe()==lnd%io_pelist(1)) then - ! create time axis, on root IO processors only - __NF_ASRT__(nfu_def_dim(ncid2,'time',NF_UNLIMITED,NF_DOUBLE,units=trim(units))) - ! add calendar attribute to the time axis - iret=nfu_put_att(ncid2,'time','calendar',trim(valid_calendar_types(get_calendar_type()))) - __NF_ASRT__(iret) - endif - endif + call create_tile_out_file(static_veg_file, 'static_veg_out.nc', tidx, tile_dim_length) + call create_cohort_dimension_new(static_veg_file, cidx, 'static_veg_out.nc', tile_dim_length) + + call register_axis(static_veg_file, "time", unlimited) + call register_field(static_veg_file, "time", "double", (/"time"/)) + call register_variable_attribute(static_veg_file, "time", "units", trim(units), str_len=len(trim(units))) + call register_variable_attribute(static_veg_file, "time", "calendar", trim(valid_calendar_types(get_calendar_type())), & + str_len=len(trim(valid_calendar_types(get_calendar_type())))) + + call register_restart_field(static_veg_file, "species", species, (/"cohort_index"/)) + call register_variable_attribute(static_veg_file, "species", "long_name", "vegetation species", & + str_len=len(trim("vegetation species"))) + + call register_restart_field(static_veg_file, "bl", bl, (/"cohort_index"/)) + call register_variable_attribute(static_veg_file, "bl", "long_name", "biomass of leaves per individual", & + str_len=len(trim("biomass of leaves per individual"))) + call register_variable_attribute(static_veg_file, "bl", "units", "kg C/m2", str_len=len(trim("kg C/m2"))) + + call register_restart_field(static_veg_file, "blv", blv, (/"cohort_index"/)) + call register_variable_attribute(static_veg_file, "blv", "long_name", "biomass of virtual leaves (labile store) per individual", & + str_len=len(trim("biomass of virtual leaves (labile store) per individual"))) + call register_variable_attribute(static_veg_file, "blv", "units", "kg C/m2", str_len=len(trim("kg C/m2"))) + + call register_restart_field(static_veg_file, "br", br, (/"cohort_index"/)) + call register_variable_attribute(static_veg_file, "br", "long_name", "biomass of fine roots per individual", & + str_len=len(trim("biomass of fine roots per individual"))) + call register_variable_attribute(static_veg_file, "br", "units", "kg C/m2", str_len=len(trim("kg C/m2"))) + + call register_restart_field(static_veg_file, "bsw", bsw, (/"cohort_index"/)) + call register_variable_attribute(static_veg_file, "bsw", "long_name", "biomass of sapwood per individual", & + str_len=len(trim("biomass of sapwood per individual"))) + call register_variable_attribute(static_veg_file, "bsw", "units", "kg C/m2", str_len=len(trim("kg C/m2"))) + + call register_restart_field(static_veg_file, "bwood", bwood, (/"cohort_index"/)) + call register_variable_attribute(static_veg_file, "bwood", "long_name", "biomass of heartwood per individual", & + str_len=len(trim("biomass of heartwood per individual"))) + call register_variable_attribute(static_veg_file, "bwood", "units", "kg C/m2", str_len=len(trim("kg C/m2"))) + + call register_restart_field(static_veg_file, "bliving", bliving, (/"cohort_index"/)) + call register_variable_attribute(static_veg_file, "bliving", "long_name", "total living biomass per individual", & + str_len=len(trim("total living biomass per individual"))) + call register_variable_attribute(static_veg_file, "bliving", "units", "", str_len=len(trim(""))) + + call register_restart_field(static_veg_file, "status", status, (/"cohort_index"/)) + call register_variable_attribute(static_veg_file, "status", "long_name", "leaf status", str_len=len(trim("leaf status"))) + call register_variable_attribute(static_veg_file, "status", "units", "", str_len=len(trim(""))) + 11 format('days since ', i4.4, '-', i2.2, '-', i2.2, ' ', i2.2, ':', i2.2, ':', i2.2) end subroutine init_writing_static_veg ! =========================================================================== subroutine static_vegn_end() - - if(new_land_io) return - - if(use_static_veg) then - __NF_ASRT__(nf_close(ncid)) - deallocate(time_line,map_i,map_j) - endif - if(write_static_veg .and. mpp_pe()==lnd%io_pelist(1) ) then - __NF_ASRT__(nf_close(ncid2)) + if (use_static_veg) then + if (input_is_multiface) then + call close_file(fileobj_domainug) + else + call close_file(fileobj) + endif + call close_file(static_veg_file) endif module_is_initialized = .false. end subroutine static_vegn_end @@ -564,9 +405,10 @@ subroutine read_static_vegn (time, err_msg) integer :: index1, index2 ! result of time interpolation (only index1 is used) real :: weight ! another result of time interp, not used character(len=256) :: msg - integer :: siz(4) + integer,dimension(:), allocatable :: siz integer, allocatable :: cidx(:), idata(:) real, allocatable :: rdata(:) + integer :: ndims if(.not.use_static_veg)return; @@ -586,98 +428,54 @@ subroutine read_static_vegn (time, err_msg) endif ! read the data into cohort variables - if(new_land_io) then - if(input_is_multiface) then - call fms_io_unstructured_get_field_size(trim(input_file), "cohort_index", siz, lnd%ug_domain) - allocate(cidx(siz(1)), idata(siz(1)), rdata(siz(1))) - call fms_io_unstructured_read(trim(input_file), "cohort_index", cidx, lnd%ug_domain, timelevel=index1) - call fms_io_unstructured_read(trim(input_file), "species", idata, lnd%ug_domain, timelevel=index1) - call read_remap_cohort_data_i0d_new(Fields(ispecies), cohort_species_ptr, map_i, map_j, cidx, idata) - call fms_io_unstructured_read(trim(input_file), "bl", rdata, lnd%ug_domain, timelevel=index1) - call read_remap_cohort_data_r0d_new(Fields(ibl), cohort_bl_ptr, map_i, map_j, cidx, rdata) - call fms_io_unstructured_read(trim(input_file), "blv", rdata, lnd%ug_domain, timelevel=index1) - call read_remap_cohort_data_r0d_new(Fields(iblv), cohort_blv_ptr, map_i, map_j, cidx, rdata) - call fms_io_unstructured_read(trim(input_file), "br", rdata, lnd%ug_domain, timelevel=index1) - call read_remap_cohort_data_r0d_new(Fields(ibr), cohort_br_ptr, map_i, map_j, cidx, rdata) - call fms_io_unstructured_read(trim(input_file), "bsw", rdata, lnd%ug_domain, timelevel=index1) - call read_remap_cohort_data_r0d_new(Fields(ibsw), cohort_bsw_ptr, map_i, map_j, cidx, rdata) - call fms_io_unstructured_read(trim(input_file), "bwood", rdata, lnd%ug_domain, timelevel=index1) - call read_remap_cohort_data_r0d_new(Fields(ibwood), cohort_bwood_ptr, map_i, map_j, cidx, rdata) - call fms_io_unstructured_read(trim(input_file), "bliving", rdata, lnd%ug_domain, timelevel=index1) - call read_remap_cohort_data_r0d_new(Fields(ibliving), cohort_bliving_ptr, map_i, map_j, cidx, rdata) - call fms_io_unstructured_read(trim(input_file), "status", idata, lnd%ug_domain, timelevel=index1) - call read_remap_cohort_data_i0d_new(Fields(istatus), cohort_status_ptr, map_i, map_j, cidx, idata) - deallocate(cidx, idata, rdata) - else - call get_field_size(trim(input_file), & - "cohort_index", & - siz, & - domain=lnd%sg_domain) - allocate(cidx(siz(1)), idata(siz(1)), rdata(siz(1))) - call read_compressed(trim(input_file), & - "cohort_index", & - cidx, & - domain=lnd%sg_domain, & - timelevel=index1) - call read_compressed(trim(input_file), & - "species", & - idata, & - domain=lnd%sg_domain, & - timelevel=index1) - call read_remap_cohort_data_i0d_new(Fields(ispecies), cohort_species_ptr, map_i, map_j, cidx, idata) - call read_compressed(trim(input_file), & - "bl", & - rdata, & - domain=lnd%sg_domain, & - timelevel=index1) - call read_remap_cohort_data_r0d_new(Fields(ibl), cohort_bl_ptr, map_i, map_j, cidx, rdata) - call read_compressed(trim(input_file), & - "blv", & - rdata, & - domain=lnd%sg_domain, & - timelevel=index1) - call read_remap_cohort_data_r0d_new(Fields(iblv), cohort_blv_ptr, map_i, map_j, cidx, rdata) - call read_compressed(trim(input_file), & - "br", & - rdata, & - domain=lnd%sg_domain, & - timelevel=index1) - call read_remap_cohort_data_r0d_new(Fields(ibr), cohort_br_ptr, map_i, map_j, cidx, rdata) - call read_compressed(trim(input_file), & - "bsw", & - rdata, & - domain=lnd%sg_domain, & - timelevel=index1) - call read_remap_cohort_data_r0d_new(Fields(ibsw), cohort_bsw_ptr, map_i, map_j, cidx, rdata) - call read_compressed(trim(input_file), & - "bwood", & - rdata, & - domain=lnd%sg_domain, & - timelevel=index1) - call read_remap_cohort_data_r0d_new(Fields(ibwood), cohort_bwood_ptr, map_i, map_j, cidx, rdata) - call read_compressed(trim(input_file), & - "bliving", & - rdata, & - domain=lnd%sg_domain, & - timelevel=index1) - call read_remap_cohort_data_r0d_new(Fields(ibliving), cohort_bliving_ptr, map_i, map_j, cidx, rdata) - call read_compressed(trim(input_file), & - "status", & - idata, & - domain=lnd%sg_domain, & - timelevel=index1) - call read_remap_cohort_data_i0d_new(Fields(istatus), cohort_status_ptr, map_i, map_j, cidx, idata) - deallocate(cidx, idata, rdata) - endif + if(input_is_multiface) then + ndims = get_variable_num_dimensions(fileobj_domainug, "cohort_index") + allocate(siz(ndims)) + call get_variable_size(fileobj_domainug, "cohort_index", siz) + allocate(cidx(siz(1)), idata(siz(1)), rdata(siz(1))) + deallocate(siz) + call read_data(fileobj_domainug, "cohort_index", cidx) + call read_data(fileobj_domainug, "species", idata, unlim_dim_level=index1) + call read_remap_cohort_data_i0d_new(fileobj_domainug, "species", cohort_species_ptr, map_i, map_j, cidx, idata) + call read_data(fileobj_domainug, "bl", rdata, unlim_dim_level=index1) + call read_remap_cohort_data_r0d_new(fileobj_domainug, "bl", cohort_bl_ptr, map_i, map_j, cidx, rdata) + call read_data(fileobj_domainug, "blv", rdata, unlim_dim_level=index1) + call read_remap_cohort_data_r0d_new(fileobj_domainug, "blv", cohort_blv_ptr, map_i, map_j, cidx, rdata) + call read_data(fileobj_domainug, "br", rdata, unlim_dim_level=index1) + call read_remap_cohort_data_r0d_new(fileobj_domainug, "br", cohort_br_ptr, map_i, map_j, cidx, rdata) + call read_data(fileobj_domainug, "bsw", rdata, unlim_dim_level=index1) + call read_remap_cohort_data_r0d_new(fileobj_domainug, "bsw", cohort_bsw_ptr, map_i, map_j, cidx, rdata) + call read_data(fileobj_domainug, "bwood", rdata, unlim_dim_level=index1) + call read_remap_cohort_data_r0d_new(fileobj_domainug, "bwood", cohort_bwood_ptr, map_i, map_j, cidx, rdata) + call read_data(fileobj_domainug, "bliving", rdata, unlim_dim_level=index1) + call read_remap_cohort_data_r0d_new(fileobj_domainug, "bliving", cohort_bliving_ptr, map_i, map_j, cidx, rdata) + call read_data(fileobj_domainug, "status", idata, unlim_dim_level=index1) + call read_remap_cohort_data_i0d_new(fileobj_domainug, "status", cohort_status_ptr, map_i, map_j, cidx, idata) + deallocate(cidx, idata, rdata) else - call read_remap_cohort_data_i0d_fptr(ncid, 'species' , cohort_species_ptr , map_i, map_j, index1) - call read_remap_cohort_data_r0d_fptr(ncid, 'bl' , cohort_bl_ptr , map_i, map_j, index1) - call read_remap_cohort_data_r0d_fptr(ncid, 'blv' , cohort_blv_ptr , map_i, map_j, index1) - call read_remap_cohort_data_r0d_fptr(ncid, 'br' , cohort_br_ptr , map_i, map_j, index1) - call read_remap_cohort_data_r0d_fptr(ncid, 'bsw' , cohort_bsw_ptr , map_i, map_j, index1) - call read_remap_cohort_data_r0d_fptr(ncid, 'bwood' , cohort_bwood_ptr , map_i, map_j, index1) - call read_remap_cohort_data_r0d_fptr(ncid, 'bliving' , cohort_bliving_ptr , map_i, map_j, index1) - call read_remap_cohort_data_i0d_fptr(ncid, 'status' , cohort_status_ptr , map_i, map_j, index1) + ndims = get_variable_num_dimensions(fileobj, "cohort_index") + allocate(siz(ndims)) + call get_variable_size(fileobj, "cohort_index", siz) + allocate(cidx(siz(1)), idata(siz(1)), rdata(siz(1))) + deallocate(siz) + call read_data(fileobj, "cohort_index", cidx) + call read_data(fileobj, "species", idata, unlim_dim_level=index1) + call read_remap_cohort_data_i0d_new(fileobj, "species", cohort_species_ptr, map_i, map_j, cidx, idata) + call read_data(fileobj, "bl", rdata, unlim_dim_level=index1) + call read_remap_cohort_data_r0d_new(fileobj, "bl", cohort_bl_ptr, map_i, map_j, cidx, rdata) + call read_data(fileobj, "blv", rdata, unlim_dim_level=index1) + call read_remap_cohort_data_r0d_new(fileobj, "blv", cohort_blv_ptr, map_i, map_j, cidx, rdata) + call read_data(fileobj, "br", rdata, unlim_dim_level=index1) + call read_remap_cohort_data_r0d_new(fileobj, "br", cohort_br_ptr, map_i, map_j, cidx, rdata) + call read_data(fileobj, "bsw", rdata, unlim_dim_level=index1) + call read_remap_cohort_data_r0d_new(fileobj, "bsw", cohort_bsw_ptr, map_i, map_j, cidx, rdata) + call read_data(fileobj, "bwood", rdata, unlim_dim_level=index1) + call read_remap_cohort_data_r0d_new(fileobj, "bwood", cohort_bwood_ptr, map_i, map_j, cidx, rdata) + call read_data(fileobj, "bliving", rdata, unlim_dim_level=index1) + call read_remap_cohort_data_r0d_new(fileobj, "bliving", cohort_bliving_ptr, map_i, map_j, cidx, rdata) + call read_data(fileobj, "status", idata, unlim_dim_level=index1) + call read_remap_cohort_data_i0d_new(fileobj, "status", cohort_status_ptr, map_i, map_j, cidx, idata) + deallocate(cidx, idata, rdata) endif ! derived variables will be updated in update_land_bc_fast @@ -711,46 +509,11 @@ subroutine write_static_vegn() call gather_cohort_data(cohort_bwood_ptr,cidx,tile_dim_length,bwood) call gather_cohort_data(cohort_bliving_ptr,cidx,tile_dim_length,bliving) call gather_cohort_data(cohort_status_ptr,cidx,tile_dim_length,status) - if(new_land_io) then - call fms_io_unstructured_save_restart(static_veg_file, directory="", append=.true., time_level=t) - else - ! get the current number of records in the output file, rec is only needed by the io_pelist root pe. - rec = 0 - ! create new record in the output file and store current value of time - if(mpp_pe()==lnd%io_pelist(1)) then - __NF_ASRT__(nfu_inq_dim(ncid2,'time',rec)) - rec = rec+1 - __NF_ASRT__(nfu_put_rec(ncid2,'time',rec,t)) - endif - ! write static vegetation data - call write_cohort_data_i0d(ncid2,'species', species, 'vegetation species',record=rec) - call write_cohort_data_r0d(ncid2,'bl', bl, & - 'biomass of leaves per individual','kg C/m2', record=rec) - call write_cohort_data_r0d(ncid2,'blv', blv, & - 'biomass of virtual leaves (labile store) per individual','kg C/m2',record=rec) - call write_cohort_data_r0d(ncid2,'br', br, & - 'biomass of fine roots per individual','kg C/m2', record=rec) - call write_cohort_data_r0d(ncid2,'bsw', bsw, & - 'biomass of sapwood per individual','kg C/m2', record=rec) - call write_cohort_data_r0d(ncid2,'bwood', bwood, & - 'biomass of heartwood per individual','kg C/m2', record=rec) - call write_cohort_data_r0d(ncid2,'bliving', bliving, & - 'total living biomass per individual','kg C/m2', record=rec) - call write_cohort_data_i0d(ncid2,'status', status, & - 'leaf status', record=rec) - endif + call write_restart(static_veg_file) +! call write_restart(static_veg_file, unlim_dim_level=t) end subroutine write_static_vegn -! ============================================================================ -#define F90_TYPE integer -#define READ_REMAP_SUB read_remap_cohort_data_i0d_fptr -#include "read_remap_cohort_data.inc" - -#define F90_TYPE real -#define READ_REMAP_SUB read_remap_cohort_data_r0d_fptr -#include "read_remap_cohort_data.inc" - ! ============================================================================ #define F90_TYPE integer #define READ_REMAP_SUB read_remap_cohort_data_i0d_new