diff --git a/data_override/data_override.F90 b/data_override/data_override.F90 index 0f2d7a807d..8ce8838afe 100644 --- a/data_override/data_override.F90 +++ b/data_override/data_override.F90 @@ -62,15 +62,16 @@ 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 @@ -879,7 +880,11 @@ 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 + call get_mosaic_tile_file_classic(filename,filename2,.false.,domain) + else + call get_mosaic_tile_file_fms2_io(filename,filename2,.false.,domain) + endif filename = filename2 endif diff --git a/fms2_io/fms2_io.F90 b/fms2_io/fms2_io.F90 index 74a9cbd69f..dce8866ea1 100644 --- a/fms2_io/fms2_io.F90 +++ b/fms2_io/fms2_io.F90 @@ -86,6 +86,9 @@ module fms2_io_mod public :: write_restart_bc public :: read_restart_bc public :: get_mosaic_tile_grid +public :: ascii_read +public :: get_mosaic_tile_file +public :: parse_mask_table public :: get_filename_appendix public :: set_filename_appendix public :: get_instance_filename diff --git a/fms2_io/fms_io_utils.F90 b/fms2_io/fms_io_utils.F90 index 7dcd05c4c3..06685c04cc 100644 --- a/fms2_io/fms_io_utils.F90 +++ b/fms2_io/fms_io_utils.F90 @@ -22,10 +22,14 @@ !! @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 use mpp_mod +use mpp_domains_mod, only: domain2D, domainUG, mpp_get_ntile_count, & + mpp_get_current_ntile, mpp_get_tile_id, & + mpp_get_UG_domain_ntiles, mpp_get_UG_domain_tile_id use platform_mod implicit none private @@ -50,6 +54,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 public :: get_filename_appendix public :: set_filename_appendix public :: get_instance_filename @@ -62,6 +69,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 @@ -462,6 +479,316 @@ subroutine open_check(flag, fname) endif end subroutine open_check +!> @brief Read the ascii text from filename `ascii_filename`into string array +!! `ascii_var` +subroutine ascii_read(ascii_filename, ascii_var) + character(len=*), intent(in) :: ascii_filename !< The file name to be read + character(len=:), dimension(:), allocatable, intent(out) :: ascii_var !< The + !! string + !! array + 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 + +!> @brief Populate 2D maskmap from mask_table given a model +subroutine parse_mask_table_2d(mask_table, maskmap, modelname) + + character(len=*), intent(in) :: mask_table !< Mask table to be read in + logical, intent(out) :: maskmap(:,:) !< 2D Mask output + character(len=*), intent(in) :: modelname !< Model to which this applies + + integer :: nmask, layout(2) + integer, allocatable :: mask_list(:,:) + character(len=:), dimension(:), allocatable :: mask_table_contents + integer :: iocheck, n, stdoutunit, offset + 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(1), FMT=*, IOSTAT=iocheck) nmask + if (iocheck > 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_2d): Error in reading nmask from file variable") + elseif (iocheck < 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_2d): Error: nmask not completely read from file variable") + endif + 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(2), FMT=*, IOSTAT=iocheck) layout + if (iocheck > 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_2d): Error in reading layout from file variable") + elseif (iocheck < 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_2d): Error: layout not completely read from file variable") + endif + 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 + offset = 3 + do while (offset + n < size(mask_table_contents)+1) + read(mask_table_contents(n+offset),'(a)',iostat=iocheck) record + if (iocheck > 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_2d): Error in reading record from file variable") + elseif (iocheck < 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_2d): Error: record not completely read from file variable") + endif + if (record(1:1) == '#') then + offset = offset + 1 + cycle + elseif (record(1:10) == ' ') then + offset = offset + 1 + cycle + endif + 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,*,iostat=iocheck) mask_list(n,1), mask_list(n,2) + if (iocheck > 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_2d): Error in reading mask_list from record variable") + elseif (iocheck < 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_2d): Error: mask_list not completely read from record variable") + endif + enddo + + !--- 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 + maskmap(mask_list(n,1),mask_list(n,2)) = .false. + enddo + + deallocate(mask_list) + +end subroutine parse_mask_table_2d + + +!> @brief Populate 3D maskmap from mask_table given a model +subroutine parse_mask_table_3d(mask_table, maskmap, modelname) + + character(len=*), intent(in) :: mask_table !< Mask table to be read in + logical, intent(out) :: maskmap(:,:,:) !< 2D Mask output + character(len=*), intent(in) :: modelname !< Model to which this applies + + integer :: nmask, layout(2) + integer, allocatable :: mask_list(:,:) + character(len=:), dimension(:), allocatable :: mask_table_contents + integer :: iocheck, n, stdoutunit, ntiles, offset + 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(1), FMT=*, IOSTAT=iocheck) nmask + if (iocheck > 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_3d): Error in reading nmask from file variable") + elseif (iocheck < 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_3d): Error: nmask not completely read from file variable") + endif + 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(2), FMT=*, IOSTAT=iocheck) layout(1), layout(2), ntiles + if (iocheck > 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_3d): Error in reading layout from file variable") + elseif (iocheck < 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_3d): Error: layout not completely read from file variable") + endif + 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 + offset = 3 + do while (offset + n < size(mask_table_contents)+1) + read(mask_table_contents(n+offset),'(a)',iostat=iocheck) record + if (iocheck > 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_3d): Error in reading record from file variable") + elseif (iocheck < 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_3d): Error: record not completely read from file variable") + endif + if (record(1:1) == '#') then + offset = offset + 1 + cycle + elseif (record(1:10) == ' ') then + offset = offset + 1 + cycle + endif + 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,*,iostat=iocheck) mask_list(n,1), mask_list(n,2), mask_list(n,3) + if (iocheck > 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_3d): Error in reading mask_list from record variable") + elseif (iocheck < 0) then + call mpp_error(FATAL, "fms2_io(parse_mask_table_3d): Error: mask_list not completely read from record variable") + endif + enddo + + !--- 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 + maskmap(mask_list(n,1),mask_list(n,2),mask_list(n,3)) = .false. + enddo + + deallocate(mask_list) +end subroutine parse_mask_table_3d + +!> @brief Determine tile_file for structured grid based on filename and current +!! tile on mpp_domain (this is mostly used for ongrid data_overrides) +subroutine get_mosaic_tile_file_sg(file_in, file_out, is_no_domain, domain, tile_count) + character(len=*), intent(in) :: file_in !< name of 'base' file + character(len=*), intent(out) :: file_out !< name of tile_file + logical, intent(in) :: is_no_domain !< are we providing a + !! domain + type(domain2D), intent(in), optional, target :: domain !< domain provided + integer, intent(in), optional :: tile_count !< tile count + + character(len=256) :: basefile, tilename + character(len=1) :: my_tile_str + 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 + write(my_tile_str, '(I1)') my_tile_id + tilename = 'tile'//my_tile_str + 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 + +!> @brief Determine tile_file for unstructured grid based on filename and current +!! tile on mpp_domain (this is mostly used for ongrid data_overrides) +subroutine get_mosaic_tile_file_ug(file_in, file_out, domain) + character(len=*), intent(in) :: file_in !< name of base file + character(len=*), intent(out) :: file_out !< name of tile file + type(domainUG), intent(in), optional :: domain !< domain provided + + character(len=256) :: basefile, tilename + character(len=1) :: my_tile_str + 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 + write(my_tile_str, '(I1)') my_tile_id + tilename = 'tile'//my_tile_str + 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 + !> @brief Writes filename appendix to "string_out" subroutine get_filename_appendix(string_out) character(len=*) , intent(out) :: string_out !< String to write the filename_appendix to diff --git a/mpp/include/mpp_util.inc b/mpp/include/mpp_util.inc index 6da06d8057..893f4b97ee 100644 --- a/mpp/include/mpp_util.inc +++ b/mpp/include/mpp_util.inc @@ -1301,7 +1301,8 @@ end function rarray_to_char character(len=*), intent(in), optional :: pelist_name_in ! private variables integer :: log_unit - integer :: num_lines, i + integer :: i + integer, dimension(2) :: lines_and_length logical :: file_exist character(len=len(peset(current_peset_num)%name)) :: pelist_name character(len=128) :: filename @@ -1328,9 +1329,9 @@ end function rarray_to_char if (.not. file_exist ) then filename='input.nml' endif - num_lines = get_ascii_file_num_lines(filename, INPUT_STR_LENGTH) - allocate(input_nml_file(num_lines)) - call read_ascii_file(filename, INPUT_STR_LENGTH, input_nml_file) + lines_and_length = get_ascii_file_num_lines_and_length(filename) + allocate(character(len=lines_and_length(2))::input_nml_file(lines_and_length(1))) + call read_ascii_file(filename, lines_and_length(2), input_nml_file) ! write info logfile if (pe == root_pe) then @@ -1338,7 +1339,7 @@ end function rarray_to_char write(log_unit,'(a)') '========================================================================' write(log_unit,'(a)') 'READ_INPUT_NML: '//trim(version) write(log_unit,'(a)') 'READ_INPUT_NML: '//trim(filename)//' ' - do i = 1, num_lines + do i = 1, lines_and_length(1) write(log_unit,*) trim(input_nml_file(i)) enddo end if @@ -1408,6 +1409,76 @@ end function rarray_to_char end function get_ascii_file_num_lines + !####################################################################### + !> @brief Function to determine the maximum line length and number of lines from an ascii file + function get_ascii_file_num_lines_and_length(FILENAME, PELIST) + character(len=*), intent(in) :: FILENAME !< name of the file to be read + integer, intent(in), optional, dimension(:) :: PELIST !< optional pelist + + integer, dimension(2) :: get_ascii_file_num_lines_and_length !< number of lines (1) and + !! max line length (2) + integer :: num_lines, max_length + integer, parameter :: LENGTH=1024 + character(len=LENGTH) :: str_tmp + character(len=5) :: text + integer :: status, f_unit, from_pe + logical :: file_exist + + if( read_ascii_file_on) then + call mpp_error(FATAL, & + "mpp_util.inc: get_ascii_file_num_lines is called again before calling read_ascii_file") + endif + read_ascii_file_on = .true. + + from_pe = root_pe + get_ascii_file_num_lines_and_length = -1 + num_lines = -1 + max_length = -1 + if ( pe == root_pe ) then + inquire(FILE=FILENAME, EXIST=file_exist) + + if ( file_exist ) then + f_unit = get_unit() + open(UNIT=f_unit, FILE=FILENAME, ACTION='READ', STATUS='OLD', IOSTAT=status) + + if ( status .ne. 0 ) then + write (UNIT=text, FMT='(I5)') status + call mpp_error(FATAL, 'get_ascii_file_num_lines: Error opening file:' //trim(FILENAME)// & + '. (IOSTAT = '//trim(text)//')') + else + num_lines = 1 + do + read (UNIT=f_unit, FMT='(A)', IOSTAT=status) str_tmp + if ( status .lt. 0 ) exit + if ( status .gt. 0 ) then + write (UNIT=text, FMT='(I5)') num_lines + call mpp_error(FATAL, 'get_ascii_file_num_lines: Error reading line '//trim(text)// & + ' in file '//trim(FILENAME)//'.') + end if + if ( len_trim(str_tmp) == LENGTH ) then + write(UNIT=text, FMT='(I5)') length + call mpp_error(FATAL, 'get_ascii_file_num_lines: Length of output string ('//trim(text)//' is too small.& + & Increase the LENGTH value.') + end if + if (len_trim(str_tmp) > max_length) max_length = len_trim(str_tmp) + num_lines = num_lines + 1 + end do + close(UNIT=f_unit) + end if + else + call mpp_error(FATAL, 'get_ascii_file_num_lines: File '//trim(FILENAME)//' does not exist.') + end if + max_length = max_length+1 + end if + + ! Broadcast number of lines + call mpp_broadcast(num_lines, from_pe, PELIST=PELIST) + call mpp_broadcast(max_length, from_pe, PELIST=PELIST) + get_ascii_file_num_lines_and_length(1) = num_lines + get_ascii_file_num_lines_and_length(2) = max_length + + end function get_ascii_file_num_lines_and_length + !----------------------------------------------------------------------- ! ! AUTHOR: Rusty Benson , diff --git a/mpp/mpp.F90 b/mpp/mpp.F90 index 35d0e9b6d2..aa8d1bcf10 100644 --- a/mpp/mpp.F90 +++ b/mpp/mpp.F90 @@ -215,7 +215,7 @@ module mpp_mod public :: mpp_get_current_pelist, mpp_set_current_pelist, mpp_get_current_pelist_name public :: mpp_clock_id, mpp_clock_set_grain, mpp_record_timing_data, get_unit public :: read_ascii_file, read_input_nml, mpp_clock_begin, mpp_clock_end - public :: get_ascii_file_num_lines + public :: get_ascii_file_num_lines, get_ascii_file_num_lines_and_length public :: mpp_record_time_start, mpp_record_time_end !--- public interface from mpp_comm.h ------------------------------ @@ -1280,7 +1280,7 @@ module mpp_mod ! parameter defining length of character variables integer, parameter :: INPUT_STR_LENGTH = 256 ! public variable needed for reading input.nml from an internal file - character(len=INPUT_STR_LENGTH), dimension(:), allocatable, target, public :: input_nml_file + character(len=:), dimension(:), allocatable, target, public :: input_nml_file logical :: read_ascii_file_on = .FALSE. !*********************************************************************** diff --git a/test_fms/fms2_io/Makefile.am b/test_fms/fms2_io/Makefile.am index 83fdb49860..77b6e3bc35 100644 --- a/test_fms/fms2_io/Makefile.am +++ b/test_fms/fms2_io/Makefile.am @@ -30,7 +30,7 @@ LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. check_PROGRAMS = test_get_is_valid test_file_appendix test_fms2_io test_atmosphere_io test_io_simple test_io_with_mask test_global_att \ - test_bc_restart test_get_mosaic_tile_grid + test_bc_restart test_get_mosaic_tile_grid test_read_ascii_file # This is the source code for the test. test_get_is_valid_SOURCES = test_get_is_valid.F90 @@ -45,9 +45,10 @@ test_global_att_SOURCES = test_global_att.F90 test_io_with_mask_SOURCES=test_io_with_mask.F90 test_bc_restart_SOURCES=test_bc_restart.F90 test_get_mosaic_tile_grid_SOURCES=test_get_mosaic_tile_grid.F90 +test_read_ascii_file_SOURCES=test_read_ascii_file.F90 test_file_appendix_SOURCES=test_file_appendix.F90 -EXTRA_DIST = test_bc_restart.sh test_fms2_io.sh test_atmosphere_io.sh test_io_simple.sh test_global_att.sh test_io_with_mask.sh +EXTRA_DIST = test_bc_restart.sh test_fms2_io.sh test_atmosphere_io.sh test_io_simple.sh test_global_att.sh test_io_with_mask.sh test_read_ascii_file.sh argparse.mod: argparse.$(OBJEXT) setup.mod: setup.$(OBJEXT) @@ -57,7 +58,7 @@ test_io_simple.$(OBJEXT): setup.mod test_fms2_io.$(OBJEXT): argparse.mod # Run the test program. -TESTS = test_bc_restart.sh test_fms2_io.sh test_atmosphere_io.sh test_io_simple.sh test_io_with_mask.sh test_global_att.sh +TESTS = test_bc_restart.sh test_fms2_io.sh test_atmosphere_io.sh test_io_simple.sh test_io_with_mask.sh test_global_att.sh test_read_ascii_file.sh # skips tests that fail if using netCDF 4.7.4 if SKIP_FMS2_IO_TESTS @@ -70,4 +71,4 @@ endif TESTS_ENVIRONMENT = srcdir="$(top_srcdir)"; \ netcdf_version_skip=${skipflag} -CLEANFILES = *.mod *.nc *.nc.* input.nml logfile.000000.out the_mask +CLEANFILES = *.mod *.nc *.nc.* input.nml logfile.000000.out the_mask ascii_test1 diff --git a/test_fms/fms2_io/test_io_with_mask.F90 b/test_fms/fms2_io/test_io_with_mask.F90 index 9c38c77954..d5789fafc1 100644 --- a/test_fms/fms2_io/test_io_with_mask.F90 +++ b/test_fms/fms2_io/test_io_with_mask.F90 @@ -29,9 +29,9 @@ program test_io_with_mask mpp_get_compute_domain,domain2d use mpp_mod, only: mpp_pe, mpp_root_pe, mpp_error, FATAL use fms2_io_mod, only: open_file, register_axis, register_variable_attribute, close_file, & - FmsNetcdfDomainFile_t, write_data, register_field, read_data + FmsNetcdfDomainFile_t, write_data, register_field, read_data, & + parse_mask_table use fms_mod, only: fms_init, fms_end -use fms_io_mod, only: parse_mask_table use netcdf, only: nf90_open, nf90_get_var, nf90_nowrite, NF90_NOERR, nf90_get_var, & nf90_close use mpi, only: mpi_barrier, mpi_comm_world diff --git a/test_fms/fms2_io/test_io_with_mask.sh b/test_fms/fms2_io/test_io_with_mask.sh index 3929827106..1db317e260 100755 --- a/test_fms/fms2_io/test_io_with_mask.sh +++ b/test_fms/fms2_io/test_io_with_mask.sh @@ -40,7 +40,7 @@ touch input.nml # . ----- . ----- . # | (3,1) | (3,2) | # . ----- . ----- . -printf "\n1\n2,3\n1,1" | cat > the_mask +printf "1\n2,3\n1,1" | cat > the_mask # For example, if you have a grid that is 60 by 60 and a layout of 2,3 # You are going to need 6 ranks: diff --git a/test_fms/fms2_io/test_read_ascii_file.F90 b/test_fms/fms2_io/test_read_ascii_file.F90 new file mode 100644 index 0000000000..0b38fc8420 --- /dev/null +++ b/test_fms/fms2_io/test_read_ascii_file.F90 @@ -0,0 +1,51 @@ +!*********************************************************************** +!* 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 . +!*********************************************************************** + +!> @file +!! @brief Tests the read_ascii_file subroutine +!! @author Colin Gladue +!! @email gfdl.climate.model.info@noaa.gov + +program test_read_ascii_file + + use mpp_mod, only : mpp_init + use mpp_mod, only : mpp_error, FATAL, NOTE + use fms2_io_mod, only : fms2_io_init, ascii_read + + character(len=:), dimension(:), allocatable :: test_array !< Content array + character(len=256) :: filename !< Name of ascii file to be read + character(len=256) :: filename2 !< Name of alternative ascii file to be read + character(len=256) :: line !< Content of a line of the read ascii file + integer :: num_lines !< Number of lines in the ascii file + integer, dimension(2) :: stat !< IOSTATUS from the read method + integer, allocatable :: cur_pelist(:) !< PELIST is read into this variable + integer :: ierr !< used by MPI_FINALIZE + + call mpp_init() + call fms2_io_init() + filename = "ascii_test1" + call ascii_read(filename, test_array) + read(test_array(1), *) stat + if (stat(1)*6 - (stat(2)+3) /= 13) call mpp_error(FATAL, "test_read_ascii: failed to read integers") + read(test_array(2), *) num_lines + if (num_lines-11 /= 12) call mpp_error(FATAL, "test_read_ascii: failed to read integer") + read(test_array(3), *) line + if (trim(line)//"wut" /= "forlendulawut") call mpp_error(FATAL, "test_read_ascii: failed to read string") + call MPI_FINALIZE(ierr) +end program test_read_ascii_file diff --git a/test_fms/fms2_io/test_read_ascii_file.sh b/test_fms/fms2_io/test_read_ascii_file.sh new file mode 100755 index 0000000000..52f450583c --- /dev/null +++ b/test_fms/fms2_io/test_read_ascii_file.sh @@ -0,0 +1,31 @@ +#!/bin/sh + +#*********************************************************************** +#* 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 . +#*********************************************************************** + +# This is part of the GFDL FMS package. This is a shell script to +# execute tests in the test_fms/fms2_io directory. + +# Set common test settings. +. ../test_common.sh +# make an input.nml for mpp_init to read +printf "EOF\n&dummy\nEOF" | cat > input.nml +printf "5, 14 \n23\n\"forlendula\"" | cat > ascii_test1 +# run the tests +run_test test_read_ascii_file 6 $netcdf_version_skip