diff --git a/.github/workflows/ci_windows.yml b/.github/workflows/ci_windows.yml index 66551fdd2..fa938073d 100644 --- a/.github/workflows/ci_windows.yml +++ b/.github/workflows/ci_windows.yml @@ -35,6 +35,8 @@ jobs: mingw-w64-${{ matrix.arch }}-python-fypp mingw-w64-${{ matrix.arch }}-cmake mingw-w64-${{ matrix.arch }}-ninja + unzip + zip - run: >- PATH=$PATH:/mingw64/bin/ cmake diff --git a/doc/specs/stdlib_array.md b/doc/specs/stdlib_array.md index e10a95aff..3880786bc 100644 --- a/doc/specs/stdlib_array.md +++ b/doc/specs/stdlib_array.md @@ -10,8 +10,58 @@ title: array Module for index manipulation and array handling tasks. -## Procedures and methods provided +## Derived types provided + +### `array_wrapper_type` + +A derived type that wraps a polymorphic `array_type` and helps with its allocation. By loading an npz file with `load_npz`, a list of array wrappers will be obtained. On the other hand, a list of array wrappers can be saved to an npz file using `save_npz`. Use `add_array` to add an array to a list of array wrappers and call `get_values` on the array wrapper to obtain the values of the underlying array. + +#### Status + +Experimental + +#### Example + +```fortran +program npz_example + use stdlib_array, only: array_wrapper_type, add_array + use stdlib_io_np, only: save_npz, load_npz + implicit none + type(array_wrapper_type), allocatable :: input_arrays(:), output_arrays(:) + real :: x(3, 2) = 1 + integer :: y(2, 3) = 2 + real, allocatable :: x_out(:,:) + integer, allocatable :: y_out(:,:) + + call add_array(input_arrays, x) + call add_array(input_arrays, y) + + call save_npz('example_save.npz', input_arrays) + + call load_npz('example_save.npz', output_arrays) + + if (size(input_arrays) /= 2) then + print *, 'Error: Output array has unexpected size.'; stop + end if + + call output_arrays(1)%get_values(x_out) + call output_arrays(2)%get_values(y_out) + + print *, x_out + print *, y_out +end +``` + +### `array_type` + +An abstract type that can be extended according to the type and rank of the stored array. It is usually not necessary to interact with this type directly. It is used to store multiple arrays of different types and ranks in a single array. + +#### Status + +Experimental + +## Procedures and methods provided ### `trueloc` @@ -49,7 +99,6 @@ Returns an array of default integer size, with a maximum length of `size(array)` {!example/array/example_trueloc.f90!} ``` - ### `falseloc` #### Status @@ -85,3 +134,73 @@ Returns an array of default integer size, with a maximum length of `size(array)` ```fortran {!example/array/example_falseloc.f90!} ``` + +### `add_array` + +#### Status + +Experimental + +#### Description + +Add an array of defined type and rank to a list of array wrappers. + +#### Syntax + +`call ` [[stdlib_array(module):add_array(interface)]] `(arrays, array[, stat, msg, name])` + +#### Class + +Pure subroutine. + +#### Arguments + +`arrays`: List of array wrappers of type `array_wrapper_type` to add `array` to. This argument is `intent(inout)`. + +`array`: Array with defined type and rank to be added to the list of array wrappers. This argument is `intent(in)`. + +`stat`: Status variable of type `integer`. This argument is `optional` and `intent(out)`. The operation is successful if `stat` is `0`. + +`msg`: Error message. This argument is `optional` and `intent(out)`. + +`name`: Name of the array. This argument is `optional` and `intent(in)`. If not provided, the name will be set to the default value. + +#### Examples + +```fortran +{!example/io/example_save_npz.f90!} +``` + +### `get_values` + +#### Status + +Experimental + +#### Description + +Get the values of the array within the array wrapper. + +#### Syntax + +`call ` [[stdlib_array(module):array_wrapper_type(type)]] `%` [[array_wrapper_type(type):get_values(bound)]] `(wrapper, values[, stat, msg])` + +#### Class + +Pure subroutine. + +#### Arguments + +`wrapper`: Array wrapper of type `array_wrapper_type` to get the values from. This argument is `intent(in)`. + +`values`: Array of the same type and rank as the array within the array wrapper. This argument is `intent(out)`. + +`stat`: Status variable of type `integer`. This argument is `optional` and `intent(out)`. The operation is successful if `stat` is `0`. + +`msg`: Error message. This argument is `optional` and `intent(out)`. + +#### Examples + +```fortran +{!example/io/example_load_npz.f90!} +``` diff --git a/doc/specs/stdlib_io.md b/doc/specs/stdlib_io.md index 8c868802a..0c389a136 100644 --- a/doc/specs/stdlib_io.md +++ b/doc/specs/stdlib_io.md @@ -136,11 +136,11 @@ Loads an `array` from a npy formatted binary file. ### Syntax -`call ` [[stdlib_io_npy(module):load_npy(interface)]] `(filename, array[, iostat][, iomsg])` +`call ` [[stdlib_io_np(module):load_npy(interface)]] `(filename, array[, iostat][, iomsg])` ### Arguments -`filename`: Shall be a character expression containing the file name from which to load the `array`. +`filename`: Shall be a character expression containing the file name from which to load the `array`. This argument is `intent(in)`. `array`: Shall be an allocatable array of any rank of type `real`, `complex` or `integer`. @@ -164,7 +164,6 @@ Returns an allocated `array` with the content of `filename` in case of success. {!example/io/example_loadnpy.f90!} ``` - ## `save_npy` ### Status @@ -177,7 +176,7 @@ Saves an `array` into a npy formatted binary file. ### Syntax -`call ` [[stdlib_io_npy(module):save_npy(interface)]] `(filename, array[, iostat][, iomsg])` +`call ` [[stdlib_io_np(module):save_npy(interface)]] `(filename, array[, iostat][, iomsg])` ### Arguments @@ -205,6 +204,70 @@ Provides a npy file called `filename` that contains the rank-2 `array`. {!example/io/example_savenpy.f90!} ``` +## `load_npz` + +### Status + +Experimental + +### Description + +Populates an array of `array_wrapper_type` with the contents of an npz file. + +### Syntax + +`call ` [[stdlib_io_np(module):load_npz(interface)]] `(filename, arrays[, iostat][, iomsg][, tmp_dir])` + +### Arguments + +`filename`: Shall be a character expression containing the name of the npz file to load from. The argument is `intent(in)`. + +`arrays`: Shall be an allocatable array of type `array_wrapper_type` to load the content of the npz file to. This argument is `intent(out)`. + +`iostat`: Default integer, contains status of loading to file, zero in case of success. This argument is `optional` and `intent(out)`. + +`iomsg`: Deferred length character value, contains error message in case `iostat` is non-zero. It is an optional argument, error message will be dropped if not present. This argument is `intent(out)`. + +`tmp_dir`: Shall be a character expression containing the name of the temporary directory to extract the npz file to. The argument is `optional` and `intent(in)`. + +### Example + +```fortran +{!example/io/example_load_npz.f90!} +``` + +## `save_npz` + +### Status + +Experimental + +### Description + +Saves an array of `array_wrapper_type` into a npz file. + +### Syntax + +`call ` [[stdlib_io_np(module):save_npz(interface)]] `(filename, arrays[, iostat][, iomsg][, compressed])` + +### Arguments + +`filename`: Shall be a character expression containing the name of the file that contains the arrays. This argument is `intent(in)`. + +`arrays`: Shall be arrays of type `array_wrapper_type` that are meant to be saved to disk. This argument is `intent(in)`. + +`iostat`: Default integer, contains status of saving to file, zero in case of success. This argument is `optional` and `intent(out)`. + +`iomsg`: Deferred length character value, contains error message in case `iostat` is non-zero. It is an optional argument, error message will be dropped if not present. This argument is `intent(out)`. + +`compressed`: Shall be a logical expression that determines if the npz file should be compressed. The argument is `optional` and `intent(in)`. The default value is `.false.`. + +### Example + +```fortran +{!example/io/example_save_npz.f90!} +``` + ## `getline` ### Status @@ -260,3 +323,117 @@ Provides formats for all kinds as defined in the `stdlib_kinds` module. ```fortran {!example/io/example_fmt_constants.f90!} ``` + +## `zip` + +### Status + +Experimental + +### Description + +Compresses a file or directory into a zip archive. + +### Syntax + +`call ` [[stdlib_io_zip(module):zip(subroutine)]] ` (output_file, files[, stat][, msg][, compressed])` + +### Arguments + +`output_file`: Character expression representing the name of the zip file to create. This argument is `intent(in)`. + +`files`: Array of `string_type` representing the names of the files to compress. This argument is `intent(in)`. + +`stat`: Default integer, contains status of reading from unit, zero in case of success. This argument is `optional` and `intent(out)`. + +`msg`: Deferred length character value, contains error message in case `iostat` is non-zero. It is an `optional` argument, error message will be dropped if not present. This argument is `intent(out)`. + +`compressed`: Logical expression that determines if the zip file should be compressed. The argument is `optional` and `intent(in)`. The default value is `.true.`. + +## `unzip` + +### Status + +Experimental + +### Description + +Extracts a zip archive into a directory. + +### Syntax + +`call ` [[stdlib_io_zip(module):unzip(subroutine)]] ` (filename, outputdir[, stat][, msg])` + +### Arguments + +`filename`: Character expression representing the name of the zip file to extract. This argument is `intent(in)`. + +`outputdir`: Character expression representing the name of the directory to extract the zip file to. This argument is `intent(in)`. + +`stat`: Default integer, contains status of reading from unit, zero in case of success. This argument is `optional` and `intent(out)`. + +`msg`: Deferred length character value, contains error message in case `iostat` is non-zero. It is an `optional` argument, error message will be dropped if not present. This argument is `intent(out)`. + +## `exists` + +### Status + +Experimental + +### Description + +Whether a file or directory exists at the given location in the filesystem. + +### Syntax + +`is_existing = ` [[stdlib_io_filesystem(module):exists(function)]] ` (filename)` + +### Arguments + +`filename`: Character expression representing the name of the file or directory to check for existence. This argument is `intent(in)`. + +## `list_dir` + +### Status + +Experimental + +### Description + +Lists the contents of a directory. + +### Syntax + +`call ` [[stdlib_io_filesystem(module):list_dir(subroutine)]] ` (dir, files[, iostat][, iomsg])` + +### Arguments + +`dir`: Character expression representing the name of the directory to list. This argument is `intent(in)`. + +`files`: Array of `string_type` representing the names of the files in the directory. This argument is `intent(out)`. + +`iostat`: Default integer, contains status of reading from unit, zero in case of success. This argument is `optional` and `intent(out)`. + +`iomsg`: Deferred length character value, contains error message in case `iostat` is non-zero. It is an `optional` argument, error message will be dropped if not present. This argument is `intent(out)`. + +## `run` + +### Status + +Experimental + +### Description + +Runs a command in the shell. + +### Syntax + +`call ` [[stdlib_io_filesystem(module):run(subroutine)]] ` (command[, iostat][, iomsg])` + +### Arguments + +`command`: Character expression representing the command to run. This argument is `intent(in)`. + +`iostat`: Default integer, contains status of reading from unit, zero in case of success. This argument is `optional` and `intent(out)`. + +`iomsg`: Deferred length character value, contains error message in case `iostat` is non-zero. It is an `optional` argument, error message will be dropped if not present. This argument is `intent(out)`. diff --git a/example/io/CMakeLists.txt b/example/io/CMakeLists.txt index 2e606d2d1..ea420ee0c 100644 --- a/example/io/CMakeLists.txt +++ b/example/io/CMakeLists.txt @@ -5,3 +5,5 @@ ADD_EXAMPLE(loadtxt) ADD_EXAMPLE(open) ADD_EXAMPLE(savenpy) ADD_EXAMPLE(savetxt) +ADD_EXAMPLE(load_npz) +ADD_EXAMPLE(save_npz) diff --git a/example/io/example_load.npz b/example/io/example_load.npz new file mode 100644 index 000000000..1592ce173 Binary files /dev/null and b/example/io/example_load.npz differ diff --git a/example/io/example_load_npz.f90 b/example/io/example_load_npz.f90 new file mode 100644 index 000000000..edb6fe703 --- /dev/null +++ b/example/io/example_load_npz.f90 @@ -0,0 +1,18 @@ +program example_load_npz + use stdlib_array, only: array_wrapper_type + use stdlib_kinds, only: int32, sp + use stdlib_io_np, only: load_npz + implicit none + + type(array_wrapper_type), allocatable :: arrays(:) + real(sp), allocatable :: array_1(:,:) + integer(int32), allocatable :: array_2(:,:) + + call load_npz('example_load.npz', arrays) + + call arrays(1)%get_values(array_1) + call arrays(2)%get_values(array_2) + + print *, array_1 + print *, array_2 +end diff --git a/example/io/example_loadnpy.f90 b/example/io/example_loadnpy.f90 index b037312ec..bd0decd37 100644 --- a/example/io/example_loadnpy.f90 +++ b/example/io/example_loadnpy.f90 @@ -1,6 +1,6 @@ program example_loadnpy - use stdlib_io_npy, only: load_npy - implicit none - real, allocatable :: x(:, :) - call load_npy('example.npy', x) -end program example_loadnpy + use stdlib_io_np, only: load_npy + implicit none + real, allocatable :: x(:, :) + call load_npy('example.npy', x) + end program example_loadnpy \ No newline at end of file diff --git a/example/io/example_save_npz.f90 b/example/io/example_save_npz.f90 new file mode 100644 index 000000000..3271d9f2a --- /dev/null +++ b/example/io/example_save_npz.f90 @@ -0,0 +1,14 @@ +program example_save_npz + use stdlib_array, only: array_wrapper_type, add_array + use stdlib_io_np, only: save_npz + implicit none + + type(array_wrapper_type), allocatable :: arrays(:) + real :: x(3, 2) = 1 + integer :: y(2, 3) = 2 + + call add_array(arrays, x) + call add_array(arrays, y) + + call save_npz('example_save.npz', arrays) +end diff --git a/example/io/example_savenpy.f90 b/example/io/example_savenpy.f90 index b6929f40f..da4c5767f 100644 --- a/example/io/example_savenpy.f90 +++ b/example/io/example_savenpy.f90 @@ -1,6 +1,6 @@ program example_savenpy - use stdlib_io_npy, only: save_npy - implicit none - real :: x(3, 2) = 1 - call save_npy('example.npy', x) -end program example_savenpy + use stdlib_io_np, only: save_npy + implicit none + real :: x(3, 2) = 1 + call save_npy('example.npy', x) + end program example_savenpy \ No newline at end of file diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index ef11b642e..d8c4c215f 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -2,6 +2,7 @@ # Create a list of the files to be preprocessed set(fppFiles + stdlib_array.fypp stdlib_ascii.fypp stdlib_bitsets.fypp stdlib_bitsets_64.fypp @@ -17,9 +18,9 @@ set(fppFiles stdlib_hash_64bit_pengy.fypp stdlib_hash_64bit_spookyv2.fypp stdlib_io.fypp - stdlib_io_npy.fypp - stdlib_io_npy_load.fypp - stdlib_io_npy_save.fypp + stdlib_io_np.fypp + stdlib_io_np_load.fypp + stdlib_io_np_save.fypp stdlib_kinds.fypp stdlib_linalg.fypp stdlib_linalg_diag.fypp @@ -102,13 +103,14 @@ set(SRC stdlib_ansi.f90 stdlib_ansi_operator.f90 stdlib_ansi_to_string.f90 - stdlib_array.f90 stdlib_codata.f90 stdlib_error.f90 stdlib_hashmap_wrappers.f90 stdlib_hashmaps.f90 stdlib_hashmap_chaining.f90 stdlib_hashmap_open.f90 + stdlib_io_filesystem.f90 + stdlib_io_zip.f90 stdlib_logger.f90 stdlib_sorting_radix_sort.f90 stdlib_system.F90 @@ -120,6 +122,17 @@ set(SRC ${outPreprocFiles} ) +# Files that have cpp directives need to be compiled with the preprocessor. +set(hasCPP + stdlib_io_filesystem.f90 +) + +if(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") + set_source_files_properties(${hasCPP} PROPERTIES COMPILE_FLAGS "-cpp") +elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "Intel") + set_source_files_properties(${hasCPP} PROPERTIES COMPILE_FLAGS "-fpp") +endif() + add_library(${PROJECT_NAME} ${SRC}) set_target_properties( diff --git a/src/stdlib_array.f90 b/src/stdlib_array.f90 deleted file mode 100644 index c5e4fa004..000000000 --- a/src/stdlib_array.f90 +++ /dev/null @@ -1,68 +0,0 @@ -! SPDX-Identifier: MIT - -!> Module for index manipulation and general array handling -!> -!> The specification of this module is available [here](../page/specs/stdlib_array.html). -module stdlib_array - implicit none - private - - public :: trueloc, falseloc - -contains - - !> Version: experimental - !> - !> Return the positions of the true elements in array. - !> [Specification](../page/specs/stdlib_array.html#trueloc) - pure function trueloc(array, lbound) result(loc) - !> Mask of logicals - logical, intent(in) :: array(:) - !> Lower bound of array to index - integer, intent(in), optional :: lbound - !> Locations of true elements - integer :: loc(count(array)) - - call logicalloc(loc, array, .true., lbound) - end function trueloc - - !> Version: experimental - !> - !> Return the positions of the false elements in array. - !> [Specification](../page/specs/stdlib_array.html#falseloc) - pure function falseloc(array, lbound) result(loc) - !> Mask of logicals - logical, intent(in) :: array(:) - !> Lower bound of array to index - integer, intent(in), optional :: lbound - !> Locations of false elements - integer :: loc(count(.not.array)) - - call logicalloc(loc, array, .false., lbound) - end function falseloc - - !> Return the positions of the truthy elements in array - pure subroutine logicalloc(loc, array, truth, lbound) - !> Locations of truthy elements - integer, intent(out) :: loc(:) - !> Mask of logicals - logical, intent(in) :: array(:) - !> Truthy value - logical, intent(in) :: truth - !> Lower bound of array to index - integer, intent(in), optional :: lbound - integer :: i, pos, offset - - offset = 0 - if (present(lbound)) offset = lbound - 1 - - i = 0 - do pos = 1, size(array) - if (array(pos).eqv.truth) then - i = i + 1 - loc(i) = pos + offset - end if - end do - end subroutine logicalloc - -end module stdlib_array diff --git a/src/stdlib_array.fypp b/src/stdlib_array.fypp new file mode 100644 index 000000000..af0312a17 --- /dev/null +++ b/src/stdlib_array.fypp @@ -0,0 +1,224 @@ +! SPDX-Identifier: MIT + +#:include "common.fypp" +#:set RANKS = range(1, MAXRANK + 1) +#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES + +!> Module for general array handling and index manipulation. +!> +!> The specification of this module is available [here](../page/specs/stdlib_array.html). +module stdlib_array + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp + use stdlib_strings, only: to_string + implicit none + private + + public :: add_array, trueloc, falseloc + + !> Version: experimental + !> + !> Wrapper class that helps with the allocation of `array_type`. + !> [Specification](../page/specs/stdlib_array.html#array_wrapper_type) + type, public :: array_wrapper_type + !> Polymorphic array. + class(array_type), allocatable :: array + contains +#:for k1, t1 in KINDS_TYPES +#:for rank in RANKS + generic :: get_values => get_values_${t1[0]}$${k1}$_${rank}$ + procedure :: get_values_${t1[0]}$${k1}$_${rank}$ +#:endfor +#:endfor + end type + + !> Version: experimental + !> + !> Abstract type that is extended according to the type and rank of the stored array. + !> [Specification](../page/specs/stdlib_array.html#array_type) + type, abstract, public :: array_type + !> Name of the array. + character(:), allocatable :: name + end type + +#:for k1, t1 in KINDS_TYPES +#:for rank in RANKS + !> Version: experimental + !> + !> Array type for ${t1}$ arrays of ${k1} precision and rank ${rank}. + !> Extends `array_type` and contains the values of the array. + type, extends(array_type), public :: array_type_${t1[0]}$${k1}$_${rank}$ + ${t1}$, allocatable :: values${ranksuffix(rank)}$ + end type +#:endfor +#:endfor + + !> Version: experimental + !> + !> Add an array of defined type and rank to an array of array wrappers. + !> [Specification](../page/specs/stdlib_array.html#add_array) + interface add_array +#:for k1, t1 in KINDS_TYPES +#:for rank in RANKS + pure module subroutine add_array_${t1[0]}$${k1}$_${rank}$(arrays, array, stat, msg, name) + !> Array of arrays to which the array is to be added. + type(array_wrapper_type), allocatable, intent(inout) :: arrays(:) + !> Array to be added. + ${t1}$, intent(in) :: array${ranksuffix(rank)}$ + !> Status of addition. + integer, intent(out), optional :: stat + !> Error message. + character(len=:), allocatable, intent(out), optional :: msg + !> Name of the array to be added. A default name will be used if not provided. + character(len=*), intent(in), optional :: name + end +#:endfor +#:endfor + end interface + +contains + +#:for k1, t1 in KINDS_TYPES +#:for rank in RANKS + !> Version: experimental + !> + !> Extract array values from an array wrapper. + !> [Specification](../page/specs/stdlib_array.html#get_values) + pure subroutine get_values_${t1[0]}$${k1}$_${rank}$(wrapper, values, stat, msg) + !> Array wrapper to extract the values from. + class(array_wrapper_type), intent(in) :: wrapper + !> Extracted values. + ${t1}$, allocatable, intent(out) :: values${ranksuffix(rank)}$ + !> Optional status of the extraction. + integer, intent(out), optional :: stat + !> Optional error message. + character(len=:), allocatable, intent(out), optional :: msg + + if (present(stat)) stat = 0 + + select type (array_ => wrapper%array) + class is (array_type_${t1[0]}$${k1}$_${rank}$) + values = array_%values + class default + if (present(stat)) stat = 1 + if (present(msg)) msg = "Array is of unexpected type." + end select + end +#:endfor +#:endfor + +#:for k1, t1 in KINDS_TYPES +#:for rank in RANKS + !> Version: experimental + !> + !> Add an array to an array of array wrappers. + pure module subroutine add_array_${t1[0]}$${k1}$_${rank}$(arrays, array, stat, msg, name) + !> Array of wrapper arrays to which the array is to be added. + type(array_wrapper_type), allocatable, intent(inout) :: arrays(:) + !> Array to be added. + ${t1}$, intent(in) :: array${ranksuffix(rank)}$ + !> Status of addition. + integer, intent(out), optional :: stat + !> Error message. + character(len=:), allocatable, intent(out), optional :: msg + !> Name of the array to be added. A default name will be used if not provided. + character(len=*), intent(in), optional :: name + + integer :: i, arr_size + type(array_type_${t1[0]}$${k1}$_${rank}$) :: t_arr + type(array_wrapper_type), allocatable :: tmp_arrays(:) + + if (present(stat)) stat = 0 + + if (present(name)) then + if (trim(name) == '') then + if (present(stat)) stat = 1 + if (present(msg)) msg = "Array name cannot be empty." + return + end if + t_arr%name = name + else + if (allocated(arrays)) then + t_arr%name = "arr_"//to_string(size(arrays))//".npy" + else + t_arr%name = "arr_0.npy" + end if + end if + + allocate(t_arr%values, source=array) + if (.not. allocated(arrays)) then + allocate(arrays(1)) + allocate(arrays(1)%array, source=t_arr) + return + end if + + arr_size = size(arrays) + do i = 1, arr_size + if (arrays(i)%array%name == t_arr%name) then + if (present(stat)) stat = 1 + if (present(msg)) msg = "Array with the same name '"//t_arr%name//"' already exists." + return + end if + end do + + allocate(tmp_arrays(arr_size + 1)) + tmp_arrays(:arr_size) = arrays + allocate(tmp_arrays(arr_size + 1)%array, source=t_arr) + call move_alloc(tmp_arrays, arrays) + end +#:endfor +#:endfor + + !> Version: experimental + !> + !> Return the positions of the true elements in array. + !> [Specification](../page/specs/stdlib_array.html#trueloc) + pure function trueloc(array, lbound) result(loc) + !> Mask of logicals + logical, intent(in) :: array(:) + !> Lower bound of array to index + integer, intent(in), optional :: lbound + !> Locations of true elements + integer :: loc(count(array)) + + call logicalloc(loc, array, .true., lbound) + end + + !> Version: experimental + !> + !> Return the positions of the false elements in array. + !> [Specification](../page/specs/stdlib_array.html#falseloc) + pure function falseloc(array, lbound) result(loc) + !> Mask of logicals + logical, intent(in) :: array(:) + !> Lower bound of array to index + integer, intent(in), optional :: lbound + !> Locations of false elements + integer :: loc(count(.not. array)) + + call logicalloc(loc, array, .false., lbound) + end + + !> Return the positions of the truthy elements in array + pure subroutine logicalloc(loc, array, truth, lbound) + !> Locations of truthy elements + integer, intent(out) :: loc(:) + !> Mask of logicals + logical, intent(in) :: array(:) + !> Truthy value + logical, intent(in) :: truth + !> Lower bound of array to index + integer, intent(in), optional :: lbound + integer :: i, pos, offset + + offset = 0 + if (present(lbound)) offset = lbound - 1 + + i = 0 + do pos = 1, size(array) + if (array(pos) .eqv. truth) then + i = i + 1 + loc(i) = pos + offset + end if + end do + end +end diff --git a/src/stdlib_io_filesystem.f90 b/src/stdlib_io_filesystem.f90 new file mode 100644 index 000000000..426b36d45 --- /dev/null +++ b/src/stdlib_io_filesystem.f90 @@ -0,0 +1,112 @@ +! SPDX-Identifier: MIT + +!> Interaction with the filesystem. +module stdlib_io_filesystem + use stdlib_string_type, only: string_type + implicit none + private + + public :: exists, list_dir, run, temp_dir + + character(*), parameter :: temp_dir = 'temp' + character(*), parameter :: listed_contents = temp_dir//'/listed_contents.txt' + +contains + + !> Version: experimental + !> + !> Whether a file or directory exists at the given path. + !> [Specification](../page/specs/stdlib_io.html#exists) + logical function exists(filename) + !> Name of the file or directory. + character(len=*), intent(in) :: filename + + inquire(file=filename, exist=exists) + +#if defined(__INTEL_COMPILER) + if (.not. exists) inquire(directory=filename, exist=exists) +#endif + end + + !> Version: experimental + !> + !> List files and directories of a directory. Does not list hidden files. + !> [Specification](../page/specs/stdlib_io.html#list_dir) + subroutine list_dir(dir, files, iostat, iomsg) + !> Directory to list. + character(len=*), intent(in) :: dir + !> List of files and directories. + type(string_type), allocatable, intent(out) :: files(:) + !> Status of listing. + integer, optional, intent(out) :: iostat + !> Error message. + character(len=:), allocatable, optional, intent(out) :: iomsg + + integer :: unit, stat + character(len=256) :: line + + stat = 0 + + if (.not. exists(temp_dir)) then + call run('mkdir '//temp_dir, stat) + if (stat /= 0) then + if (present(iostat)) iostat = stat + if (present(iomsg)) iomsg = "Failed to create temporary directory '"//temp_dir//"'." + return + end if + end if + + call run('ls '//dir//' > '//listed_contents, stat) + if (stat /= 0) then + if (present(iostat)) iostat = stat + if (present(iomsg)) iomsg = "Failed to list files in directory '"//dir//"'." + return + end if + + open(newunit=unit, file=listed_contents, status='old', action='read', iostat=stat) + if (stat /= 0) then + if (present(iostat)) iostat = stat + if (present(iomsg)) iomsg = "Failed to open file '"//listed_contents//"'." + return + end if + + allocate(files(0)) + do + read(unit, '(A)', iostat=stat) line + if (stat /= 0) exit + files = [files, string_type(line)] + end do + close(unit, status="delete") + end + + !> Version: experimental + !> + !> Run a command in the shell. + !> [Specification](../page/specs/stdlib_io.html#run) + subroutine run(command, iostat, iomsg) + !> Command to run. + character(len=*), intent(in) :: command + !> Status of the operation. + integer, intent(out), optional :: iostat + !> Error message. + character(len=:), allocatable, intent(out), optional :: iomsg + + integer :: exitstat, cmdstat + character(len=256) :: cmdmsg + + if (present(iostat)) iostat = 0 + exitstat = 0; cmdstat = 0 + + call execute_command_line(command, exitstat=exitstat, cmdstat=cmdstat, cmdmsg=cmdmsg) + if (exitstat /= 0 .or. cmdstat /= 0) then + if (present(iostat)) then + if (exitstat /= 0) then + iostat = exitstat + else + iostat = cmdstat + end if + end if + if (present(iomsg) .and. trim(adjustl(cmdmsg)) /= '') iomsg = cmdmsg + end if + end +end diff --git a/src/stdlib_io_npy.fypp b/src/stdlib_io_np.fypp similarity index 69% rename from src/stdlib_io_npy.fypp rename to src/stdlib_io_np.fypp index bf69a6a0c..65d1a3f66 100644 --- a/src/stdlib_io_npy.fypp +++ b/src/stdlib_io_np.fypp @@ -1,10 +1,10 @@ -! SPDX-Identifer: MIT +! SPDX-Identifier: MIT #:include "common.fypp" #:set RANKS = range(1, MAXRANK + 1) #:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES -!> Description of the npy format taken from +!> Description of the npy and npz formats taken from !> https://numpy.org/doc/stable/reference/generated/numpy.lib.format.html !> !>## Format Version 1.0 @@ -68,59 +68,80 @@ !> !> This version replaces the ASCII string (which in practice was latin1) with a !> utf8-encoded string, so supports structured types with any unicode field names. -module stdlib_io_npy - use stdlib_kinds, only : int8, int16, int32, int64, sp, dp, xdp, qp +module stdlib_io_np + use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp + use stdlib_array, only: array_wrapper_type implicit none private - public :: save_npy, load_npy + public :: load_npy, save_npy, load_npz, save_npz + character(len=*), parameter :: & + type_iint8 = " Version: experimental + !> + !> Load multidimensional array in npy format + !> ([Specification](../page/specs/stdlib_io.html#load_npy)) + interface load_npy +#:for k1, t1 in KINDS_TYPES +#:for rank in RANKS + module subroutine load_npy_${t1[0]}$${k1}$_${rank}$(filename, array, iostat, iomsg) + character(len=*), intent(in) :: filename + ${t1}$, allocatable, intent(out) :: array${ranksuffix(rank)}$ + integer, intent(out), optional :: iostat + character(len=:), allocatable, intent(out), optional :: iomsg + end +#:endfor +#:endfor + end interface !> Version: experimental !> !> Save multidimensional array in npy format !> ([Specification](../page/specs/stdlib_io.html#save_npy)) interface save_npy - #:for k1, t1 in KINDS_TYPES - #:for rank in RANKS +#:for k1, t1 in KINDS_TYPES +#:for rank in RANKS module subroutine save_npy_${t1[0]}$${k1}$_${rank}$(filename, array, iostat, iomsg) character(len=*), intent(in) :: filename ${t1}$, intent(in) :: array${ranksuffix(rank)}$ integer, intent(out), optional :: iostat character(len=:), allocatable, intent(out), optional :: iomsg - end subroutine save_npy_${t1[0]}$${k1}$_${rank}$ - #:endfor - #:endfor - end interface save_npy + end +#:endfor +#:endfor + end interface !> Version: experimental !> - !> Load multidimensional array in npy format - !> ([Specification](../page/specs/stdlib_io.html#load_npy)) - interface load_npy - #:for k1, t1 in KINDS_TYPES - #:for rank in RANKS - module subroutine load_npy_${t1[0]}$${k1}$_${rank}$(filename, array, iostat, iomsg) + !> Load multiple multidimensional arrays from a (compressed) npz file. + !> ([Specification](../page/specs/stdlib_io.html#load_npz)) + interface load_npz + module subroutine load_npz_to_arrays(filename, arrays, iostat, iomsg, tmp_dir) character(len=*), intent(in) :: filename - ${t1}$, allocatable, intent(out) :: array${ranksuffix(rank)}$ + type(array_wrapper_type), allocatable, intent(out) :: arrays(:) integer, intent(out), optional :: iostat character(len=:), allocatable, intent(out), optional :: iomsg - end subroutine load_npy_${t1[0]}$${k1}$_${rank}$ - #:endfor - #:endfor - end interface load_npy - - - character(len=*), parameter :: nl = achar(10) - - character(len=*), parameter :: & - type_iint8 = " Version: experimental + !> + !> Save multidimensional arrays to a compressed or an uncompressed npz file. + !> ([Specification](../page/specs/stdlib_io.html#save_npz)) + interface save_npz + module subroutine save_arrays_to_npz(filename, arrays, iostat, iomsg, compressed) + character(len=*), intent(in) :: filename + type(array_wrapper_type), intent(in) :: arrays(:) + integer, intent(out), optional :: iostat + character(len=:), allocatable, intent(out), optional :: iomsg + !> If true, the file is saved in compressed format. The default is false. + logical, intent(in), optional :: compressed + end + end interface +end diff --git a/src/stdlib_io_np_load.fypp b/src/stdlib_io_np_load.fypp new file mode 100644 index 000000000..9a77e5e9a --- /dev/null +++ b/src/stdlib_io_np_load.fypp @@ -0,0 +1,664 @@ +! SPDX-Identifier: MIT + +#:include "common.fypp" +#:set RANKS = range(1, MAXRANK + 1) +#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES + +!> Implementation of loading npy files into multidimensional arrays +submodule(stdlib_io_np) stdlib_io_np_load + use stdlib_array + use stdlib_error, only: error_stop + use stdlib_io_filesystem, only: exists, list_dir, temp_dir + use stdlib_io_zip, only: unzip, default_unzip_dir, zip_contents, zip + use stdlib_strings, only: to_string, starts_with + use stdlib_string_type, only: string_type, as_string => char + implicit none + +contains + +#:for k1, t1 in KINDS_TYPES +#:for rank in RANKS + !> Load a ${rank}$-dimensional array from a npy file + module subroutine load_npy_${t1[0]}$${k1}$_${rank}$(filename, array, iostat, iomsg) + !> Name of the npy file to load from + character(len=*), intent(in) :: filename + !> Array to be loaded from the npy file + ${t1}$, allocatable, intent(out) :: array${ranksuffix(rank)}$ + !> Error status of loading, zero on success + integer, intent(out), optional :: iostat + !> Associated error message in case of non-zero status code + character(len=:), allocatable, intent(out), optional :: iomsg + + character(len=*), parameter :: vtype = type_${t1[0]}$${k1}$ + integer, parameter :: rank = ${rank}$ + + integer :: io, stat + character(len=:), allocatable :: msg + + open(newunit=io, file=filename, form="unformatted", access="stream", iostat=stat) + catch: block + character(len=:), allocatable :: this_type + integer, allocatable :: vshape(:) + + call get_descriptor(io, filename, this_type, vshape, stat, msg) + if (stat /= 0) exit catch + + if (this_type /= vtype) then + stat = 1 + msg = "File '"//filename//"' contains data of type '"//this_type//"', "//& + & "but expected '"//vtype//"'" + exit catch + end if + + if (size(vshape) /= rank) then + stat = 1 + msg = "File '"//filename//"' contains data of rank "//& + & to_string(size(vshape))//", but expected "//& + & to_string(rank) + exit catch + end if + + call allocate_array_from_shape_${t1[0]}$${k1}$_${rank}$(array, vshape, stat) + if (stat /= 0) then + msg = "Failed to allocate array of type '"//vtype//"' "//& + & "with total size of "//to_string(product(vshape)) + exit catch + end if + + read(io, iostat=stat) array + end block catch + close(io) + + if (present(iostat)) then + iostat = stat + else if (stat /= 0) then + if (allocated(msg)) then + call error_stop("Failed to read array from file '"//filename//"'"//nl//msg) + else + call error_stop("Failed to read array from file '"//filename//"'") + end if + end if + + if (present(iomsg).and.allocated(msg)) call move_alloc(msg, iomsg) + end +#:endfor +#:endfor + +#:for k1, t1 in KINDS_TYPES +#:for rank in RANKS + subroutine allocate_array_from_shape_${t1[0]}$${k1}$_${rank}$(array, vshape, stat) + ${t1}$, allocatable, intent(out) :: array${ranksuffix(rank)}$ + integer, intent(in) :: vshape(:) + integer, intent(out) :: stat + + allocate(array( & +#:for i in range(rank-1) + & vshape(${i+1}$), & +#:endfor + & vshape(${rank}$)), & + & stat=stat) + end +#:endfor +#:endfor + + !> Load multidimensional arrays from a compressed or uncompressed npz file. + module subroutine load_npz_to_arrays(filename, arrays, iostat, iomsg, tmp_dir) + character(len=*), intent(in) :: filename + type(array_wrapper_type), allocatable, intent(out) :: arrays(:) + integer, intent(out), optional :: iostat + character(len=:), allocatable, intent(out), optional :: iomsg + character(*), intent(in), optional :: tmp_dir + + integer :: stat + character(len=:), allocatable :: msg, unzip_dir + type(string_type), allocatable :: files(:) + + if (present(iostat)) iostat = 0 + if (present(tmp_dir)) then + unzip_dir = tmp_dir + else + unzip_dir = default_unzip_dir + end if + + call unzip(filename, unzip_dir, stat, msg) + if (stat /= 0) then + if (present(iostat)) iostat = stat + if (present(iomsg) .and. allocated(msg)) call move_alloc(msg, iomsg) + return + end if + + call list_dir(unzip_dir, files, stat, msg) + if (stat /= 0) then + if (present(iostat)) iostat = stat + if (present(iomsg) .and. allocated(msg)) call move_alloc(msg, iomsg) + return + end if + + call load_unzipped_files_to_arrays(files, unzip_dir, arrays, stat, msg) + if (stat /= 0) then + if (present(iostat)) iostat = stat + if (present(iomsg) .and. allocated(msg)) call move_alloc(msg, iomsg) + return + end if + end + + !> Load arrays from unzipped files. + subroutine load_unzipped_files_to_arrays(files, dir, arrays, stat, msg) + !> List of files to load arrays from. + type(string_type), intent(in) :: files(:) + !> Directory containing the files. + character(len=*), intent(in) :: dir + !> Array of array wrappers to store the loaded arrays. + type(array_wrapper_type), allocatable, intent(out) :: arrays(:) + !> Status of the operation. Zero on success. + integer, intent(out) :: stat + !> Error message in case of non-zero status. + character(len=:), allocatable, intent(out) :: msg + + integer :: i, io + integer, allocatable :: vshape(:) + character(len=:), allocatable :: this_type, array_name, path + + stat = 0 + allocate(arrays(size(files))) + + do i = 1, size(files) + array_name = as_string(files(i)) + path = dir//'/'//array_name + + open(newunit=io, file=path, form='unformatted', access='stream', iostat=stat, iomsg=msg) + if (stat /= 0) return + + call get_descriptor(io, array_name, this_type, vshape, stat, msg) + if (stat /= 0) then + close(io, status='delete'); return + end if + + select case (this_type) +#:for k1, t1 in KINDS_TYPES + case (type_${t1[0]}$${k1}$) + select case (size(vshape)) +#:for rank in RANKS + case (${rank}$) + block + ${t1}$, allocatable :: array${ranksuffix(rank)}$ + + call allocate_array_from_shape_${t1[0]}$${k1}$_${rank}$(array, vshape, stat) + if (stat /= 0) then + msg = "Failed to allocate array of type '"//this_type//"'."; + close(io, status='delete'); return + end if + + read (io, iostat=stat) array + if (stat /= 0) then + msg = "Failed to read array of type '"//this_type//"' "//& + & 'with total size of '//to_string(product(vshape)) + close(io, status='delete'); return + end if + + allocate(array_type_${t1[0]}$${k1}$_${rank}$ :: arrays(i)%array, stat=stat) + if (stat /= 0) then + msg = "Failed to allocate array of type '"//this_type//"' "//& + & 'with total size of '//to_string(product(vshape)) + close(io, status='delete'); return + end if + + select type (typed_array => arrays(i)%array) + class is (array_type_${t1[0]}$${k1}$_${rank}$) + allocate(typed_array%values, source=array) + class default + msg = 'Failed to allocate values.'; stat = 1 + close(io, status='delete'); return + end select + + arrays(i)%array%name = array_name + end block +#:endfor + case default + stat = 1; msg = 'Unsupported rank for array of type '//this_type//': '// & + & to_string(size(vshape))//'.' + close(io, status='delete'); return + end select +#:endfor + case default + stat = 1; msg = 'Unsupported array type: '//this_type//'.' + close(io, status='delete'); return + end select + + close (io, status='delete') + if (stat /= 0) return + end do + end + + !> Read the npy header from a binary file and retrieve the descriptor string. + subroutine get_descriptor(io, filename, vtype, vshape, stat, msg) + !> Unformatted, stream accessed unit + integer, intent(in) :: io + !> Filename for error reporting + character(len=*), intent(in) :: filename + !> Type of data saved in npy file + character(len=:), allocatable, intent(out) :: vtype + !> Shape descriptor of the + integer, allocatable, intent(out) :: vshape(:) + !> Status of operation + integer, intent(out) :: stat + !> Associated error message in case of non-zero status + character(len=:), allocatable, intent(out) :: msg + + integer :: major, header_len, i + character(len=:), allocatable :: dict + character(len=8) :: header + character :: buf(4) + logical :: fortran_order + + ! stat should be zero if no error occurred + stat = 0 + + read(io, iostat=stat) header + if (stat /= 0) return + + call parse_header(header, major, stat, msg) + if (stat /= 0) return + + read(io, iostat=stat) buf(1:merge(4, 2, major > 1)) + if (stat /= 0) return + + if (major > 1) then + header_len = ichar(buf(1)) & + & + ichar(buf(2)) * 256**1 & + & + ichar(buf(3)) * 256**2 & + & + ichar(buf(4)) * 256**3 + else + header_len = ichar(buf(1)) & + & + ichar(buf(2)) * 256**1 + end if + allocate(character(header_len) :: dict, stat=stat) + if (stat /= 0) return + + read(io, iostat=stat) dict + if (stat /= 0) return + + if (dict(header_len:header_len) /= nl) then + stat = 1 + msg = "Descriptor length does not match" + return + end if + + if (scan(dict, achar(0)) > 0) then + stat = 1 + msg = "Nul byte not allowed in descriptor string" + return + end if + + call parse_descriptor(trim(dict(:len(dict)-1)), filename, & + & vtype, fortran_order, vshape, stat, msg) + if (stat /= 0) return + + if (.not.fortran_order) then + vshape = [(vshape(i), i = size(vshape), 1, -1)] + end if + end + + + !> Parse the first eight bytes of the npy header to verify the data + subroutine parse_header(header, major, stat, msg) + !> Header of the binary file + character(len=*), intent(in) :: header + !> Major version of the npy format + integer, intent(out) :: major + !> Status of operation + integer, intent(out) :: stat + !> Associated error message in case of non-zero status + character(len=:), allocatable, intent(out) :: msg + + integer :: minor + + ! stat should be zero if no error occurred + stat = 0 + + if (header(1:1) /= magic_number) then + stat = 1 + msg = "Expected z'93' but got z'"//to_string(ichar(header(1:1)))//"' "//& + & "as first byte" + return + end if + + if (header(2:6) /= magic_string) then + stat = 1 + msg = "Expected identifier '"//magic_string//"'" + return + end if + + major = ichar(header(7:7)) + if (.not.any(major == [1, 2, 3])) then + stat = 1 + msg = "Unsupported format major version number '"//to_string(major)//"'" + return + end if + + minor = ichar(header(8:8)) + if (minor /= 0) then + stat = 1 + msg = "Unsupported format version "// & + & "'"//to_string(major)//"."//to_string(minor)//"'" + return + end if + end + + !> Parse the descriptor in the npy header. This routine implements a minimal + !> non-recursive parser for serialized Python dictionaries. + subroutine parse_descriptor(input, filename, vtype, fortran_order, vshape, stat, msg) + !> Input string to parse as descriptor + character(len=*), intent(in) :: input + !> Filename for error reporting + character(len=*), intent(in) :: filename + !> Type of the data stored, retrieved from field `descr` + character(len=:), allocatable, intent(out) :: vtype + !> Whether the data is in left layout, retrieved from field `fortran_order` + logical, intent(out) :: fortran_order + !> Shape of the stored data, retrieved from field `shape` + integer, allocatable, intent(out) :: vshape(:) + !> Status of operation + integer, intent(out) :: stat + !> Associated error message in case of non-zero status + character(len=:), allocatable, intent(out) :: msg + + enum, bind(c) + enumerator :: invalid, string, lbrace, rbrace, comma, colon, & + lparen, rparen, bool, literal, space + end enum + + type :: token_type + integer :: first, last, kind + end type token_type + + integer :: pos + character(len=:), allocatable :: key + type(token_type) :: token, last + logical :: has_descr, has_shape, has_fortran_order + + has_descr = .false. + has_shape = .false. + has_fortran_order = .false. + pos = 0 + call next_token(input, pos, token, [lbrace], stat, msg) + if (stat /= 0) return + + last = token_type(pos, pos, comma) + do while (pos < len(input)) + call get_token(input, pos, token) + select case(token%kind) + case(space) + continue + case(comma) + if (token%kind == last%kind) then + stat = 1 + msg = make_message(filename, input, token%first, token%last, & + & "Comma cannot appear at this point") + return + end if + last = token + case(rbrace) + exit + case(string) + if (token%kind == last%kind) then + stat = 1 + msg = make_message(filename, input, token%first, token%last, & + & "String cannot appear at this point") + return + end if + last = token + + key = input(token%first+1:token%last-1) + call next_token(input, pos, token, [colon], stat, msg) + if (stat /= 0) return + + if (key == "descr" .and. has_descr & + & .or. key == "fortran_order" .and. has_fortran_order & + & .or. key == "shape" .and. has_shape) then + stat = 1 + msg = make_message(filename, input, last%first, last%last, & + & "Duplicate entry for '"//key//"' found") + return + end if + + select case(key) + case("descr") + call next_token(input, pos, token, [string], stat, msg) + if (stat /= 0) return + + vtype = input(token%first+1:token%last-1) + has_descr = .true. + + case("fortran_order") + call next_token(input, pos, token, [bool], stat, msg) + if (stat /= 0) return + + fortran_order = input(token%first:token%last) == "True" + has_fortran_order = .true. + + case("shape") + call parse_tuple(input, pos, vshape, stat, msg) + + has_shape = .true. + + case default + stat = 1 + msg = make_message(filename, input, last%first, last%last, & + & "Invalid entry '"//key//"' in dictionary encountered") + return + end select + case default + stat = 1 + msg = make_message(filename, input, token%first, token%last, & + & "Invalid token encountered") + return + end select + end do + + if (.not.has_descr) then + stat = 1 + msg = make_message(filename, input, 1, pos, & + & "Dictionary does not contain required entry 'descr'") + end if + + if (.not.has_shape) then + stat = 1 + msg = make_message(filename, input, 1, pos, & + & "Dictionary does not contain required entry 'shape'") + end if + + if (.not.has_fortran_order) then + stat = 1 + msg = make_message(filename, input, 1, pos, & + & "Dictionary does not contain required entry 'fortran_order'") + end if + + contains + + function make_message(filename, input, first, last, message) result(str) + !> Filename for context + character(len=*), intent(in) :: filename + !> Input string to parse + character(len=*), intent(in) :: input + !> Offset in the input + integer, intent(in) :: first, last + !> Error message + character(len=*), intent(in) :: message + !> Final output message + character(len=:), allocatable :: str + + character(len=*), parameter :: nl = new_line('a') + + str = message // nl // & + & " --> " // filename // ":1:" // to_string(first) // "-" // to_string(last) // nl // & + & " |" // nl // & + & "1 | " // input // nl // & + & " |" // repeat(" ", first) // repeat("^", last - first + 1) // nl // & + & " |" + end + + !> Parse a tuple of integers into an array of integers + subroutine parse_tuple(input, pos, tuple, stat, msg) + !> Input string to parse + character(len=*), intent(in) :: input + !> Offset in the input, will be advanced after reading + integer, intent(inout) :: pos + !> Array representing tuple of integers + integer, allocatable, intent(out) :: tuple(:) + !> Status of operation + integer, intent(out) :: stat + !> Associated error message in case of non-zero status + character(len=:), allocatable, intent(out) :: msg + + type(token_type) :: token + integer :: last, itmp + + allocate(tuple(0), stat=stat) + if (stat /= 0) return + + call next_token(input, pos, token, [lparen], stat, msg) + if (stat /= 0) return + + last = comma + do while (pos < len(input)) + call get_token(input, pos, token) + select case(token%kind) + case(space) + continue + case(literal) + if (token%kind == last) then + stat = 1 + msg = make_message(filename, input, token%first, token%last, & + & "Invalid token encountered") + return + end if + last = token%kind + read(input(token%first:token%last), *, iostat=stat) itmp + if (stat /= 0) then + return + end if + tuple = [tuple, itmp] + case(comma) + if (token%kind == last) then + stat = 1 + msg = make_message(filename, input, token%first, token%last, & + & "Invalid token encountered") + return + end if + last = token%kind + case(rparen) + exit + case default + stat = 1 + msg = make_message(filename, input, token%first, token%last, & + & "Invalid token encountered") + return + end select + end do + end + + !> Get the next allowed token + subroutine next_token(input, pos, token, allowed_token, stat, msg) + !> Input string to parse + character(len=*), intent(in) :: input + !> Current offset in the input string + integer, intent(inout) :: pos + !> Last token parsed + type(token_type), intent(out) :: token + !> Tokens allowed in the current context + integer, intent(in) :: allowed_token(:) + !> Status of operation + integer, intent(out) :: stat + !> Associated error message in case of non-zero status + character(len=:), allocatable, intent(out) :: msg + + stat = pos + do while (pos < len(input)) + call get_token(input, pos, token) + if (token%kind == space) then + continue + else if (any(token%kind == allowed_token)) then + stat = 0 + exit + else + stat = 1 + msg = make_message(filename, input, token%first, token%last, & + & "Invalid token encountered") + exit + end if + end do + end + + !> Tokenize input string + subroutine get_token(input, pos, token) + !> Input strin to tokenize + character(len=*), intent(in) :: input + !> Offset in input string, will be advanced + integer, intent(inout) :: pos + !> Returned token from the next position + type(token_type), intent(out) :: token + + character :: quote + + pos = pos + 1 + select case(input(pos:pos)) + case("""", "'") + quote = input(pos:pos) + token%first = pos + pos = pos + 1 + do while (pos <= len(input)) + if (input(pos:pos) == quote) then + token%last = pos + exit + else + pos = pos + 1 + end if + end do + token%kind = string + case("0", "1", "2", "3", "4", "5", "6", "7", "8", "9") + token%first = pos + do while (pos <= len(input)) + if (.not.any(input(pos:pos) == ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"])) then + pos = pos - 1 + token%last = pos + exit + else + pos = pos + 1 + end if + end do + token%kind = literal + case("T") + if (starts_with(input(pos:), "True")) then + token = token_type(pos, pos+3, bool) + pos = pos + 3 + else + token = token_type(pos, pos, invalid) + end if + case("F") + if (starts_with(input(pos:), "False")) then + token = token_type(pos, pos+4, bool) + pos = pos + 4 + else + token = token_type(pos, pos, invalid) + end if + case("{") + token = token_type(pos, pos, lbrace) + case("}") + token = token_type(pos, pos, rbrace) + case(",") + token = token_type(pos, pos, comma) + case(":") + token = token_type(pos, pos, colon) + case("(") + token = token_type(pos, pos, lparen) + case(")") + token = token_type(pos, pos, rparen) + case(" ", nl) + token = token_type(pos, pos, space) + case default + token = token_type(pos, pos, invalid) + end select + end + end +end diff --git a/src/stdlib_io_np_save.fypp b/src/stdlib_io_np_save.fypp new file mode 100644 index 000000000..1b81b588f --- /dev/null +++ b/src/stdlib_io_np_save.fypp @@ -0,0 +1,221 @@ +! SPDX-Identifier: MIT + +#:include "common.fypp" +#:set RANKS = range(1, MAXRANK + 1) +#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES + +!> Implementation of saving multidimensional arrays to npy files +submodule(stdlib_io_np) stdlib_io_np_save + use stdlib_array + use stdlib_error, only: error_stop + use stdlib_io_filesystem, only: run + use stdlib_io_zip, only: zip + use stdlib_strings, only: to_string + use stdlib_string_type, only: string_type, as_string => char + implicit none + +contains + + !> Generate magic header string for npy format + pure function magic_header(major, minor) result(str) + !> Major version of npy format + integer, intent(in) :: major + !> Minor version of npy format + integer, intent(in) :: minor + !> Magic string for npy format + character(len=8) :: str + + str = magic_number//magic_string//achar(major)//achar(minor) + end + + !> Generate header for npy format + pure function npy_header(vtype, vshape) result(str) + !> Type of variable + character(len=*), intent(in) :: vtype + !> Shape of variable + integer, intent(in) :: vshape(:) + !> Header string for npy format + character(len=:), allocatable :: str + + integer, parameter :: len_v10 = 8 + 2, len_v20 = 8 + 4, block_size = 64 + + str = & + "{'descr': '"//vtype// & + "', 'fortran_order': True, 'shape': "// & + shape_str(vshape)//", }" + + if (len(str) + len_v10 >= 65535) then + str = str// & + & repeat(" ", block_size - mod(len(str) + len_v20 + 1, block_size))//nl + str = magic_header(2, 0)//to_bytes_i4(int(len(str)))//str + else + str = str// & + & repeat(" ", block_size - mod(len(str) + len_v10 + 1, block_size))//nl + str = magic_header(1, 0)//to_bytes_i2(int(len(str)))//str + end if + end + + !> Write integer as byte string in little endian encoding + pure function to_bytes_i4(val) result(str) + !> Integer value to convert to bytes + integer, intent(in) :: val + !> String of bytes + character(len=4) :: str + + str = achar(mod(val, 256**1))// & + & achar(mod(val, 256**2)/256**1)// & + & achar(mod(val, 256**3)/256**2)// & + & achar(val/256**3) + end + + !> Write integer as byte string in little endian encoding, 2-byte truncated version + pure function to_bytes_i2(val) result(str) + !> Integer value to convert to bytes + integer, intent(in) :: val + !> String of bytes + character(len=2) :: str + + str = achar(mod(val, 2**8))// & + & achar(mod(val, 2**16)/2**8) + end + + !> Print array shape as tuple of int + pure function shape_str(vshape) result(str) + !> Shape of variable + integer, intent(in) :: vshape(:) + !> Shape string for npy format + character(len=:), allocatable :: str + + integer :: i + + str = "(" + do i = 1, size(vshape) + str = str//to_string(vshape(i))//", " + end do + str = str//")" + end + +#:for k1, t1 in KINDS_TYPES +#:for rank in RANKS + !> Save ${rank}$-dimensional array in npy format + module subroutine save_npy_${t1[0]}$${k1}$_${rank}$(filename, array, iostat, iomsg) + !> Name of the npy file to load from + character(len=*), intent(in) :: filename + !> Array to be loaded from the npy file + ${t1}$, intent(in) :: array${ranksuffix(rank)}$ + !> Error status of loading, zero on success + integer, intent(out), optional :: iostat + !> Associated error message in case of non-zero status code + character(len=:), allocatable, intent(out), optional :: iomsg + + character(len=*), parameter :: vtype = type_${t1[0]}$${k1}$ + integer :: io, stat + + open (newunit=io, file=filename, form="unformatted", access="stream", iostat=stat) + if (stat == 0) then + write (io, iostat=stat) npy_header(vtype, shape(array)) + end if + if (stat == 0) then + write (io, iostat=stat) array + end if + close (io, iostat=stat) + + if (present(iostat)) then + iostat = stat + else if (stat /= 0) then + call error_stop("Failed to write array to file '"//filename//"'") + end if + + if (present(iomsg)) then + if (stat /= 0) then + iomsg = "Failed to write array to file '"//filename//"'" + end if + end if + end +#:endfor +#:endfor + + !> Save multidimensional arrays to a compressed or an uncompressed npz file. + module subroutine save_arrays_to_npz(filename, arrays, iostat, iomsg, compressed) + !> Name of the npz file to save to. + character(len=*), intent(in) :: filename + !> Arrays to be saved. + type(array_wrapper_type), intent(in) :: arrays(:) + !> Optional error status of saving, zero on success. + integer, intent(out), optional :: iostat + !> Optional error message. + character(len=:), allocatable, intent(out), optional :: iomsg + !> If true, the file is saved in compressed format. The default is false. + logical, intent(in), optional :: compressed + + integer :: i, j, stat + logical :: is_compressed + character(len=:), allocatable :: msg + type(string_type), allocatable :: files(:) + + if (present(iostat)) iostat = 0 + stat = 0 + + if (present(compressed)) then + is_compressed = compressed + else + is_compressed = .false. + end if + + allocate(files(0)) + do i = 1, size(arrays) + select type (typed_array => arrays(i)%array) +#:for k1, t1 in KINDS_TYPES +#:for rank in RANKS + class is (array_type_${t1[0]}$${k1}$_${rank}$) + do j = 1, size(files) + if (as_string(files(j)) == typed_array%name) then + if (present(iostat)) iostat = 1 + if (present(iomsg)) iomsg = "Error saving array to file '"//filename// & + "': Array with the same name '"//typed_array%name//"' already exists." + call delete_files(files) + return + end if + end do + + call save_npy(typed_array%name, typed_array%values, stat, msg) + if (stat /= 0) then + if (present(iostat)) iostat = stat + if (present(iomsg)) iomsg = msg + call delete_files(files) + return + end if + + files = [files, string_type(typed_array%name)] +#:endfor +#:endfor + class default + if (present(iostat)) iostat = 1 + if (present(iomsg)) iomsg = "Error saving array to file '"//filename//"': Unsupported array type." + call delete_files(files) + return + end select + end do + + call zip(filename, files, stat, msg, is_compressed) + if (stat /= 0) then + if (present(iostat)) iostat = stat + if (present(iomsg)) iomsg = msg + call delete_files(files) + return + end if + + call delete_files(files) + end + + subroutine delete_files(files) + type(string_type), allocatable, intent(in) :: files(:) + + integer :: i, unit + + do i = 1, size(files) + open(newunit=unit, file=as_string(files(i))) + close(unit, status="delete") + end do + end +end diff --git a/src/stdlib_io_npy_load.fypp b/src/stdlib_io_npy_load.fypp deleted file mode 100644 index 389f24cd2..000000000 --- a/src/stdlib_io_npy_load.fypp +++ /dev/null @@ -1,539 +0,0 @@ -! SPDX-Identifier: MIT - -#:include "common.fypp" -#:set RANKS = range(1, MAXRANK + 1) -#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES - -!> Implementation of loading npy files into multidimensional arrays -submodule (stdlib_io_npy) stdlib_io_npy_load - use stdlib_error, only : error_stop - use stdlib_strings, only : to_string, starts_with - implicit none - -contains - -#:for k1, t1 in KINDS_TYPES - #:for rank in RANKS - !> Load a ${rank}$-dimensional array from a npy file - module subroutine load_npy_${t1[0]}$${k1}$_${rank}$(filename, array, iostat, iomsg) - !> Name of the npy file to load from - character(len=*), intent(in) :: filename - !> Array to be loaded from the npy file - ${t1}$, allocatable, intent(out) :: array${ranksuffix(rank)}$ - !> Error status of loading, zero on success - integer, intent(out), optional :: iostat - !> Associated error message in case of non-zero status code - character(len=:), allocatable, intent(out), optional :: iomsg - - character(len=*), parameter :: vtype = type_${t1[0]}$${k1}$ - integer, parameter :: rank = ${rank}$ - - integer :: io, stat - character(len=:), allocatable :: msg - - open(newunit=io, file=filename, form="unformatted", access="stream", iostat=stat) - catch: block - character(len=:), allocatable :: this_type - integer, allocatable :: vshape(:) - - call get_descriptor(io, filename, this_type, vshape, stat, msg) - if (stat /= 0) exit catch - - if (this_type /= vtype) then - stat = 1 - msg = "File '"//filename//"' contains data of type '"//this_type//"', "//& - & "but expected '"//vtype//"'" - exit catch - end if - - if (size(vshape) /= rank) then - stat = 1 - msg = "File '"//filename//"' contains data of rank "//& - & to_string(size(vshape))//", but expected "//& - & to_string(rank) - exit catch - end if - - call allocator(array, vshape, stat) - if (stat /= 0) then - msg = "Failed to allocate array of type '"//vtype//"' "//& - & "with total size of "//to_string(product(vshape)) - exit catch - end if - - read(io, iostat=stat) array - end block catch - close(io) - - if (present(iostat)) then - iostat = stat - else if (stat /= 0) then - if (allocated(msg)) then - call error_stop("Failed to read array from file '"//filename//"'"//nl//& - & msg) - else - call error_stop("Failed to read array from file '"//filename//"'") - end if - end if - - if (present(iomsg).and.allocated(msg)) call move_alloc(msg, iomsg) - contains - - !> Wrapped intrinsic allocate to create an allocation from a shape array - subroutine allocator(array, vshape, stat) - !> Instance of the array to be allocated - ${t1}$, allocatable, intent(out) :: array${ranksuffix(rank)}$ - !> Dimensions to allocate for - integer, intent(in) :: vshape(:) - !> Status of allocate - integer, intent(out) :: stat - - allocate(array( & - #:for i in range(rank-1) - & vshape(${i+1}$), & - #:endfor - & vshape(${rank}$)), & - & stat=stat) - - end subroutine allocator - - end subroutine load_npy_${t1[0]}$${k1}$_${rank}$ - #:endfor -#:endfor - - - !> Read the npy header from a binary file and retrieve the descriptor string. - subroutine get_descriptor(io, filename, vtype, vshape, stat, msg) - !> Unformatted, stream accessed unit - integer, intent(in) :: io - !> Filename for error reporting - character(len=*), intent(in) :: filename - !> Type of data saved in npy file - character(len=:), allocatable, intent(out) :: vtype - !> Shape descriptor of the - integer, allocatable, intent(out) :: vshape(:) - !> Status of operation - integer, intent(out) :: stat - !> Associated error message in case of non-zero status - character(len=:), allocatable, intent(out) :: msg - - integer :: major, header_len, i - character(len=:), allocatable :: dict - character(len=8) :: header - character :: buf(4) - logical :: fortran_order - - ! stat should be zero if no error occurred - stat = 0 - - read(io, iostat=stat) header - if (stat /= 0) return - - call parse_header(header, major, stat, msg) - if (stat /= 0) return - - read(io, iostat=stat) buf(1:merge(4, 2, major > 1)) - if (stat /= 0) return - - if (major > 1) then - header_len = ichar(buf(1)) & - & + ichar(buf(2)) * 256**1 & - & + ichar(buf(3)) * 256**2 & - & + ichar(buf(4)) * 256**3 - else - header_len = ichar(buf(1)) & - & + ichar(buf(2)) * 256**1 - end if - allocate(character(header_len) :: dict, stat=stat) - if (stat /= 0) return - - read(io, iostat=stat) dict - if (stat /= 0) return - - if (dict(header_len:header_len) /= nl) then - stat = 1 - msg = "Descriptor length does not match" - return - end if - - if (scan(dict, achar(0)) > 0) then - stat = 1 - msg = "Nul byte not allowed in descriptor string" - return - end if - - call parse_descriptor(trim(dict(:len(dict)-1)), filename, & - & vtype, fortran_order, vshape, stat, msg) - if (stat /= 0) return - - if (.not.fortran_order) then - vshape = [(vshape(i), i = size(vshape), 1, -1)] - end if - end subroutine get_descriptor - - - !> Parse the first eight bytes of the npy header to verify the data - subroutine parse_header(header, major, stat, msg) - !> Header of the binary file - character(len=*), intent(in) :: header - !> Major version of the npy format - integer, intent(out) :: major - !> Status of operation - integer, intent(out) :: stat - !> Associated error message in case of non-zero status - character(len=:), allocatable, intent(out) :: msg - - integer :: minor - - ! stat should be zero if no error occurred - stat = 0 - - if (header(1:1) /= magic_number) then - stat = 1 - msg = "Expected z'93' but got z'"//to_string(ichar(header(1:1)))//"' "//& - & "as first byte" - return - end if - - if (header(2:6) /= magic_string) then - stat = 1 - msg = "Expected identifier '"//magic_string//"'" - return - end if - - major = ichar(header(7:7)) - if (.not.any(major == [1, 2, 3])) then - stat = 1 - msg = "Unsupported format major version number '"//to_string(major)//"'" - return - end if - - minor = ichar(header(8:8)) - if (minor /= 0) then - stat = 1 - msg = "Unsupported format version "// & - & "'"//to_string(major)//"."//to_string(minor)//"'" - return - end if - end subroutine parse_header - - !> Parse the descriptor in the npy header. This routine implements a minimal - !> non-recursive parser for serialized Python dictionaries. - subroutine parse_descriptor(input, filename, vtype, fortran_order, vshape, stat, msg) - !> Input string to parse as descriptor - character(len=*), intent(in) :: input - !> Filename for error reporting - character(len=*), intent(in) :: filename - !> Type of the data stored, retrieved from field `descr` - character(len=:), allocatable, intent(out) :: vtype - !> Whether the data is in left layout, retrieved from field `fortran_order` - logical, intent(out) :: fortran_order - !> Shape of the stored data, retrieved from field `shape` - integer, allocatable, intent(out) :: vshape(:) - !> Status of operation - integer, intent(out) :: stat - !> Associated error message in case of non-zero status - character(len=:), allocatable, intent(out) :: msg - - enum, bind(c) - enumerator :: invalid, string, lbrace, rbrace, comma, colon, & - lparen, rparen, bool, literal, space - end enum - - type :: token_type - integer :: first, last, kind - end type token_type - - integer :: pos - character(len=:), allocatable :: key - type(token_type) :: token, last - logical :: has_descr, has_shape, has_fortran_order - - has_descr = .false. - has_shape = .false. - has_fortran_order = .false. - pos = 0 - call next_token(input, pos, token, [lbrace], stat, msg) - if (stat /= 0) return - - last = token_type(pos, pos, comma) - do while (pos < len(input)) - call get_token(input, pos, token) - select case(token%kind) - case(space) - continue - case(comma) - if (token%kind == last%kind) then - stat = 1 - msg = make_message(filename, input, token%first, token%last, & - & "Comma cannot appear at this point") - return - end if - last = token - case(rbrace) - exit - case(string) - if (token%kind == last%kind) then - stat = 1 - msg = make_message(filename, input, token%first, token%last, & - & "String cannot appear at this point") - return - end if - last = token - - key = input(token%first+1:token%last-1) - call next_token(input, pos, token, [colon], stat, msg) - if (stat /= 0) return - - if (key == "descr" .and. has_descr & - & .or. key == "fortran_order" .and. has_fortran_order & - & .or. key == "shape" .and. has_shape) then - stat = 1 - msg = make_message(filename, input, last%first, last%last, & - & "Duplicate entry for '"//key//"' found") - return - end if - - select case(key) - case("descr") - call next_token(input, pos, token, [string], stat, msg) - if (stat /= 0) return - - vtype = input(token%first+1:token%last-1) - has_descr = .true. - - case("fortran_order") - call next_token(input, pos, token, [bool], stat, msg) - if (stat /= 0) return - - fortran_order = input(token%first:token%last) == "True" - has_fortran_order = .true. - - case("shape") - call parse_tuple(input, pos, vshape, stat, msg) - - has_shape = .true. - - case default - stat = 1 - msg = make_message(filename, input, last%first, last%last, & - & "Invalid entry '"//key//"' in dictionary encountered") - return - end select - case default - stat = 1 - msg = make_message(filename, input, token%first, token%last, & - & "Invalid token encountered") - return - end select - end do - - if (.not.has_descr) then - stat = 1 - msg = make_message(filename, input, 1, pos, & - & "Dictionary does not contain required entry 'descr'") - end if - - if (.not.has_shape) then - stat = 1 - msg = make_message(filename, input, 1, pos, & - & "Dictionary does not contain required entry 'shape'") - end if - - if (.not.has_fortran_order) then - stat = 1 - msg = make_message(filename, input, 1, pos, & - & "Dictionary does not contain required entry 'fortran_order'") - end if - - contains - - function make_message(filename, input, first, last, message) result(str) - !> Filename for context - character(len=*), intent(in) :: filename - !> Input string to parse - character(len=*), intent(in) :: input - !> Offset in the input - integer, intent(in) :: first, last - !> Error message - character(len=*), intent(in) :: message - !> Final output message - character(len=:), allocatable :: str - - character(len=*), parameter :: nl = new_line('a') - - str = message // nl // & - & " --> " // filename // ":1:" // to_string(first) // "-" // to_string(last) // nl // & - & " |" // nl // & - & "1 | " // input // nl // & - & " |" // repeat(" ", first) // repeat("^", last - first + 1) // nl // & - & " |" - end function make_message - - !> Parse a tuple of integers into an array of integers - subroutine parse_tuple(input, pos, tuple, stat, msg) - !> Input string to parse - character(len=*), intent(in) :: input - !> Offset in the input, will be advanced after reading - integer, intent(inout) :: pos - !> Array representing tuple of integers - integer, allocatable, intent(out) :: tuple(:) - !> Status of operation - integer, intent(out) :: stat - !> Associated error message in case of non-zero status - character(len=:), allocatable, intent(out) :: msg - - type(token_type) :: token - integer :: last, itmp - - allocate(tuple(0), stat=stat) - if (stat /= 0) return - - call next_token(input, pos, token, [lparen], stat, msg) - if (stat /= 0) return - - last = comma - do while (pos < len(input)) - call get_token(input, pos, token) - select case(token%kind) - case(space) - continue - case(literal) - if (token%kind == last) then - stat = 1 - msg = make_message(filename, input, token%first, token%last, & - & "Invalid token encountered") - return - end if - last = token%kind - read(input(token%first:token%last), *, iostat=stat) itmp - if (stat /= 0) then - return - end if - tuple = [tuple, itmp] - case(comma) - if (token%kind == last) then - stat = 1 - msg = make_message(filename, input, token%first, token%last, & - & "Invalid token encountered") - return - end if - last = token%kind - case(rparen) - exit - case default - stat = 1 - msg = make_message(filename, input, token%first, token%last, & - & "Invalid token encountered") - return - end select - end do - end subroutine parse_tuple - - !> Get the next allowed token - subroutine next_token(input, pos, token, allowed_token, stat, msg) - !> Input string to parse - character(len=*), intent(in) :: input - !> Current offset in the input string - integer, intent(inout) :: pos - !> Last token parsed - type(token_type), intent(out) :: token - !> Tokens allowed in the current context - integer, intent(in) :: allowed_token(:) - !> Status of operation - integer, intent(out) :: stat - !> Associated error message in case of non-zero status - character(len=:), allocatable, intent(out) :: msg - - stat = pos - do while (pos < len(input)) - call get_token(input, pos, token) - if (token%kind == space) then - continue - else if (any(token%kind == allowed_token)) then - stat = 0 - exit - else - stat = 1 - msg = make_message(filename, input, token%first, token%last, & - & "Invalid token encountered") - exit - end if - end do - end subroutine next_token - - !> Tokenize input string - subroutine get_token(input, pos, token) - !> Input strin to tokenize - character(len=*), intent(in) :: input - !> Offset in input string, will be advanced - integer, intent(inout) :: pos - !> Returned token from the next position - type(token_type), intent(out) :: token - - character :: quote - - pos = pos + 1 - select case(input(pos:pos)) - case("""", "'") - quote = input(pos:pos) - token%first = pos - pos = pos + 1 - do while (pos <= len(input)) - if (input(pos:pos) == quote) then - token%last = pos - exit - else - pos = pos + 1 - end if - end do - token%kind = string - case("0", "1", "2", "3", "4", "5", "6", "7", "8", "9") - token%first = pos - do while (pos <= len(input)) - if (.not.any(input(pos:pos) == ["0", "1", "2", "3", "4", "5", "6", "7", "8", "9"])) then - pos = pos - 1 - token%last = pos - exit - else - pos = pos + 1 - end if - end do - token%kind = literal - case("T") - if (starts_with(input(pos:), "True")) then - token = token_type(pos, pos+3, bool) - pos = pos + 3 - else - token = token_type(pos, pos, invalid) - end if - case("F") - if (starts_with(input(pos:), "False")) then - token = token_type(pos, pos+4, bool) - pos = pos + 4 - else - token = token_type(pos, pos, invalid) - end if - case("{") - token = token_type(pos, pos, lbrace) - case("}") - token = token_type(pos, pos, rbrace) - case(",") - token = token_type(pos, pos, comma) - case(":") - token = token_type(pos, pos, colon) - case("(") - token = token_type(pos, pos, lparen) - case(")") - token = token_type(pos, pos, rparen) - case(" ", nl) - token = token_type(pos, pos, space) - case default - token = token_type(pos, pos, invalid) - end select - - end subroutine get_token - - end subroutine parse_descriptor - -end submodule stdlib_io_npy_load diff --git a/src/stdlib_io_npy_save.fypp b/src/stdlib_io_npy_save.fypp deleted file mode 100644 index 706c3cd90..000000000 --- a/src/stdlib_io_npy_save.fypp +++ /dev/null @@ -1,139 +0,0 @@ -! SPDX-Identifer: MIT - -#:include "common.fypp" -#:set RANKS = range(1, MAXRANK + 1) -#:set KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + CMPLX_KINDS_TYPES - -!> Implementation of saving multidimensional arrays to npy files -submodule (stdlib_io_npy) stdlib_io_npy_save - use stdlib_error, only : error_stop - use stdlib_strings, only : to_string - implicit none - -contains - - - !> Generate magic header string for npy format - pure function magic_header(major, minor) result(str) - !> Major version of npy format - integer, intent(in) :: major - !> Minor version of npy format - integer, intent(in) :: minor - !> Magic string for npy format - character(len=8) :: str - - str = magic_number // magic_string // achar(major) // achar(minor) - end function magic_header - - - !> Generate header for npy format - pure function npy_header(vtype, vshape) result(str) - !> Type of variable - character(len=*), intent(in) :: vtype - !> Shape of variable - integer, intent(in) :: vshape(:) - !> Header string for npy format - character(len=:), allocatable :: str - - integer, parameter :: len_v10 = 8 + 2, len_v20 = 8 + 4, block_size = 64 - - str = & - "{'descr': '"//vtype//& - "', 'fortran_order': True, 'shape': "//& - shape_str(vshape)//", }" - - if (len(str) + len_v10 >= 65535) then - str = str // & - & repeat(" ", block_size - mod(len(str) + len_v20 + 1, block_size)) // nl - str = magic_header(2, 0) // to_bytes_i4(int(len(str))) // str - else - str = str // & - & repeat(" ", block_size - mod(len(str) + len_v10 + 1, block_size)) // nl - str = magic_header(1, 0) // to_bytes_i2(int(len(str))) // str - end if - end function npy_header - - !> Write integer as byte string in little endian encoding - pure function to_bytes_i4(val) result(str) - !> Integer value to convert to bytes - integer, intent(in) :: val - !> String of bytes - character(len=4) :: str - - str = achar(mod(val, 256**1)) // & - & achar(mod(val, 256**2) / 256**1) // & - & achar(mod(val, 256**3) / 256**2) // & - & achar(val / 256**3) - end function to_bytes_i4 - - - !> Write integer as byte string in little endian encoding, 2-byte truncated version - pure function to_bytes_i2(val) result(str) - !> Integer value to convert to bytes - integer, intent(in) :: val - !> String of bytes - character(len=2) :: str - - str = achar(mod(val, 2**8)) // & - & achar(mod(val, 2**16) / 2**8) - end function to_bytes_i2 - - - !> Print array shape as tuple of int - pure function shape_str(vshape) result(str) - !> Shape of variable - integer, intent(in) :: vshape(:) - !> Shape string for npy format - character(len=:), allocatable :: str - - integer :: i - - str = "(" - do i = 1, size(vshape) - str = str//to_string(vshape(i))//", " - enddo - str = str//")" - end function shape_str - - -#:for k1, t1 in KINDS_TYPES - #:for rank in RANKS - !> Save ${rank}$-dimensional array in npy format - module subroutine save_npy_${t1[0]}$${k1}$_${rank}$(filename, array, iostat, iomsg) - !> Name of the npy file to load from - character(len=*), intent(in) :: filename - !> Array to be loaded from the npy file - ${t1}$, intent(in) :: array${ranksuffix(rank)}$ - !> Error status of loading, zero on success - integer, intent(out), optional :: iostat - !> Associated error message in case of non-zero status code - character(len=:), allocatable, intent(out), optional :: iomsg - - character(len=*), parameter :: vtype = type_${t1[0]}$${k1}$ - integer :: io, stat - - open(newunit=io, file=filename, form="unformatted", access="stream", iostat=stat) - if (stat == 0) then - write(io, iostat=stat) npy_header(vtype, shape(array)) - end if - if (stat == 0) then - write(io, iostat=stat) array - end if - close(io, iostat=stat) - - if (present(iostat)) then - iostat = stat - else if (stat /= 0) then - call error_stop("Failed to write array to file '"//filename//"'") - end if - - if (present(iomsg)) then - if (stat /= 0) then - iomsg = "Failed to write array to file '"//filename//"'" - end if - end if - end subroutine save_npy_${t1[0]}$${k1}$_${rank}$ - #:endfor -#:endfor - -end submodule stdlib_io_npy_save diff --git a/src/stdlib_io_zip.f90 b/src/stdlib_io_zip.f90 new file mode 100644 index 000000000..23629f058 --- /dev/null +++ b/src/stdlib_io_zip.f90 @@ -0,0 +1,118 @@ +! SPDX-Identifier: MIT + +!> Handling of zip files including creation and extraction. +module stdlib_io_zip + use stdlib_io_filesystem, only: exists, run, temp_dir + use stdlib_string_type, only: string_type, char + use stdlib_strings, only: starts_with + implicit none + private + + public :: zip, unzip, default_unzip_dir, zip_contents + + character(*), parameter :: default_unzip_dir = temp_dir//'/unzipped_files' + character(*), parameter :: zip_contents = default_unzip_dir//'/zip_contents.txt' + +contains + + !> Version: experimental + !> + !> Create a zip file from a list of files. + !> [Specification](../page/specs/stdlib_io.html#zip) + subroutine zip(output_file, files, stat, msg, compressed) + !> Name of the zip file to create. + character(*), intent(in) :: output_file + !> List of files to include in the zip file. + type(string_type), intent(in) :: files(:) + !> Optional error status of zipping, zero on success. + integer, intent(out), optional :: stat + !> Optional error message. + character(len=:), allocatable, intent(out), optional :: msg + !> If true, the file is saved in compressed format. The default is true. + logical, intent(in), optional :: compressed + + integer :: run_stat, i + character(:), allocatable :: files_str, cmd + logical :: is_compressed + + if (present(stat)) stat = 0 + run_stat = 0 + + if (present(compressed)) then + is_compressed = compressed + else + is_compressed = .true. + end if + + if (trim(output_file) == '') then + if (present(stat)) stat = 1 + if (present(msg)) msg = "Output file is empty." + return + end if + + files_str = '' + do i = 1, size(files) + files_str = files_str//' '//char(files(i)) + end do + + cmd = 'zip -q '//''//output_file//' '//files_str + if (.not. is_compressed) cmd = cmd//' -0' + + call run(cmd, run_stat) + if (run_stat /= 0) then + if (present(stat)) stat = run_stat + if (present(msg)) msg = "Error creating zip file '"//output_file//"'." + return + end if + end + + !> Version: experimental + !> + !> Extract a zip file to a directory. + !> [Specification](../page/specs/stdlib_io.html#unzip) + subroutine unzip(filename, outputdir, stat, msg) + !> Name of the zip file to extract. + character(len=*), intent(in) :: filename + !> Directory to extract the zip file to. + character(len=*), intent(in), optional :: outputdir + !> Optional error status of unzipping, zero on success. + integer, intent(out), optional :: stat + !> Optional error message. + character(len=:), allocatable, intent(out), optional :: msg + + integer :: run_stat + character(:), allocatable :: output_dir + + if (present(outputdir)) then + output_dir = outputdir + else + output_dir = default_unzip_dir + end if + + if (present(stat)) stat = 0 + run_stat = 0 + + call run('rm -rf '//output_dir, run_stat) + if (run_stat /= 0) then + if (present(stat)) stat = run_stat + if (present(msg)) msg = "Error removing folder '"//output_dir//"'." + return + end if + + if (starts_with(output_dir, temp_dir) .and. .not. exists(temp_dir)) then + call run('mkdir '//temp_dir, run_stat) + if (run_stat /= 0) then + if (present(stat)) stat = run_stat + if (present(msg)) msg = "Error creating folder '"//temp_dir//"'." + return + end if + end if + + call run('unzip -q '//filename//' -d '//output_dir, run_stat) + if (run_stat /= 0) then + if (present(stat)) stat = run_stat + if (present(msg)) msg = "Error unzipping '"//filename//"'." + return + end if + end +end diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index 4d83548db..67001cea3 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -30,4 +30,4 @@ add_subdirectory(system) add_subdirectory(quadrature) add_subdirectory(math) add_subdirectory(stringlist) -add_subdirectory(terminal) \ No newline at end of file +add_subdirectory(terminal) diff --git a/test/io/CMakeLists.txt b/test/io/CMakeLists.txt index 98794cd88..7009b1e67 100644 --- a/test/io/CMakeLists.txt +++ b/test/io/CMakeLists.txt @@ -13,7 +13,12 @@ ADDTEST(savetxt_qp) set_tests_properties(loadtxt_qp PROPERTIES LABELS quadruple_precision) set_tests_properties(savetxt_qp PROPERTIES LABELS quadruple_precision) +ADDTEST(filesystem) ADDTEST(getline) -ADDTEST(npy) ADDTEST(open) ADDTEST(parse_mode) + +ADDTEST(np) +ADDTEST(zip) +set_tests_properties(np PROPERTIES WORKING_DIRECTORY ${PROJECT_SOURCE_DIR}) +set_tests_properties(zip PROPERTIES WORKING_DIRECTORY ${PROJECT_SOURCE_DIR}) diff --git a/test/io/test_filesystem.f90 b/test/io/test_filesystem.f90 new file mode 100644 index 000000000..fca2ecb02 --- /dev/null +++ b/test/io/test_filesystem.f90 @@ -0,0 +1,219 @@ +module test_filesystem + use stdlib_io_filesystem + use stdlib_string_type, only : char, string_type + use testdrive, only : new_unittest, unittest_type, error_type, check, test_failed + implicit none + private + + public :: collect_filesystem + + character(*), parameter :: temp_list_dir = 'temp_list_dir' + +contains + + !> Collect all exported unit tests + subroutine collect_filesystem(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("fs_file_not_exists", fs_file_not_exists, should_fail=.true.), & + new_unittest("fs_file_exists", fs_file_exists), & + new_unittest("fs_current_dir_exists", fs_current_dir_exists), & + new_unittest("fs_run_invalid_command", fs_run_invalid_command, should_fail=.true.), & + new_unittest("fs_run_with_invalid_option", fs_run_with_invalid_option, should_fail=.true.), & + new_unittest("fs_run_valid_command", fs_run_valid_command), & + new_unittest("fs_list_dir_empty", fs_list_dir_empty), & + new_unittest("fs_list_dir_one_file", fs_list_dir_one_file), & + new_unittest("fs_list_dir_two_files", fs_list_dir_two_files) & + ] + end + + subroutine fs_file_not_exists(error) + type(error_type), allocatable, intent(out) :: error + + logical :: is_existing + + is_existing = exists("nonexistent") + call check(error, is_existing, "Non-existent file should fail.") + end + + subroutine fs_file_exists(error) + type(error_type), allocatable, intent(out) :: error + + logical :: is_existing + integer :: unit + character(*), parameter :: filename = "file.tmp" + + open(newunit=unit, file=filename) + close(unit) + + is_existing = exists(filename) + call check(error, is_existing, "An existing file should not fail.") + call delete_file(filename) + end + + subroutine fs_current_dir_exists(error) + type(error_type), allocatable, intent(out) :: error + + logical :: is_existing + + is_existing = exists(".") + call check(error, is_existing, "Current directory should not fail.") + end + + subroutine fs_run_invalid_command(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat + + call run("invalid_command", iostat=stat) + call check(error, stat, "Running an invalid command should fail.") + end + + subroutine fs_run_with_invalid_option(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat + + call run("whoami -X", iostat=stat) + call check(error, stat, "Running a valid command with an invalid option should fail.") + end + + subroutine fs_run_valid_command(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat + + call run("whoami", iostat=stat) + call check(error, stat, "Running a valid command should not fail.") + end + + subroutine fs_list_dir_empty(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat + type(string_type), allocatable :: files(:) + + call run('rm -rf '//temp_list_dir, iostat=stat) + if (stat /= 0) then + call test_failed(error, "Removing directory '"//temp_list_dir//"' failed."); return + end if + + call run('mkdir '//temp_list_dir, iostat=stat) + if (stat /= 0) then + call test_failed(error, "Creating directory '"//temp_list_dir//"' failed."); return + end if + + call list_dir(temp_list_dir, files, stat) + call check(error, stat, "Listing the contents of an empty directory shouldn't fail.") + call check(error, size(files) == 0, "The directory should be empty.") + + call run('rm -rf '//temp_list_dir, iostat=stat) + end + + subroutine fs_list_dir_one_file(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat + + type(string_type), allocatable :: files(:) + character(*), parameter :: filename = 'abc.txt' + + call run('rm -rf '//temp_list_dir, iostat=stat) + if (stat /= 0) then + call test_failed(error, "Removing directory '"//temp_list_dir//"' failed."); return + end if + + call run('mkdir '//temp_list_dir, iostat=stat) + if (stat /= 0) then + call test_failed(error, "Creating directory '"//temp_list_dir//"' failed."); return + end if + + call run('touch '//temp_list_dir//'/'//filename, iostat=stat) + if (stat /= 0) then + call test_failed(error, "Creating file'"//filename//"' in directory '"//temp_list_dir//"' failed."); return + end if + + call list_dir(temp_list_dir, files, stat) + call check(error, stat, "Listing the contents of an empty directory shouldn't fail.") + call check(error, size(files) == 1, "The directory should contain one file.") + call check(error, char(files(1)) == filename, "The file should be '"//filename//"'.") + + call run('rm -rf '//temp_list_dir, iostat=stat) + end + + subroutine fs_list_dir_two_files(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat + + type(string_type), allocatable :: files(:) + character(*), parameter :: filename1 = 'abc.txt' + character(*), parameter :: filename2 = 'xyz' + + call run('rm -rf '//temp_list_dir, iostat=stat) + if (stat /= 0) then + call test_failed(error, "Removing directory '"//temp_list_dir//"' failed."); return + end if + + call run('mkdir '//temp_list_dir, iostat=stat) + if (stat /= 0) then + call test_failed(error, "Creating directory '"//temp_list_dir//"' failed."); return + end if + + call run('touch '//temp_list_dir//'/'//filename1, iostat=stat) + if (stat /= 0) then + call test_failed(error, "Creating file 1 in directory '"//temp_list_dir//"' failed."); return + end if + + call run('touch '//temp_list_dir//'/'//filename2, iostat=stat) + if (stat /= 0) then + call test_failed(error, "Creating file 2 in directory '"//temp_list_dir//"' failed."); return + end if + + call list_dir(temp_list_dir, files, stat) + call check(error, stat, "Listing the contents of an empty directory shouldn't fail.") + call check(error, size(files) == 2, "The directory should contain two files.") + call check(error, char(files(1)) == filename1, "The file should be '"//filename1//"'.") + call check(error, char(files(2)) == filename2, "The file should be '"//filename2//"'.") + + call run('rm -rf '//temp_list_dir, iostat=stat) + end + + subroutine delete_file(filename) + character(len=*), intent(in) :: filename + + integer :: io + + open(newunit=io, file=filename) + close(io, status="delete") + end + +end + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use testdrive, only : run_testsuite, new_testsuite, testsuite_type + use test_filesystem, only : collect_filesystem + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("filesystem", collect_filesystem) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end diff --git a/test/io/test_np.f90 b/test/io/test_np.f90 new file mode 100644 index 000000000..a5ffb6c38 --- /dev/null +++ b/test/io/test_np.f90 @@ -0,0 +1,1348 @@ +module test_np + use stdlib_array + use stdlib_io_filesystem, only : temp_dir, exists + use stdlib_io_np, only : save_npy, load_npy, load_npz, save_npz + use stdlib_kinds, only : int8, int16, int32, int64, sp, dp + use testdrive, only : new_unittest, unittest_type, error_type, check, test_failed + implicit none + private + + public :: collect_np + + character(*), parameter :: path_to_zip_files = "test/io/zip_files/" + +contains + + !> Collect all exported unit tests + subroutine collect_np(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("read-rdp-r2", test_read_rdp_rank2), & + new_unittest("read-rdp-r3", test_read_rdp_rank3), & + new_unittest("read-rsp-r1", test_read_rsp_rank1), & + new_unittest("read-rsp-r2", test_read_rsp_rank2), & + new_unittest("write-rdp-r2", test_write_rdp_rank2), & + new_unittest("write-rsp-r2", test_write_rsp_rank2), & + new_unittest("write-i2-r4", test_write_int16_rank4), & + new_unittest("invalid-magic-number", test_invalid_magic_number, should_fail=.true.), & + new_unittest("invalid-magic-string", test_invalid_magic_string, should_fail=.true.), & + new_unittest("invalid-major-version", test_invalid_major_version, should_fail=.true.), & + new_unittest("invalid-minor-version", test_invalid_minor_version, should_fail=.true.), & + new_unittest("invalid-header-len", test_invalid_header_len, should_fail=.true.), & + new_unittest("invalid-nul-byte", test_invalid_nul_byte, should_fail=.true.), & + new_unittest("invalid-key", test_invalid_key, should_fail=.true.), & + new_unittest("invalid-comma", test_invalid_comma, should_fail=.true.), & + new_unittest("invalid-string", test_invalid_string, should_fail=.true.), & + new_unittest("duplicate-descr", test_duplicate_descr, should_fail=.true.), & + new_unittest("missing-descr", test_missing_descr, should_fail=.true.), & + new_unittest("missing-fortran_order", test_missing_fortran_order, should_fail=.true.), & + new_unittest("missing-shape", test_missing_shape, should_fail=.true.), & + new_unittest("iomsg-deallocated", test_iomsg_deallocated), & + new_unittest("npz_load_nonexistent_file", npz_load_nonexistent_file, should_fail=.true.), & + new_unittest("npz_load_invalid_dir", npz_load_invalid_dir, should_fail=.true.), & + new_unittest("npz_load_empty_file", npz_load_empty_file, should_fail=.true.), & + new_unittest("npz_load_empty_zip", npz_load_empty_zip, should_fail=.true.), & + new_unittest("npz_load_arr_empty_0", npz_load_arr_empty_0), & + new_unittest("npz_load_arr_rand_2_3", npz_load_arr_rand_2_3), & + new_unittest("npz_load_arr_arange_10_20", npz_load_arr_arange_10_20), & + new_unittest("npz_load_arr_cmplx", npz_load_arr_cmplx), & + new_unittest("npz_load_two_arr_iint64_rdp", npz_load_two_arr_iint64_rdp), & + new_unittest("npz_load_two_arr_iint64_rdp_comp", npz_load_two_arr_iint64_rdp_comp), & + new_unittest("add_array_to_empty", add_array_to_empty), & + new_unittest("add_two_arrays", add_two_arrays), & + new_unittest("add_array_custom_name", add_array_custom_name), & + new_unittest("add_array_empty_name", add_array_empty_name, should_fail=.true.), & + new_unittest("add_array_duplicate_names", add_array_duplicate_names, should_fail=.true.), & + new_unittest("npz_save_empty_array_input", npz_save_empty_array_input, should_fail=.true.), & + new_unittest("npz_save_one_array", npz_save_one_array), & + new_unittest("npz_save_two_arrays", npz_save_two_arrays), & + new_unittest("npz_get_values_unallocated", npz_get_values_unallocated, should_fail=.true.), & + new_unittest("npz_get_values_correct_type", npz_get_values_correct_type), & + new_unittest("npz_get_values_wrong_type", npz_get_values_wrong_type, should_fail=.true.), & + new_unittest("npz_get_values_two_arrays", npz_get_values_two_arrays) & + ] + end subroutine collect_np + + subroutine test_read_rdp_rank2(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr':' Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: stat + character(len=*), parameter :: filename = ".test-rdp-r2-rt.npy" + real(dp), allocatable :: input(:, :), output(:, :) + + allocate(input(10, 4)) + call random_number(input) + call save_npy(filename, input, stat) + + call check(error, stat, "Writing of npy file failed") + if (allocated(error)) return + + call load_npy(filename, output, stat) + call delete_file(filename) + + call check(error, stat, "Reading of npy file failed") + if (allocated(error)) return + + call check(error, size(output), size(input)) + if (allocated(error)) return + + call check(error, any(abs(output - input) <= epsilon(1.0_dp)), & + "Precision loss when rereading array") + end subroutine test_write_rdp_rank2 + + subroutine test_write_rsp_rank2(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: stat + character(len=*), parameter :: filename = ".test-rsp-r2-rt.npy" + real(sp), allocatable :: input(:, :), output(:, :) + + allocate(input(12, 5)) + call random_number(input) + call save_npy(filename, input, stat) + + call check(error, stat, "Writing of npy file failed") + if (allocated(error)) return + + call load_npy(filename, output, stat) + call delete_file(filename) + + call check(error, stat, "Reading of npy file failed") + if (allocated(error)) return + + call check(error, size(output), size(input)) + if (allocated(error)) return + + call check(error, any(abs(output - input) <= epsilon(1.0_dp)), & + "Precision loss when rereading array") + end subroutine test_write_rsp_rank2 + + subroutine test_write_int16_rank4(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: stat, i + character(len=*), parameter :: filename = ".test-i2-r4-rt.npy" + integer(int16), allocatable :: input(:, :, :, :), output(:, :, :, :) + + input = reshape([(i*(i+1)/2, i = 1, 40)], [2, 5, 2, 2]) + call save_npy(filename, input, stat) + + call check(error, stat, "Writing of npy file failed") + if (allocated(error)) return + + call load_npy(filename, output, stat) + call delete_file(filename) + + call check(error, stat, "Reading of npy file failed") + if (allocated(error)) return + + call check(error, size(output), size(input)) + if (allocated(error)) return + + call check(error, all(abs(output - input) == 0), & + "Precision loss when rereading array") + end subroutine test_write_int16_rank4 + + subroutine test_invalid_magic_number(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'fortran_order': True, 'shape': (10, 4, ), 'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'fortran_order': True,, 'shape': (10, 4, ), 'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'fortran_order': True, 'shape': (10, 4, ), 'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'fortran_order': True, 'shape': (10, 4, ), } " // & + char(10) + character(len=*), parameter :: header = & + char(int(z"93")) // "NUMPY" // char(1) // char(0) // & + char(len(dict)) // char(0) // dict + + integer :: io, stat + character(len=:), allocatable :: msg + character(len=*), parameter :: filename = ".test-missing-descr.npy" + real(dp), allocatable :: array(:, :) + + open(newunit=io, file=filename, form="unformatted", access="stream") + write(io) header + write(io) spread(0.0_dp, 1, 40) + close(io) + + call load_npy(filename, array, stat, msg) + call delete_file(filename) + + call check(error, stat, msg) + end subroutine test_missing_descr + + subroutine test_missing_fortran_order(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + character(len=*), parameter :: dict = & + "{'fortran_order': True, 'descr': ' Error handling + type(error_type), allocatable, intent(out) :: error + + integer :: stat + character(len=:), allocatable :: msg + + character(len=*), parameter :: filename = ".test-iomsg-deallocated.npy" + real(sp), allocatable :: input(:, :), output(:, :) + + msg = "This message should be deallocated." + + allocate(input(12, 5)) + call random_number(input) + call save_npy(filename, input, stat, msg) + call delete_file(filename) + + call check(error,.not. allocated(msg), "Message wrongly allocated.") + + end subroutine + + subroutine npz_load_nonexistent_file(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + + integer :: stat + character(*), parameter :: filename = "nonexistent.npz" + character(*), parameter :: tmp = temp_dir//"/nonexistent" + + call load_npz(filename, arrays, stat, tmp_dir=tmp) + call check(error, stat, "Loading a non-existent npz file should fail.") + end + + subroutine npz_load_invalid_dir(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + + integer :: stat + character(*), parameter :: filename = "." + character(*), parameter :: tmp = temp_dir//"/invalid_dir" + + + call load_npz(filename, arrays, stat, tmp_dir=tmp) + call check(error, stat, "A file name that points towards a directory should fail.") + end + + subroutine npz_load_empty_file(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + + integer :: io, stat + character(*), parameter :: filename = "empty_file" + character(*), parameter :: tmp = temp_dir//"/empty_file" + + open(newunit=io, file=filename) + close(io) + + call load_npz(filename, arrays, stat, tmp_dir=tmp) + call check(error, stat, "Try loading an empty file as an npz file should fail.") + + call delete_file(filename) + end + + subroutine npz_load_empty_zip(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: io, stat + + character(*), parameter :: filename = "empty.zip" + character(*), parameter :: tmp = temp_dir//"/empty_zip" + character(*), parameter:: binary_data = 'PK'//char(5)//char(6)//repeat(char(0), 18) + + open (newunit=io, file=filename, form='unformatted', access='stream') + write (io) binary_data + close (io) + + call load_npz(filename, arrays, stat, tmp_dir=tmp) + call check(error, stat, "Trying to load an npz file that is an empty zip file should fail.") + + call delete_file(filename) + end + + subroutine npz_load_arr_empty_0(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: stat + character(*), parameter :: filename = "empty_0.npz" + character(*), parameter :: tmp = temp_dir//"/empty_0" + character(*), parameter :: path = path_to_zip_files//filename + + call load_npz(path, arrays, stat, tmp_dir=tmp) + call check(error, stat, "Loading an npz that contains a single empty array shouldn't fail.") + if (allocated(error)) return + call check(error, size(arrays) == 1, "'"//filename//"' is supposed to contain a single array.") + if (allocated(error)) return + call check(error, arrays(1)%array%name == "arr_0.npy", "Wrong array name.") + if (allocated(error)) return + select type (typed_array => arrays(1)%array) + class is (array_type_rdp_1) + call check(error, size(typed_array%values) == 0, "Array in '"//filename//"' is supposed to be empty.") + class default + call test_failed(error, "Array in '"//filename//"' is of wrong type.") + end select + end + + subroutine npz_load_arr_rand_2_3(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: stat + character(*), parameter :: filename = "rand_2_3.npz" + character(*), parameter :: tmp = temp_dir//"/rand_2_3" + character(*), parameter :: path = path_to_zip_files//filename + + call load_npz(path, arrays, stat, tmp_dir=tmp) + call check(error, stat, "Loading an npz file that contains a valid nd_array shouldn't fail.") + if (allocated(error)) return + call check(error, size(arrays) == 1, "'"//filename//"' is supposed to contain a single array.") + if (allocated(error)) return + call check(error, arrays(1)%array%name == "arr_0.npy", "Wrong array name.") + if (allocated(error)) return + select type (typed_array => arrays(1)%array) + class is (array_type_rdp_2) + call check(error, size(typed_array%values) == 6, "Array in '"//filename//"' is supposed to have 6 entries.") + class default + call test_failed(error, "Array in '"//filename//"' is of wrong type.") + end select + end + + subroutine npz_load_arr_arange_10_20(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: stat, i + character(*), parameter :: filename = "arange_10_20.npz" + character(*), parameter :: tmp = temp_dir//"/arange_10_20" + character(*), parameter :: path = path_to_zip_files//filename + + call load_npz(path, arrays, stat, tmp_dir=tmp) + call check(error, stat, "Loading an npz file that contains a valid nd_array shouldn't fail.") + if (allocated(error)) return + call check(error, size(arrays) == 1, "'"//filename//"' is supposed to contain a single array.") + if (allocated(error)) return + call check(error, arrays(1)%array%name == "arr_0.npy", "Wrong array name.") + if (allocated(error)) return + select type (typed_array => arrays(1)%array) + class is (array_type_iint64_1) + call check(error, size(typed_array%values) == 10, "Array in '"//filename//"' is supposed to have 10 entries.") + if (allocated(error)) return + call check(error, typed_array%values(1) == 10, "First entry is supposed to be 10.") + if (allocated(error)) return + do i = 2, 10 + call check(error, typed_array%values(i) == typed_array%values(i-1) + 1, "Array is supposed to be an arange.") + if (allocated(error)) return + end do + class default + call test_failed(error, "Array in '"//filename//"' is of wrong type.") + end select + end + + subroutine npz_load_arr_cmplx(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: stat + character(*), parameter :: filename = "cmplx_arr.npz" + character(*), parameter :: tmp = temp_dir//"/cmplx_arr" + character(*), parameter :: path = path_to_zip_files//filename + + call load_npz(path, arrays, stat, tmp_dir=tmp) + call check(error, stat, "Loading an npz file that contains a valid nd_array shouldn't fail.") + if (allocated(error)) return + call check(error, size(arrays) == 1, "'"//filename//"' is supposed to contain a single array.") + if (allocated(error)) return + call check(error, arrays(1)%array%name == "cmplx.npy", "Wrong array name.") + if (allocated(error)) return + select type (typed_array => arrays(1)%array) + class is (array_type_csp_1) + call check(error, size(typed_array%values) == 3, "Array in '"//filename//"' is supposed to have 3 entries.") + if (allocated(error)) return + call check(error, typed_array%values(1) == cmplx(1_dp, 2_dp), "First complex number does not match.") + if (allocated(error)) return + call check(error, typed_array%values(2) == cmplx(3_dp, 4_dp), "Second complex number does not match.") + if (allocated(error)) return + call check(error, typed_array%values(3) == cmplx(5_dp, 6_dp), "Third complex number does not match.") + if (allocated(error)) return + class default + call test_failed(error, "Array in '"//filename//"' is of wrong type.") + end select + end + + subroutine npz_load_two_arr_iint64_rdp(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: stat + character(*), parameter :: filename = "two_arr_iint64_rdp.npz" + character(*), parameter :: tmp = temp_dir//"/two_arr_iint64_rdp" + character(*), parameter :: path = path_to_zip_files//filename + + call load_npz(path, arrays, stat, tmp_dir=tmp) + call check(error, stat, "Loading an npz file that contains valid nd_arrays shouldn't fail.") + if (allocated(error)) return + call check(error, size(arrays) == 2, "'"//filename//"' is supposed to contain two arrays.") + if (allocated(error)) return + call check(error, arrays(1)%array%name == "arr_0.npy", "Wrong array name.") + if (allocated(error)) return + call check(error, arrays(2)%array%name == "arr_1.npy", "Wrong array name.") + if (allocated(error)) return + select type (typed_array => arrays(1)%array) + class is (array_type_iint64_1) + call check(error, size(typed_array%values) == 3, "Array in '"//filename//"' is supposed to have 3 entries.") + if (allocated(error)) return + call check(error, typed_array%values(1) == 1, "First integer does not match.") + if (allocated(error)) return + call check(error, typed_array%values(2) == 2, "Second integer does not match.") + if (allocated(error)) return + call check(error, typed_array%values(3) == 3, "Third integer does not match.") + if (allocated(error)) return + class default + call test_failed(error, "Array in '"//filename//"' is of wrong type.") + end select + select type (typed_array => arrays(2)%array) + class is (array_type_rdp_1) + call check(error, size(typed_array%values) == 3, "Array in '"//filename//"' is supposed to have 3 entries.") + if (allocated(error)) return + call check(error, typed_array%values(1) == 1., "First number does not match.") + if (allocated(error)) return + call check(error, typed_array%values(2) == 1., "Second number does not match.") + if (allocated(error)) return + call check(error, typed_array%values(3) == 1., "Third number does not match.") + if (allocated(error)) return + class default + call test_failed(error, "Array in '"//filename//"' is of wrong type.") + end select + end + + subroutine npz_load_two_arr_iint64_rdp_comp(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: stat + character(*), parameter :: filename = "two_arr_iint64_rdp_comp.npz" + character(*), parameter :: tmp = temp_dir//"/two_arr_iint64_rdp_comp" + character(*), parameter :: path = path_to_zip_files//filename + + call load_npz(path, arrays, stat, tmp_dir=tmp) + call check(error, stat, "Loading a compressed npz file that contains valid nd_arrays shouldn't fail.") + if (allocated(error)) return + call check(error, size(arrays) == 2, "'"//filename//"' is supposed to contain two arrays.") + if (allocated(error)) return + call check(error, arrays(1)%array%name == "arr_0.npy", "Wrong array name.") + if (allocated(error)) return + call check(error, arrays(2)%array%name == "arr_1.npy", "Wrong array name.") + if (allocated(error)) return + select type (typed_array => arrays(1)%array) + class is (array_type_iint64_1) + call check(error, size(typed_array%values) == 3, "Array in '"//filename//"' is supposed to have 3 entries.") + if (allocated(error)) return + call check(error, typed_array%values(1) == 1, "First integer does not match.") + if (allocated(error)) return + call check(error, typed_array%values(2) == 2, "Second integer does not match.") + if (allocated(error)) return + call check(error, typed_array%values(3) == 3, "Third integer does not match.") + if (allocated(error)) return + class default + call test_failed(error, "Array in '"//filename//"' is of wrong type.") + end select + select type (typed_array => arrays(2)%array) + class is (array_type_rdp_1) + call check(error, size(typed_array%values) == 3, "Array in '"//filename//"' is supposed to have 3 entries.") + if (allocated(error)) return + call check(error, typed_array%values(1) == 1., "First number does not match.") + if (allocated(error)) return + call check(error, typed_array%values(2) == 1., "Second number does not match.") + if (allocated(error)) return + call check(error, typed_array%values(3) == 1., "Third number does not match.") + if (allocated(error)) return + class default + call test_failed(error, "Array in '"//filename//"' is of wrong type.") + end select + end + + subroutine add_array_to_empty(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: stat + real(dp), allocatable :: input_array(:,:) + + allocate(input_array(10, 4)) + call random_number(input_array) + call add_array(arrays, input_array, stat) + call check(error, stat, "Error adding an array to the list of arrays.") + if (allocated(error)) return + call check(error, size(arrays) == 1, "Array was not added to the list of arrays.") + if (allocated(error)) return + call check(error, arrays(1)%array%name == "arr_0.npy", "Wrong array name.") + if (allocated(error)) return + select type (typed_array => arrays(1)%array) + class is (array_type_rdp_2) + call check(error, size(typed_array%values), size(input_array), "Array sizes do not match.") + if (allocated(error)) return + call check(error, any(abs(typed_array%values - input_array) <= epsilon(1.0_dp)), & + "Precision loss when adding array.") + if (allocated(error)) return + class default + call test_failed(error, "Array is of wrong type.") + end select + end + + subroutine add_two_arrays(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: stat + real(dp), allocatable :: array_1(:,:) + real(sp), allocatable :: array_2(:) + + allocate(array_1(10, 4)) + call random_number(array_1) + call add_array(arrays, array_1, stat) + call check(error, stat, "Error adding the first array to the list of arrays.") + if (allocated(error)) return + call check(error, size(arrays) == 1, "Array was not added to the list of arrays.") + if (allocated(error)) return + call check(error, arrays(1)%array%name == "arr_0.npy", "Wrong array name.") + if (allocated(error)) return + select type (typed_array => arrays(1)%array) + class is (array_type_rdp_2) + call check(error, size(typed_array%values), size(array_1), "Array sizes do not match.") + if (allocated(error)) return + call check(error, any(abs(typed_array%values - array_1) <= epsilon(1.0_dp)), & + "Precision loss when adding array.") + if (allocated(error)) return + class default + call test_failed(error, "Array 1 is of wrong type.") + end select + + allocate(array_2(10)) + call random_number(array_2) + call add_array(arrays, array_2, stat) + call check(error, stat, "Error adding the second array to the list of arrays.") + if (allocated(error)) return + call check(error, size(arrays) == 2, "Array was not added to the list of arrays.") + if (allocated(error)) return + call check(error, arrays(2)%array%name == "arr_1.npy", "Wrong array name.") + if (allocated(error)) return + select type (typed_array => arrays(2)%array) + class is (array_type_rsp_1) + call check(error, size(typed_array%values), size(array_2), "Array sizes do not match.") + if (allocated(error)) return + call check(error, any(abs(typed_array%values - array_2) <= epsilon(1.0_sp)), & + "Precision loss when adding array.") + if (allocated(error)) return + class default + call test_failed(error, "Array 2 is of wrong type.") + end select + end + + subroutine add_array_custom_name(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: stat + real(dp), allocatable :: input_array(:,:) + character(*), parameter :: arr_name = "custom_name.npy" + + allocate(input_array(10, 4)) + call random_number(input_array) + call add_array(arrays, input_array, stat, name=arr_name) + call check(error, stat, "Error adding an array to the list of arrays.") + if (allocated(error)) return + call check(error, size(arrays) == 1, "Array was not added to the list of arrays.") + if (allocated(error)) return + call check(error, arrays(1)%array%name == arr_name, "Wrong array name.") + if (allocated(error)) return + select type (typed_array => arrays(1)%array) + class is (array_type_rdp_2) + call check(error, size(typed_array%values), size(input_array), "Array sizes do not match.") + if (allocated(error)) return + call check(error, any(abs(typed_array%values - input_array) <= epsilon(1.0_dp)), & + "Precision loss when adding array.") + if (allocated(error)) return + class default + call test_failed(error, "Array is of wrong type.") + end select + end + + subroutine add_array_empty_name(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: stat + real(dp), allocatable :: input_array(:,:) + character(*), parameter :: arr_name = " " + + allocate(input_array(10, 4)) + call random_number(input_array) + call add_array(arrays, input_array, stat, name=arr_name) + call check(error, stat, "Empty file names are not allowed.") + end + + subroutine add_array_duplicate_names(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: stat + real(dp), allocatable :: array_1(:,:) + real(sp), allocatable :: array_2(:) + character(*), parameter :: arr_name = "arr_0.npy" + + allocate(array_1(10, 4)) + call random_number(array_1) + call add_array(arrays, array_1, stat, name=arr_name) + call check(error, stat, "Error adding the first array to the list of arrays.") + + allocate(array_2(10)) + call random_number(array_2) + call add_array(arrays, array_2, stat, name=arr_name) + call check(error, stat, "Adding a second array with the same name shouldn't work.") + end + + subroutine npz_save_empty_array_input(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: stat + character(*), parameter :: filename = "output.npz" + + allocate(arrays(0)) + call save_npz(filename, arrays, stat) + call check(error, stat, "Trying to save an empty array fail.") + end + + subroutine npz_save_one_array(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:), arrays_reloaded(:) + integer :: stat + real(dp), allocatable :: input_array(:,:) + character(*), parameter :: output_file = "one_array.npz" + character(*), parameter :: tmp = temp_dir//"/one_array" + + allocate(input_array(10, 4)) + call random_number(input_array) + call add_array(arrays, input_array, stat) + call check(error, stat, "Error adding an array to the list of arrays.") + if (allocated(error)) return + call check(error, size(arrays) == 1, "Array was not added to the list of arrays.") + if (allocated(error)) return + call save_npz(output_file, arrays, stat) + call check(error, stat, "Error saving the array.") + if (allocated(error)) then + call delete_file(output_file); return + end if + call check(error, exists(output_file), "Output file does not exist.") + if (allocated(error)) then + call delete_file(output_file); return + end if + + call load_npz(output_file, arrays_reloaded, stat, tmp_dir=tmp) + call check(error, stat, "Error loading the npz file.") + if (allocated(error)) then + call delete_file(output_file); return + end if + call check(error, size(arrays_reloaded) == 1, "Wrong number of arrays.") + if (allocated(error)) then + call delete_file(output_file); return + end if + select type (typed_array => arrays_reloaded(1)%array) + class is (array_type_rdp_2) + call check(error, size(typed_array%values), size(input_array), "Array sizes do not match.") + if (allocated(error)) then + call delete_file(output_file); return + end if + call check(error, any(abs(typed_array%values - input_array) <= epsilon(1.0_dp)), & + "Precision loss when adding array.") + if (allocated(error)) then + call delete_file(output_file); return + end if + class default + call test_failed(error, "Array is of wrong type.") + end select + call delete_file(output_file) + end + + subroutine npz_save_two_arrays(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:), arrays_reloaded(:) + integer :: stat + real(dp), allocatable :: input_array_1(:,:) + complex(dp), parameter :: input_array_2(3) = [(1, 2._dp), (3, 4._dp), (5, 6._dp)] + character(*), parameter :: array_name_1 = "array_1" + character(*), parameter :: array_name_2 = "array_2" + character(*), parameter :: output_file = "two_arrays.npz" + character(*), parameter :: tmp = temp_dir//"/two_arrays" + + allocate(input_array_1(5, 6)) + call random_number(input_array_1) + call add_array(arrays, input_array_1, stat, name=array_name_1) + call check(error, stat, "Error adding array 1 to the list of arrays.") + if (allocated(error)) return + + call add_array(arrays, input_array_2, stat, name=array_name_2) + call check(error, stat, "Error adding array 2 to the list of arrays.") + if (allocated(error)) return + call check(error, size(arrays) == 2, "Wrong array size.") + if (allocated(error)) return + + call save_npz(output_file, arrays, stat) + call check(error, stat, "Error saving arrays as an npz file.") + if (allocated(error)) then + call delete_file(output_file); return + end if + call check(error, exists(output_file), "Output file does not exist.") + if (allocated(error)) then + call delete_file(output_file); return + end if + + call load_npz(output_file, arrays_reloaded, stat, tmp_dir=tmp) + call check(error, stat, "Error loading npz file.") + if (allocated(error)) then + call delete_file(output_file); return + end if + call check(error, size(arrays_reloaded) == 2, "Wrong number of arrays.") + if (allocated(error)) then + call delete_file(output_file); return + end if + + select type (typed_array => arrays_reloaded(1)%array) + class is (array_type_rdp_2) + call check(error, size(typed_array%values), size(input_array_1), "First array does not match in size.") + if (allocated(error)) then + call delete_file(output_file); return + end if + call check(error, any(abs(typed_array%values - input_array_1) <= epsilon(1.0_dp)), & + "Precision loss when adding array.") + if (allocated(error)) then + call delete_file(output_file); return + end if + class default + call test_failed(error, "Array 1 is of wrong type.") + end select + + select type (typed_array => arrays_reloaded(2)%array) + class is (array_type_cdp_1) + call check(error, size(typed_array%values), size(input_array_2), "Second array does not match in size.") + if (allocated(error)) then + call delete_file(output_file); return + end if + call check(error, any(abs(typed_array%values - input_array_2) <= epsilon(1.0_dp)), & + "Precision loss when adding array.") + if (allocated(error)) then + call delete_file(output_file); return + end if + class default + call test_failed(error, "Array 2 is of wrong type.") + end select + call delete_file(output_file) + end + + subroutine npz_get_values_unallocated(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: stat + real(dp), allocatable :: input_array(:,:) + + allocate(arrays(1)) + call arrays(1)%get_values(input_array, stat) + call check(error, stat, "Getting values from an unallocated array should fail.") + end + + subroutine npz_get_values_correct_type(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: stat + real(dp), allocatable :: input_array(:,:), output_array(:, :) + + allocate(input_array(10, 4)) + call random_number(input_array) + call add_array(arrays, input_array, stat) + call check(error, stat, "Error adding an array to the list of arrays.") + if (allocated(error)) return + call check(error, size(arrays) == 1, "Array was not added to the list of arrays.") + if (allocated(error)) return + call arrays(1)%get_values(output_array, stat) + call check(error, stat, "Error reading values from the array.") + if (allocated(error)) return + call check(error, size(output_array), size(input_array), "Array sizes do not match.") + if (allocated(error)) return + call check(error, any(abs(output_array - input_array) <= epsilon(1.0_dp)), & + "Precision loss when reading values from the array.") + end + + subroutine npz_get_values_wrong_type(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:) + integer :: stat + real(dp), allocatable :: input_array(:,:), output_array(:) + + allocate(input_array(10, 4)) + call random_number(input_array) + call add_array(arrays, input_array, stat) + call check(error, stat, "Error adding an array to the list of arrays.") + if (allocated(error)) return + call check(error, size(arrays) == 1, "Array was not added to the list of arrays.") + if (allocated(error)) return + call arrays(1)%get_values(output_array, stat) + call check(error, stat, "Get values shouldn't work due to type mismatch.") + end + + subroutine npz_get_values_two_arrays(error) + type(error_type), allocatable, intent(out) :: error + + type(array_wrapper_type), allocatable :: arrays(:), arrays_reloaded(:) + integer :: stat + real(dp), allocatable :: input_array_1(:,:), output_array_1(:,:) + complex(dp), parameter :: input_array_2(3) = [(1, 2._dp), (3, 4._dp), (5, 6._dp)] + complex(dp), allocatable :: output_array_2(:) + + allocate(input_array_1(5, 6)) + call random_number(input_array_1) + call add_array(arrays, input_array_1, stat) + call check(error, stat, "Error adding array 1 to the list of arrays.") + if (allocated(error)) return + + call add_array(arrays, input_array_2, stat) + call check(error, stat, "Error adding array 2 to the list of arrays.") + if (allocated(error)) return + call check(error, size(arrays) == 2, "Wrong array size.") + if (allocated(error)) return + + call arrays(1)%get_values(output_array_1, stat) + call check(error, stat, "Error reading values from the first array.") + if (allocated(error)) return + call check(error, size(input_array_1), size(output_array_1), "First array does not match in size.") + if (allocated(error)) return + call check(error, any(abs(output_array_1 - input_array_1) <= epsilon(1.0_dp)), & + "Precision loss when reading values from the first array.") + if (allocated(error)) return + + call arrays(2)%get_values(output_array_2, stat) + call check(error, stat, "Error reading values from the second array.") + if (allocated(error)) return + call check(error, size(input_array_2), size(output_array_2), "Second array does not match in size.") + if (allocated(error)) return + call check(error, any(abs(output_array_2 - input_array_2) <= epsilon(1.0_dp)), & + "Precision loss when reading values from the second array.") + end + + subroutine delete_file(filename) + character(len=*), intent(in) :: filename + + integer :: io + + open(newunit=io, file=filename) + close(io, status="delete") + end subroutine delete_file +end + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use testdrive, only : run_testsuite, new_testsuite, testsuite_type + use test_np, only : collect_np + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("np", collect_np) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end diff --git a/test/io/test_npy.f90 b/test/io/test_npy.f90 deleted file mode 100644 index c56637030..000000000 --- a/test/io/test_npy.f90 +++ /dev/null @@ -1,680 +0,0 @@ -module test_npy - use stdlib_kinds, only : int8, int16, int32, int64, sp, dp - use stdlib_io_npy, only : save_npy, load_npy - use testdrive, only : new_unittest, unittest_type, error_type, check - implicit none - private - - public :: collect_npy - -contains - - !> Collect all exported unit tests - subroutine collect_npy(testsuite) - !> Collection of tests - type(unittest_type), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - new_unittest("read-rdp-r2", test_read_rdp_rank2), & - new_unittest("read-rdp-r3", test_read_rdp_rank3), & - new_unittest("read-rsp-r1", test_read_rsp_rank1), & - new_unittest("read-rsp-r2", test_read_rsp_rank2), & - new_unittest("write-rdp-r2", test_write_rdp_rank2), & - new_unittest("write-rsp-r2", test_write_rsp_rank2), & - new_unittest("write-i2-r4", test_write_int16_rank4), & - new_unittest("invalid-magic-number", test_invalid_magic_number, should_fail=.true.), & - new_unittest("invalid-magic-string", test_invalid_magic_string, should_fail=.true.), & - new_unittest("invalid-major-version", test_invalid_major_version, should_fail=.true.), & - new_unittest("invalid-minor-version", test_invalid_minor_version, should_fail=.true.), & - new_unittest("invalid-header-len", test_invalid_header_len, should_fail=.true.), & - new_unittest("invalid-nul-byte", test_invalid_nul_byte, should_fail=.true.), & - new_unittest("invalid-key", test_invalid_key, should_fail=.true.), & - new_unittest("invalid-comma", test_invalid_comma, should_fail=.true.), & - new_unittest("invalid-string", test_invalid_string, should_fail=.true.), & - new_unittest("duplicate-descr", test_duplicate_descr, should_fail=.true.), & - new_unittest("missing-descr", test_missing_descr, should_fail=.true.), & - new_unittest("missing-fortran_order", test_missing_fortran_order, should_fail=.true.), & - new_unittest("missing-shape", test_missing_shape, should_fail=.true.), & - new_unittest("iomsg-deallocated", test_iomsg_deallocated) & - ] - end subroutine collect_npy - - subroutine test_read_rdp_rank2(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr':' Error handling - type(error_type), allocatable, intent(out) :: error - - integer :: stat - character(len=*), parameter :: filename = ".test-rdp-r2-rt.npy" - real(dp), allocatable :: input(:, :), output(:, :) - - allocate(input(10, 4)) - call random_number(input) - call save_npy(filename, input, stat) - - call check(error, stat, "Writing of npy file failed") - if (allocated(error)) return - - call load_npy(filename, output, stat) - call delete_file(filename) - - call check(error, stat, "Reading of npy file failed") - if (allocated(error)) return - - call check(error, size(output), size(input)) - if (allocated(error)) return - - call check(error, any(abs(output - input) <= epsilon(1.0_dp)), & - "Precision loss when rereading array") - end subroutine test_write_rdp_rank2 - - subroutine test_write_rsp_rank2(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - integer :: stat - character(len=*), parameter :: filename = ".test-rsp-r2-rt.npy" - real(sp), allocatable :: input(:, :), output(:, :) - - allocate(input(12, 5)) - call random_number(input) - call save_npy(filename, input, stat) - - call check(error, stat, "Writing of npy file failed") - if (allocated(error)) return - - call load_npy(filename, output, stat) - call delete_file(filename) - - call check(error, stat, "Reading of npy file failed") - if (allocated(error)) return - - call check(error, size(output), size(input)) - if (allocated(error)) return - - call check(error, any(abs(output - input) <= epsilon(1.0_dp)), & - "Precision loss when rereading array") - end subroutine test_write_rsp_rank2 - - subroutine test_write_int16_rank4(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - integer :: stat, i - character(len=*), parameter :: filename = ".test-i2-r4-rt.npy" - integer(int16), allocatable :: input(:, :, :, :), output(:, :, :, :) - - input = reshape([(i*(i+1)/2, i = 1, 40)], [2, 5, 2, 2]) - call save_npy(filename, input, stat) - - call check(error, stat, "Writing of npy file failed") - if (allocated(error)) return - - call load_npy(filename, output, stat) - call delete_file(filename) - - call check(error, stat, "Reading of npy file failed") - if (allocated(error)) return - - call check(error, size(output), size(input)) - if (allocated(error)) return - - call check(error, all(abs(output - input) == 0), & - "Precision loss when rereading array") - end subroutine test_write_int16_rank4 - - subroutine test_invalid_magic_number(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'fortran_order': True, 'shape': (10, 4, ), 'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'fortran_order': True,, 'shape': (10, 4, ), 'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'fortran_order': True, 'shape': (10, 4, ), 'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'fortran_order': True, 'shape': (10, 4, ), } " // & - char(10) - character(len=*), parameter :: header = & - char(int(z"93")) // "NUMPY" // char(1) // char(0) // & - char(len(dict)) // char(0) // dict - - integer :: io, stat - character(len=:), allocatable :: msg - character(len=*), parameter :: filename = ".test-missing-descr.npy" - real(dp), allocatable :: array(:, :) - - open(newunit=io, file=filename, form="unformatted", access="stream") - write(io) header - write(io) spread(0.0_dp, 1, 40) - close(io) - - call load_npy(filename, array, stat, msg) - call delete_file(filename) - - call check(error, stat, msg) - end subroutine test_missing_descr - - subroutine test_missing_fortran_order(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - character(len=*), parameter :: dict = & - "{'fortran_order': True, 'descr': ' Error handling - type(error_type), allocatable, intent(out) :: error - - integer :: stat - character(len=:), allocatable :: msg - - character(len=*), parameter :: filename = ".test-iomsg-deallocated.npy" - real(sp), allocatable :: input(:, :), output(:, :) - - msg = "This message should be deallocated." - - allocate(input(12, 5)) - call random_number(input) - call save_npy(filename, input, stat, msg) - call delete_file(filename) - - call check(error,.not. allocated(msg), "Message wrongly allocated.") - - end subroutine - - subroutine delete_file(filename) - character(len=*), intent(in) :: filename - - integer :: io - - open(newunit=io, file=filename) - close(io, status="delete") - end subroutine delete_file - -end module test_npy - - -program tester - use, intrinsic :: iso_fortran_env, only : error_unit - use testdrive, only : run_testsuite, new_testsuite, testsuite_type - use test_npy, only : collect_npy - implicit none - integer :: stat, is - type(testsuite_type), allocatable :: testsuites(:) - character(len=*), parameter :: fmt = '("#", *(1x, a))' - - stat = 0 - - testsuites = [ & - new_testsuite("npy", collect_npy) & - ] - - do is = 1, size(testsuites) - write(error_unit, fmt) "Testing:", testsuites(is)%name - call run_testsuite(testsuites(is)%collect, error_unit, stat) - end do - - if (stat > 0) then - write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" - error stop - end if -end program diff --git a/test/io/test_zip.f90 b/test/io/test_zip.f90 new file mode 100644 index 000000000..8227218b7 --- /dev/null +++ b/test/io/test_zip.f90 @@ -0,0 +1,311 @@ +module test_zip + use stdlib_io_filesystem, only: exists + use stdlib_io_zip + use stdlib_string_type, only: string_type, char + use testdrive, only: new_unittest, unittest_type, error_type, check, test_failed + implicit none + private + + public :: collect_zip + + character(*), parameter :: path_to_zip_files = "test/io/zip_files/" + +contains + + !> Collect all exported unit tests + subroutine collect_zip(testsuite) + !> Collection of tests + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("unzip_file_not_exists", unzip_file_not_exists, should_fail=.true.), & + new_unittest("unzip_points_to_directory", unzip_points_to_directory, should_fail=.true.), & + new_unittest("unzip_is_not_zip", unzip_is_not_zip, should_fail=.true.), & + new_unittest("unzip_empty_zip", unzip_empty_zip, should_fail=.true.), & + new_unittest("unzip_zip_has_empty_file", unzip_zip_has_empty_file), & + new_unittest("unzip_zip_has_txt_file", unzip_zip_has_txt_file), & + new_unittest("unzip_npz_array_empty_0_file", unzip_npz_array_empty_0_file), & + new_unittest("unzip_two_files", unzip_two_files), & + new_unittest("unzip_compressed_npz", unzip_compressed_npz), & + new_unittest("zip_nonexistent_file", zip_nonexistent_file, should_fail=.true.), & + new_unittest("zip_invalid_file", zip_invalid_file, should_fail=.true.), & + new_unittest("zip_empty_file", zip_empty_file), & + new_unittest("zip_invalid_output_file", zip_invalid_output_file, should_fail=.true.), & + new_unittest("zip_two_files", zip_two_files), & + new_unittest("zip_without_comp", zip_without_comp) & + ] + end + + subroutine unzip_file_not_exists(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat + + call unzip("nonexistent.npz", stat=stat) + call check(error, stat, "Reading of a non-existent npz file should fail.") + end + + subroutine unzip_points_to_directory(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat + + call unzip(".", stat=stat) + call check(error, stat, "An npz file that points towards a directory should fail.") + end + + subroutine unzip_is_not_zip(error) + type(error_type), allocatable, intent(out) :: error + + integer :: io, stat + character(*), parameter :: filename = "non_zip_file" + + open(newunit=io, file=filename) + close(io) + call unzip(filename, stat=stat) + call check(error, stat, "An npz file that is not a zip file should fail.") + call delete_file(filename) + end + + subroutine unzip_empty_zip(error) + type(error_type), allocatable, intent(out) :: error + + integer :: io, stat + character(*), parameter :: filename = "empty.zip" + character(*), parameter:: binary_data = 'PK'//char(5)//char(6)//repeat(char(0), 18) + + open (newunit=io, file=filename, form='unformatted', access='stream') + write (io) binary_data + close (io) + + call unzip(filename, stat=stat) + call check(error, stat, "An empty zip file should fail.") + + call delete_file(filename) + end + + subroutine unzip_zip_has_empty_file(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat + character(*), parameter :: filename = "empty.zip" + character(*), parameter :: path = path_to_zip_files//filename + + call unzip(path, stat=stat) + call check(error, stat, "Listing the contents of a zip file that contains an empty file should not fail.") + end + + subroutine unzip_zip_has_txt_file(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat + character(*), parameter :: filename = "textfile.zip" + character(*), parameter :: path = path_to_zip_files//filename + + call unzip(path, stat=stat) + call check(error, stat, "Listing the contents of a zip file that contains an empty file should not fail.") + end + + subroutine unzip_npz_array_empty_0_file(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat + character(*), parameter :: filename = "empty_0.npz" + character(*), parameter :: path = path_to_zip_files//filename + + call unzip(path, stat=stat) + call check(error, stat, "Listing the contents of a zip file that contains an empty file should not fail.") + end + + subroutine unzip_two_files(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat + character(*), parameter :: filename = "two_files.zip" + character(*), parameter :: path = path_to_zip_files//filename + + call unzip(path, stat=stat) + call check(error, stat, "Listing the contents of a zip file that contains an empty file should not fail.") + end + + subroutine unzip_compressed_npz(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat + character(*), parameter :: filename = "two_arr_iint64_rdp_comp.npz" + character(*), parameter :: path = path_to_zip_files//filename + + call unzip(path, stat=stat) + call check(error, stat, "Listing the contents of a compressed npz file should not fail.") + end + + subroutine zip_nonexistent_file(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat + character(*), parameter :: output_file = "temp.zip" + character(*), parameter :: input_file = "nonexistent" + type(string_type), allocatable :: files(:) + + files = [string_type(input_file)] + + call zip(output_file, files, stat) + call check(error, stat, "Compressing a non-existent file should fail.") + end + + subroutine zip_invalid_file(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat + character(*), parameter :: output_file = "temp.zip" + character(*), parameter :: input_file = "." + type(string_type), allocatable :: files(:) + + files = [string_type(input_file)] + + call zip(output_file, files, stat) + call check(error, stat, "Compressing an invalid file should fail.") + end + + subroutine zip_empty_file(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat, unit + character(*), parameter :: output_file = "temp.zip" + character(*), parameter :: input_file = "abc.txt" + type(string_type), allocatable :: files(:) + + files = [string_type(input_file)] + + open(newunit= unit, file=input_file) + close(unit) + + call zip(output_file, files, stat) + call check(error, stat, "Compressing a valid empty file should not fail.") + if (allocated(error)) then + call delete_file(input_file) + call delete_file(output_file) + return + end if + + call check(error, exists(output_file), "The output file should exist.") + + call delete_file(input_file) + call delete_file(output_file) + end + + subroutine zip_invalid_output_file(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat, unit + character(*), parameter :: output_file = " " + character(*), parameter :: input_file = "abc.txt" + type(string_type), allocatable :: files(:) + + files = [string_type(input_file)] + + open(newunit=unit, file=input_file) + close(unit) + + call zip(output_file, files, stat) + call check(error, stat, "Providing an empty output file should fail.") + + call delete_file(input_file) + end + + subroutine zip_two_files(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat, unit + character(*), parameter :: output_file = "temp.zip" + character(*), parameter :: input_file_1 = "abc.txt" + character(*), parameter :: input_file_2 = "def.txt" + type(string_type), allocatable :: files(:) + + files = [string_type(input_file_1), string_type(input_file_2)] + + open(newunit=unit, file=input_file_1) + close(unit) + open(newunit=unit, file=input_file_2) + close(unit) + + call zip(output_file, files, stat) + call check(error, stat, "Compressing two valid files should not fail.") + if (allocated(error)) then + call delete_file(input_file_1) + call delete_file(input_file_2) + call delete_file(output_file) + return + end if + + call check(error, exists(output_file), "The output file should exist.") + + call delete_file(input_file_1) + call delete_file(input_file_2) + call delete_file(output_file) + end + + + subroutine zip_without_comp(error) + type(error_type), allocatable, intent(out) :: error + + integer :: stat, unit + character(*), parameter :: output_file = "temp.zip" + character(*), parameter :: input_file = "abc.txt" + type(string_type), allocatable :: files(:) + + files = [string_type(input_file)] + + open(newunit= unit, file=input_file) + close(unit) + + call zip(output_file, files, stat, compressed=.false.) + call check(error, stat, "Zipping a valid file without compression shouldn't fail.") + if (allocated(error)) then + call delete_file(input_file) + call delete_file(output_file) + return + end if + + call check(error, exists(output_file), "The output file should exist.") + + call delete_file(input_file) + call delete_file(output_file) + end + + subroutine delete_file(filename) + character(len=*), intent(in) :: filename + + integer :: io + + open(newunit=io, file=filename) + close(io, status="delete") + end + +end + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use testdrive, only : run_testsuite, new_testsuite, testsuite_type + use test_zip, only : collect_zip + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("zip", collect_zip) & + ] + + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call run_testsuite(testsuites(is)%collect, error_unit, stat) + end do + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop + end if +end diff --git a/test/io/zip_files/arange_10_20.npz b/test/io/zip_files/arange_10_20.npz new file mode 100644 index 000000000..da0e2960a Binary files /dev/null and b/test/io/zip_files/arange_10_20.npz differ diff --git a/test/io/zip_files/cmplx_arr.npz b/test/io/zip_files/cmplx_arr.npz new file mode 100644 index 000000000..2492d368d Binary files /dev/null and b/test/io/zip_files/cmplx_arr.npz differ diff --git a/test/io/zip_files/empty.zip b/test/io/zip_files/empty.zip new file mode 100644 index 000000000..2227dc4f6 Binary files /dev/null and b/test/io/zip_files/empty.zip differ diff --git a/test/io/zip_files/empty_0.npz b/test/io/zip_files/empty_0.npz new file mode 100644 index 000000000..4f02137de Binary files /dev/null and b/test/io/zip_files/empty_0.npz differ diff --git a/test/io/zip_files/rand_2_3.npz b/test/io/zip_files/rand_2_3.npz new file mode 100644 index 000000000..f96ac9c7c Binary files /dev/null and b/test/io/zip_files/rand_2_3.npz differ diff --git a/test/io/zip_files/textfile.zip b/test/io/zip_files/textfile.zip new file mode 100644 index 000000000..25f313137 Binary files /dev/null and b/test/io/zip_files/textfile.zip differ diff --git a/test/io/zip_files/two_arr_iint64_rdp.npz b/test/io/zip_files/two_arr_iint64_rdp.npz new file mode 100644 index 000000000..6b026b1ff Binary files /dev/null and b/test/io/zip_files/two_arr_iint64_rdp.npz differ diff --git a/test/io/zip_files/two_arr_iint64_rdp_comp.npz b/test/io/zip_files/two_arr_iint64_rdp_comp.npz new file mode 100644 index 000000000..43fdc5789 Binary files /dev/null and b/test/io/zip_files/two_arr_iint64_rdp_comp.npz differ diff --git a/test/io/zip_files/two_files.zip b/test/io/zip_files/two_files.zip new file mode 100644 index 000000000..ec03fe049 Binary files /dev/null and b/test/io/zip_files/two_files.zip differ diff --git a/test/string/test_string_derivedtype_io.f90 b/test/string/test_string_derivedtype_io.f90 index c99272dac..ccc5cdcaa 100644 --- a/test/string/test_string_derivedtype_io.f90 +++ b/test/string/test_string_derivedtype_io.f90 @@ -1,4 +1,4 @@ -! SPDX-Identifer: MIT +! SPDX-Identifier: MIT module test_string_derivedtype_io use testdrive, only : new_unittest, unittest_type, error_type, check use stdlib_string_type, only : string_type, assignment(=), len, & diff --git a/test/string/test_string_intrinsic.f90 b/test/string/test_string_intrinsic.f90 index c84fbbd48..11fa40c13 100644 --- a/test/string/test_string_intrinsic.f90 +++ b/test/string/test_string_intrinsic.f90 @@ -1,4 +1,4 @@ -! SPDX-Identifer: MIT +! SPDX-Identifier: MIT module test_string_intrinsic use testdrive, only : new_unittest, unittest_type, error_type, check use stdlib_string_type diff --git a/test/string/test_string_operator.f90 b/test/string/test_string_operator.f90 index 0252f3f45..d2ed2f390 100644 --- a/test/string/test_string_operator.f90 +++ b/test/string/test_string_operator.f90 @@ -1,4 +1,4 @@ -! SPDX-Identifer: MIT +! SPDX-Identifier: MIT module test_string_operator use testdrive, only : new_unittest, unittest_type, error_type, check use stdlib_string_type, only : string_type, assignment(=), len, &