Skip to content
New issue

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

Sign up for GitHub

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

Already on GitHub? Sign in to your account

Jump to bottom

Ascii io #706

Merged
merged 9 commits into from
Mar 26, 2021
Merged

Ascii io #706

Show file tree
Hide file tree
Changes from 3 commits
Commits
Show all changes
9 commits
Select commit Hold shift + click to select a range
3d9b903
Added ascii_read subroutine to fms_io_utils in fms2_io plus testing
GFDL-Eric Dec 29, 2020
8770540
Updated fms2_io to include parse_mask_table
GFDL-Eric Mar 4, 2021
579e7d5
moved get_mosaic_tile_file to fms2_io
GFDL-Eric Mar 11, 2021
e9b70ed
Added doxygen to new subroutines and functions
GFDL-Eric Mar 12, 2021
406370c
Fixed several errors
GFDL-Eric Mar 12, 2021
c7f47fe
Edited parse_mask_table to work, edited test_read_ascii to actually t…
GFDL-Eric Mar 16, 2021
50c2dd9
Added error checks in to parse_mask_table and reworked the test_read_…
GFDL-Eric Mar 17, 2021
72f06af
updated input_nml_file to use get_ascii_file_num_lines_and_length
GFDL-Eric Mar 22, 2021
a85eca0
Merge branch 'main' into ascii_io
rem1776 Mar 26, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
12 changes: 7 additions & 5 deletions data_override/data_override.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -62,15 +62,14 @@ module data_override_mod
NO_REGION, INSIDE_REGION, OUTSIDE_REGION, &
get_external_fileobj
use fms_mod, only: write_version_number, field_exist, lowercase, check_nml_error
use fms_io_mod, only: fms_io_init, get_mosaic_tile_file
use axis_utils_mod, only: get_axis_bounds
use axis_utils2_mod, only : nearest_index, axis_edges
use fms_io_mod, only: fms_io_init, get_mosaic_tile_file_classic=>get_mosaic_tile_file
use mpp_domains_mod, only : domain2d, mpp_get_compute_domain, NULL_DOMAIN2D,operator(.NE.),operator(.EQ.)
use mpp_domains_mod, only : mpp_get_global_domain, mpp_get_data_domain
use mpp_domains_mod, only : domainUG, mpp_pass_SG_to_UG, mpp_get_UG_SG_domain, NULL_DOMAINUG
use time_manager_mod, only: time_type
use fms2_io_mod, only : FmsNetcdfFile_t, open_file, close_file, &
read_data, fms2_io_init, variable_exists
read_data, fms2_io_init, variable_exists, &
get_mosaic_tile_file_fms2_io=>get_mosaic_tile_file
use get_grid_version_mpp_mod, only: get_grid_version_classic_1, get_grid_version_classic_2
use get_grid_version_fms2io_mod, only: get_grid_version_1, get_grid_version_2

Expand Down Expand Up @@ -877,7 +876,10 @@ subroutine data_override_3d(gridname,fieldname_code,data,time,override,data_inde
! Allow on-grid data_overrides on cubed sphere grid
inquire(file=trim(filename),EXIST=exists)
if (.not. exists) then
call get_mosaic_tile_file(filename,filename2,.false.,domain)
if (use_mpp_bug) then
GFDL-Eric marked this conversation as resolved.
Show resolved Hide resolved
call get_mosaic_tile_file_classic(filename,filename2,.false.,domain)
else
call get_mosaic_tile_file_fms2_io(filename,filename2,.false.,domain)
filename = filename2
endif

Expand Down
1 change: 1 addition & 0 deletions fms2_io/fms2_io.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -85,6 +85,7 @@ module fms2_io_mod
public :: is_dimension_registered
public :: fms2_io_init
public :: get_mosaic_tile_grid
public :: ascii_read

interface open_file
module procedure netcdf_file_open_wrap
Expand Down
265 changes: 265 additions & 0 deletions fms2_io/fms_io_utils.F90
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -22,6 +22,7 @@
!! @email gfdl.climate.model.info@noaa.gov
module fms_io_utils_mod
use, intrinsic :: iso_fortran_env, only: error_unit
!use mpp_mod, only : get_ascii_file_num_lines_and_length, read_ascii_file
#ifdef _OPENMP
use omp_lib
#endif
Expand All @@ -48,6 +49,9 @@ module fms_io_utils_mod
public :: open_check
public :: string_compare
public :: restart_filepath_mangle
public :: ascii_read
public :: parse_mask_table
public :: get_mosaic_tile_file

!> @brief A linked list of strings
type :: char_linked_list
Expand All @@ -56,6 +60,16 @@ module fms_io_utils_mod
endtype char_linked_list


interface parse_mask_table
module procedure parse_mask_table_2d
module procedure parse_mask_table_3d
end interface parse_mask_table

interface get_mosaic_tile_file
module procedure get_mosaic_tile_file_sg
module procedure get_mosaic_tile_file_ug
end interface get_mosaic_tile_file

interface allocate_array
module procedure allocate_array_i4_kind_1d
module procedure allocate_array_i4_kind_2d
Expand Down Expand Up @@ -456,6 +470,257 @@ subroutine open_check(flag, fname)
endif
end subroutine open_check

subroutine ascii_read(ascii_filename, ascii_var)
wrongkindofdoctor marked this conversation as resolved.
Show resolved Hide resolved
character(len=*), intent(in) :: ascii_filename
character(len=:), dimension(:), allocatable, intent(out) :: ascii_var
integer, dimension(2) :: lines_and_length !lines = 1, length = 2
lines_and_length = get_ascii_file_num_lines_and_length(ascii_filename)
allocate(character(len=lines_and_length(2))::ascii_var(lines_and_length(1)))
call read_ascii_file(ascii_filename, lines_and_length(2), ascii_var)
end subroutine ascii_read

subroutine parse_mask_table_2d(mask_table, maskmap, modelname)

character(len=*), intent(in) :: mask_table
logical, intent(out) :: maskmap(:,:)
character(len=*), intent(in) :: modelname
integer :: nmask, layout(2)
integer, allocatable :: mask_list(:,:)
character(len=:), dimension(:), allocatable :: mask_table_contents !< Content array
integer :: mystat, n, stdoutunit
character(len=128) :: record

maskmap = .true.
nmask = 0
stdoutunit = stdout()
call ascii_read(mask_table, mask_table_contents)
if( mpp_pe() == mpp_root_pe() ) then
read(mask_table_contents, FMT=*, IOSTAT=mystat) nmask
write(stdoutunit,*)"parse_mask_table: Number of domain regions masked in ", trim(modelname), " = ", nmask
if( nmask > 0 ) then
!--- read layout from mask_table and confirm it matches the shape of maskmap
read(mask_table_contents, FMT=*, IOSTAT=mystat) layout
GFDL-Eric marked this conversation as resolved.
Show resolved Hide resolved
if( (layout(1) .NE. size(maskmap,1)) .OR. (layout(2) .NE. size(maskmap,2)) )then
write(stdoutunit,*)"layout=", layout, ", size(maskmap) = ", size(maskmap,1), size(maskmap,2)
call mpp_error(FATAL, "fms2_io(parse_mask_table_2d): layout in file "//trim(mask_table)// &
"does not match size of maskmap for "//trim(modelname))
endif
!--- make sure mpp_npes() == layout(1)*layout(2) - nmask
if( mpp_npes() .NE. layout(1)*layout(2) - nmask ) call mpp_error(FATAL, &
"fms2_io(parse_mask_table_2d): mpp_npes() .NE. layout(1)*layout(2) - nmask for "//trim(modelname))
endif
endif

call mpp_broadcast(nmask, mpp_root_pe())

if(nmask==0) return

allocate(mask_list(nmask,2))

if( mpp_pe() == mpp_root_pe() ) then
n = 0
do while( .true. )
read(mask_table_contents,'(a)',end=999) record
if (record(1:1) == '#') cycle
if (record(1:10) == ' ') cycle
n = n + 1
if( n > nmask ) then
call mpp_error(FATAL, "fms2_io(parse_mask_table_2d): number of mask_list entry "// &
"is greater than nmask in file "//trim(mask_table) )
endif
read(record,*,err=888) mask_list(n,1), mask_list(n,2)
enddo
888 call mpp_error(FATAL, "fms2_io(parse_mask_table_2d): Error in reading mask_list from file "//trim(mask_table))

999 continue
!--- make sure the number of entry for mask_list is nmask
if( n .NE. nmask) call mpp_error(FATAL, &
"fms2_io(parse_mask_table_2d): number of mask_list entry does not match nmask in file "//trim(mask_table))
endif

call mpp_broadcast(mask_list, 2*nmask, mpp_root_pe())
do n = 1, nmask
if(debug_mask_list) then
GFDL-Eric marked this conversation as resolved.
Show resolved Hide resolved
write(stdoutunit,*) "==>NOTE from parse_mask_table_2d: ", trim(modelname), " mask_list = ", mask_list(n,1), mask_list(n,2)
endif
maskmap(mask_list(n,1),mask_list(n,2)) = .false.
enddo

deallocate(mask_list)

end subroutine parse_mask_table_2d


!#######################################################################
subroutine parse_mask_table_3d(mask_table, maskmap, modelname)
wrongkindofdoctor marked this conversation as resolved.
Show resolved Hide resolved
wrongkindofdoctor marked this conversation as resolved.
Show resolved Hide resolved

character(len=*), intent(in) :: mask_table
logical, intent(out) :: maskmap(:,:,:)
character(len=*), intent(in) :: modelname
integer :: nmask, layout(2)
integer, allocatable :: mask_list(:,:)
character(len=:), dimension(:), allocatable :: mask_table_contents !< Content array
integer :: mystat, n, stdoutunit, ntiles
character(len=128) :: record

maskmap = .true.
nmask = 0
stdoutunit = stdout()
call ascii_read(mask_table, mask_table_contents)
if( mpp_pe() == mpp_root_pe() ) then
read(mask_table_contents, FMT=*, IOSTAT=mystat) nmask
write(stdoutunit,*)"parse_mask_table: Number of domain regions masked in ", trim(modelname), " = ", nmask
if( nmask > 0 ) then
!--- read layout from mask_table and confirm it matches the shape of maskmap
read(mask_table_contents, FMT=*, IOSTAT=mystat) layout(1), layout(2), ntiles
if( (layout(1) .NE. size(maskmap,1)) .OR. (layout(2) .NE. size(maskmap,2)) )then
write(stdoutunit,*)"layout=", layout, ", size(maskmap) = ", size(maskmap,1), size(maskmap,2)
call mpp_error(FATAL, "fms2_io(parse_mask_table_3d): layout in file "//trim(mask_table)// &
"does not match size of maskmap for "//trim(modelname))
endif
if( ntiles .NE. size(maskmap,3) ) then
write(stdoutunit,*)"ntiles=", ntiles, ", size(maskmap,3) = ", size(maskmap,3)
call mpp_error(FATAL, "fms2_io(parse_mask_table_3d): ntiles in file "//trim(mask_table)// &
"does not match size of maskmap for "//trim(modelname))
endif
!--- make sure mpp_npes() == layout(1)*layout(2) - nmask
if( mpp_npes() .NE. layout(1)*layout(2)*ntiles - nmask ) then
print*, "layout=", layout, nmask, mpp_npes()
call mpp_error(FATAL, &
"fms2_io(parse_mask_table_3d): mpp_npes() .NE. layout(1)*layout(2) - nmask for "//trim(modelname))
endif
endif
endif

call mpp_broadcast(nmask, mpp_root_pe())

if(nmask==0) return

allocate(mask_list(nmask,3))

if( mpp_pe() == mpp_root_pe() ) then
n = 0
do while( .true. )
read(mask_table_contents,'(a)',end=999) record
if (record(1:1) == '#') cycle
if (record(1:10) == ' ') cycle
n = n + 1
if( n > nmask ) then
call mpp_error(FATAL, "fms2_io(parse_mask_table_3d): number of mask_list entry "// &
"is greater than nmask in file "//trim(mask_table) )
endif
read(record,*,err=888) mask_list(n,1), mask_list(n,2), mask_list(n,3)
enddo
888 call mpp_error(FATAL, "fms2_io(parse_mask_table_3d): Error in reading mask_list from file "//trim(mask_table))

999 continue
!--- make sure the number of entry for mask_list is nmask
if( n .NE. nmask) call mpp_error(FATAL, &
"fms2_io(parse_mask_table_3d): number of mask_list entry does not match nmask in file "//trim(mask_table))
! call mpp_close(unit)
endif

call mpp_broadcast(mask_list, 3*nmask, mpp_root_pe())
do n = 1, nmask
if(debug_mask_list) then
write(stdoutunit,*) "==>NOTE from parse_mask_table_3d: ", trim(modelname), " mask_list = ", &
mask_list(n,1), mask_list(n,2), mask_list(n,3)
endif
maskmap(mask_list(n,1),mask_list(n,2),mask_list(n,3)) = .false.
enddo

deallocate(mask_list)

end subroutine parse_mask_table_3d

subroutine get_mosaic_tile_file_sg(file_in, file_out, is_no_domain, domain, tile_count)
character(len=*), intent(in) :: file_in
character(len=*), intent(out) :: file_out
logical, intent(in) :: is_no_domain
type(domain2D), intent(in), optional, target :: domain
integer, intent(in), optional :: tile_count
character(len=256) :: basefile, tilename
integer :: lens, ntiles, ntileMe, tile, my_tile_id
integer, dimension(:), allocatable :: tile_id
type(domain2d), pointer, save :: d_ptr =>NULL()
logical :: domain_exist

if(index(file_in, '.nc', back=.true.)==0) then
basefile = trim(file_in)
else
lens = len_trim(file_in)
if(file_in(lens-2:lens) .NE. '.nc') call mpp_error(FATAL, &
'fms_io_mod: .nc should be at the end of file '//trim(file_in))
basefile = file_in(1:lens-3)
end if

!--- get the tile name
ntiles = 1
my_tile_id = 1
domain_exist = .false.
if(PRESENT(domain))then
domain_exist = .true.
ntiles = mpp_get_ntile_count(domain)
d_ptr => domain
endif

if(domain_exist) then
ntileMe = mpp_get_current_ntile(d_ptr)
allocate(tile_id(ntileMe))
tile_id = mpp_get_tile_id(d_ptr)
tile = 1
if(present(tile_count)) tile = tile_count
my_tile_id = tile_id(tile)
endif

if(ntiles > 1 .or. my_tile_id > 1 )then
tilename = 'tile'//string(my_tile_id)
GFDL-Eric marked this conversation as resolved.
Show resolved Hide resolved
if(index(basefile,'.'//trim(tilename),back=.true.) == 0)then
basefile = trim(basefile)//'.'//trim(tilename);
end if
end if
if(allocated(tile_id)) deallocate(tile_id)

file_out = trim(basefile)//'.nc'

d_ptr =>NULL()

end subroutine get_mosaic_tile_file_sg

subroutine get_mosaic_tile_file_ug(file_in, file_out, domain)
character(len=*), intent(in) :: file_in
character(len=*), intent(out) :: file_out
type(domainUG), intent(in), optional :: domain
character(len=256) :: basefile, tilename
integer :: lens, ntiles, my_tile_id

if(index(file_in, '.nc', back=.true.)==0) then
basefile = trim(file_in)
else
lens = len_trim(file_in)
if(file_in(lens-2:lens) .NE. '.nc') call mpp_error(FATAL, &
'fms_io_mod: .nc should be at the end of file '//trim(file_in))
basefile = file_in(1:lens-3)
end if

!--- get the tile name
ntiles = 1
my_tile_id = 1
if(PRESENT(domain))then
ntiles = mpp_get_UG_domain_ntiles(domain)
my_tile_id = mpp_get_UG_domain_tile_id(domain)
endif

if(ntiles > 1 .or. my_tile_id > 1 )then
tilename = 'tile'//string(my_tile_id)
if(index(basefile,'.'//trim(tilename),back=.true.) == 0)then
basefile = trim(basefile)//'.'//trim(tilename);
end if
end if

file_out = trim(basefile)//'.nc'

end subroutine get_mosaic_tile_file_ug

include "array_utils.inc"
include "array_utils_char.inc"
Expand Down
Loading