Skip to content
Open
Show file tree
Hide file tree
Changes from all commits
Commits
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
3 changes: 2 additions & 1 deletion src/core_test/Makefile
Original file line number Diff line number Diff line change
Expand Up @@ -12,7 +12,8 @@ OBJS = mpas_test_core.o \
mpas_test_core_dmpar.o \
mpas_test_core_stream_inquiry.o \
mpas_test_openacc.o \
mpas_test_core_stream_list.o
mpas_test_core_stream_list.o \
mpas_test_core_io.o \

all: core_test

Expand Down
12 changes: 12 additions & 0 deletions src/core_test/mpas_test_core.F
Original file line number Diff line number Diff line change
Expand Up @@ -97,6 +97,7 @@ function test_core_run(domain) result(iErr)!{{{
use test_core_string_utils, only : mpas_test_string_utils
use mpas_test_core_dmpar, only : mpas_test_dmpar
use mpas_test_core_stream_inquiry, only : mpas_test_stream_inquiry
use test_core_io, only : test_core_io_test
use mpas_test_core_openacc, only : mpas_test_openacc

implicit none
Expand Down Expand Up @@ -224,6 +225,17 @@ function test_core_run(domain) result(iErr)!{{{

call mpas_stream_mgr_write(domain % streamManager, forceWriteNow=.true.)

!
! Run io tests
!
call mpas_log_write('')
call test_core_io_test(domain, threadErrs, iErr)
if (iErr == 0) then
call mpas_log_write('All tests PASSED')
else
call mpas_log_write('$i tests FAILED', intArgs=[iErr])
end if
call mpas_log_write('')
!
! Run mpas_test_openacc
!
Expand Down
208 changes: 208 additions & 0 deletions src/core_test/mpas_test_core_io.F
Original file line number Diff line number Diff line change
@@ -0,0 +1,208 @@
! Copyright (c) 2013, Los Alamos National Security, LLC (LANS)
! and the University Corporation for Atmospheric Research (UCAR).
!
! Unless noted otherwise source code is licensed under the BSD license.
! Additional copyright and license information can be found in the LICENSE file
! distributed with this code, or at http://mpas-dev.github.com/license.html
!
module test_core_io

#define ERROR_WRITE(M) call mpas_log_write( M , messageType=MPAS_LOG_ERR)
#define ERROR_WRITE_ARGS(M, ARGS) call mpas_log_write( M , ARGS, messageType=MPAS_LOG_ERR)
use mpas_log
use mpas_io

implicit none
private
public :: test_core_io_test

contains

!***********************************************************************
!
! routine close_file_with_message
!
!> \brief closes the provided file handle and writes an error message.
!-----------------------------------------------------------------------
subroutine close_file_with_message(fileHandle, message, args)
type(MPAS_IO_Handle_type), intent(inout) :: fileHandle
character (len=*), intent(in), optional :: message
integer, dimension(:), intent(in), optional :: args

integer :: local_ierr

! log an error message
if (present(message)) then
if (present(args)) then
ERROR_WRITE_ARGS(message, intArgs=args)
else
ERROR_WRITE(message)
end if
end if

! close the provided file
call MPAS_io_close(fileHandle, local_ierr)
if (local_ierr /= MPAS_IO_NOERR) then
ERROR_WRITE_ARGS('MPAS_io_close failed with error code:$i', intArgs=(/local_ierr/))
return
endif

end subroutine close_file_with_message

!***********************************************************************
!
! routine test_read_string_buffer_check
!
!> \brief verifies attempts to read strings into buffers which are too small
!> to hold the value fails safely.
!> \details
!> Run these tests with valgrind to ensure there are no buffer overflows when
!> attempting to read strings into undersized buffers.
!-----------------------------------------------------------------------
subroutine test_read_string_buffer_check(domain, threadErrs, ierr)

type (domain_type), intent(inout) :: domain
integer, dimension(:), intent(out) :: threadErrs
integer, intent(out) :: ierr

integer :: local_ierr, i
type(MPAS_IO_Handle_type) :: fileHandle
character (len=StrKIND), dimension(1), parameter :: dimNamesString = ['StrLen']
character (len=StrKIND), dimension(2), parameter :: dimNamesStringTime = ['StrLen', 'Time ']
character (len=32), parameter :: varName1 = 'stringVar'
character (len=32), parameter :: varName2 = 'stringTimeVar'
character (len=*), parameter :: varValue1 = 'This is a string'
character (len=32), dimension(2), parameter :: varNames = [varName1, varName2]
integer, parameter :: bufferSize=128
integer, parameter :: smallBufferSize=bufferSize/2
character (len=bufferSize) :: buffer
character (len=smallBufferSize) :: smallBuffer
character (len=*), parameter :: filename = 'char_data.nc'

ierr = 0

! open a file to write char variables to
fileHandle = MPAS_io_open(filename, MPAS_IO_WRITE, MPAS_IO_NETCDF4, domain % ioContext, &
clobber_file=.true., truncate_file=.true., ierr=local_ierr)
if (local_ierr /= MPAS_IO_NOERR) then
ierr = 1
ERROR_WRITE('Error opening file ' // trim(filename))
return
end if

! define dimensions and char variables
call MPAS_io_def_dim(fileHandle, dimNamesStringTime(1), bufferSize, local_ierr)
if (local_ierr /= MPAS_IO_NOERR) then
ierr = 1
call close_file_with_message(fileHandle, 'Error defining '//trim(dimNamesStringTime(1))//', error=$i', (/local_ierr/))
return
end if
call MPAS_io_def_dim(fileHandle, dimNamesStringTime(2), MPAS_IO_UNLIMITED_DIM, local_ierr)
if (local_ierr /= MPAS_IO_NOERR) then
ierr = 1
call close_file_with_message(fileHandle, 'Error defining '//trim(dimNamesStringTime(2))//', error=$i', (/local_ierr/))
return
end if
call MPAS_io_def_var(fileHandle, varNames(1), MPAS_IO_CHAR, dimNamesString, ierr=local_ierr)
if (local_ierr /= MPAS_IO_NOERR) then
ierr = 1
call close_file_with_message(fileHandle, 'Error defining var "'//trim(varNames(1))//'" error=$i', (/local_ierr/))
return
end if
call MPAS_io_def_var(fileHandle, varNames(2), MPAS_IO_CHAR, dimNamesStringTime, ierr=local_ierr)
if (local_ierr /= MPAS_IO_NOERR) then
ierr = 1
call close_file_with_message(fileHandle, 'Error defining var "'//trim(varNames(2))//'" error=$i', (/local_ierr/))
return
end if

! write the string values
do i=1,2
call MPAS_io_put_var_char0d(fileHandle, varNames(i), varValue1, local_ierr)
if (local_ierr /= MPAS_IO_NOERR) then
ierr = 1
call close_file_with_message(fileHandle, 'Error writing "'//trim(varNames(i))// &
'", error=$i', (/local_ierr/))
return
end if

! verify the strings are read into buffers which are large enough for the strin values
call MPAS_io_get_var_char0d(fileHandle, varNames(i), buffer, local_ierr)
if (local_ierr /= MPAS_IO_NOERR) then
ierr = 1
call close_file_with_message(fileHandle, 'Error reading "'//trim(varNames(i))// &
'", error=$i', (/local_ierr/))
return
end if
end do

! verify attempts to read strings into buffers which are too small generates an error
call mpas_log_write(' ')
call mpas_log_write('Expect to see the following error:')
call MPAS_io_err_mesg(domain % ioContext, MPAS_IO_ERR_INSUFFICIENT_ARG, .false.)
call mpas_log_write(' ')
do i=1,2
! this should return an error
call MPAS_io_get_var_char0d(fileHandle, varNames(i), smallBuffer, local_ierr)
call mpas_log_write(' ')

if (local_ierr /= MPAS_IO_ERR_INSUFFICIENT_ARG) then
ierr = 1
if (local_ierr == MPAS_IO_NOERR) then
call close_file_with_message(fileHandle, 'Expected MPAS_IO_ERR_INSUFFICIENT_ARG ($i)'&
//' but recieved no error reading "'//trim(varName1), (/local_ierr/))
else
call close_file_with_message(fileHandle, 'Expected MPAS_IO_ERR_INSUFFICIENT_ARG ($i)'&
//' but recieved error $i reading "'//trim(varName1)//'"', &
(/MPAS_IO_ERR_INSUFFICIENT_ARG, local_ierr/))
end if
return
end if
end do
call close_file_with_message(fileHandle)

end subroutine test_read_string_buffer_check


!***********************************************************************
! Subroutine test_core_io_test
!
!> \brief Core test suite for I/O
!>
!> \details This subroutine tests mpas_io features.
!> It calls individual tests for I/O operations.
!> See the subroutine body for details.
!> The results of each test are logged with a success or failure message.
!>
!> \param domain The domain object that contains the I/O context
!> \param threadErrs An array to store any errors encountered during
!> the test.
!> \param ierr The error code that indicates the result of the test.
!
!-----------------------------------------------------------------------
subroutine test_core_io_test(domain, threadErrs, ierr)

use mpas_log

type (domain_type), intent(inout) :: domain
integer, dimension(:), intent(out) :: threadErrs
integer, intent(out) :: ierr

integer :: test_status

ierr = 0
test_status = 0

call mpas_log_write('Testing char-0 buffer reads')
call test_read_string_buffer_check(domain, threadErrs, test_status)
if (test_status == 0) then
call mpas_log_write('char-0 buffer tests: SUCCESS')
else
call mpas_log_write('char-0 buffer tests: FAILURE', MPAS_LOG_ERR)
ierr = ierr + abs(test_status)
end if


end subroutine test_core_io_test

end module test_core_io
91 changes: 64 additions & 27 deletions src/framework/mpas_io.F
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,8 @@
!
module mpas_io

#define IO_DEBUG_WRITE(M, ARGS) !call mpas_log_write(M, ARGS)
#define IO_ERROR_WRITE(M, ARGS) call mpas_log_write( M, ARGS, messageType=MPAS_LOG_ERR)
use mpas_derived_types
use mpas_attlist
use mpas_dmpar
Expand Down Expand Up @@ -1847,6 +1849,13 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr
character (len=:), pointer :: charVal_p
character (len=:), dimension(:), pointer :: charArray1d_p

! local variables returned from MPAS_io_inq_var
integer :: fieldtype
integer :: ndims
integer, dimension(:), pointer :: dimsizes
character (len=StrKIND), dimension(:), pointer :: dimnames
character (len=StrKind) :: message

#ifdef MPAS_SMIOL_SUPPORT
type (SMIOLf_decomp), pointer :: null_decomp

Expand Down Expand Up @@ -1984,22 +1993,40 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr
! call mpas_log_write(' value is char')

charVal_p => charVal

! get the dimension of the char variable to ensure the provided output buffer is large enough
call MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsizes, local_ierr)
do i = 1, ndims
message = ' MPAS_io_get_var_generic len(charVal):$i var "'//trim(fieldname)// &
'" type is $i dim $i is '// trim(dimnames(i))//' size is $i'
IO_DEBUG_WRITE(message , intArgs=(/len(charVal), fieldtype, i, dimsizes(i)/))
end do
! because charVal is provided, assume dimension 1 is the string length
if (dimsizes(1) > len(charVal)) then
local_ierr = MPAS_IO_ERR_INSUFFICIENT_ARG
message = ' MPAS_io_get_var_generic var "'//trim(fieldname)// &
'" len too big, len=$i buflen=$i'
IO_ERROR_WRITE(message, intArgs=(/dimsizes(1), len(charVal)/))
else
#ifdef MPAS_SMIOL_SUPPORT
local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, charVal_p)
local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, charVal_p)
#endif

#ifdef MPAS_PIO_SUPPORT
if (field_cursor % fieldhandle % has_unlimited_dim) then
count2(1) = field_cursor % fieldhandle % dims(1) % dimsize
pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, tempchar)
charVal(1:count2(1)) = tempchar(1)(1:count2(1))
else
start1(1) = 1
count1(1) = field_cursor % fieldhandle % dims(1) % dimsize
pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, tempchar)
charVal(1:count1(1)) = tempchar(1)(1:count1(1))
end if
if (field_cursor % fieldhandle % has_unlimited_dim) then
count2(1) = field_cursor % fieldhandle % dims(1) % dimsize
pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, tempchar)
charVal(1:count2(1)) = tempchar(1)(1:count2(1))
else
start1(1) = 1
count1(1) = field_cursor % fieldhandle % dims(1) % dimsize
pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, tempchar)
charVal(1:count1(1)) = tempchar(1)(1:count1(1))
end if
#endif
end if
deallocate(dimsizes)
deallocate(dimnames)
else if (present(charArray1d)) then
! call mpas_log_write(' value is char1')
#ifdef MPAS_PIO_SUPPORT
Expand Down Expand Up @@ -2765,28 +2792,34 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr
end if

! call mpas_log_write('Checking for error')
if (local_ierr == MPAS_IO_ERR_INSUFFICIENT_ARG) then
call MPAS_io_err_mesg(handle % ioContext, local_ierr, .false.)
io_global_err = local_ierr
if (present(ierr)) ierr = local_ierr
else
#ifdef MPAS_PIO_SUPPORT
if (pio_ierr /= PIO_noerr) then
io_global_err = pio_ierr
if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND
return
end if
if (pio_ierr /= PIO_noerr) then
io_global_err = pio_ierr
if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND
return
end if
#endif

#ifdef MPAS_SMIOL_SUPPORT
if (local_ierr /= SMIOL_SUCCESS) then
call mpas_log_write('SMIOLf_get_var failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR)
if (local_ierr == SMIOL_LIBRARY_ERROR) then
call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR)
else
call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR)
end if
if (local_ierr /= SMIOL_SUCCESS) then
call mpas_log_write('SMIOLf_get_var failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR)
if (local_ierr == SMIOL_LIBRARY_ERROR) then
call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR)
else
call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR)
end if

io_global_err = local_ierr
if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND
return
end if
io_global_err = local_ierr
if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND
return
end if
#endif
end if

end subroutine MPAS_io_get_var_generic

Expand Down Expand Up @@ -6498,6 +6531,10 @@ subroutine MPAS_io_err_mesg(ioContext, ierr, fatal)
call mpas_log_write('MPAS IO Error: Would clobber existing file', MPAS_LOG_ERR)
case (MPAS_IO_ERR_NOEXIST_READ)
call mpas_log_write('MPAS IO Error: Attempting to read a file which does not exist.', MPAS_LOG_ERR)
case (MPAS_IO_ERR_MISSING_DIM)
call mpas_log_write('MPAS IO Error: Attempting to read a dimension which does not exist.', MPAS_LOG_ERR)
case (MPAS_IO_ERR_INSUFFICIENT_ARG)
call mpas_log_write('MPAS IO Error: Attempting to read a string into a buffer which is too small.', MPAS_LOG_ERR)
case default
call mpas_log_write('MPAS IO Error: Unrecognized error code...', MPAS_LOG_ERR)
end select
Expand Down
3 changes: 2 additions & 1 deletion src/framework/mpas_io_types.inc
Original file line number Diff line number Diff line change
Expand Up @@ -65,7 +65,8 @@
MPAS_IO_ERR_UNIMPLEMENTED = -18, &
MPAS_IO_ERR_WOULD_CLOBBER = -19, &
MPAS_IO_ERR_NOEXIST_READ = -20, &
MPAS_IO_ERR_MISSING_DIM = -21
MPAS_IO_ERR_MISSING_DIM = -21, &
MPAS_IO_ERR_INSUFFICIENT_ARG = -22

type MPAS_IO_Handle_type
logical :: initialized = .false.
Expand Down