From 6a66b8e68b2966bf655766d8b29a5c9b0d1fe6e5 Mon Sep 17 00:00:00 2001 From: "Michael Hirsch, Ph.D" Date: Mon, 6 Jan 2020 12:27:43 -0500 Subject: [PATCH 1/2] make real128 optional --- CMakeLists.txt | 5 + src/CMakeLists.txt | 11 ++- src/io_qp.f90 | 74 ++++++++++++++ src/opt_qp.f90 | 15 +++ ...ntal_io.f90 => stdlib_experimental_io.F90} | 96 +++++-------------- ...inds.f90 => stdlib_experimental_kinds.F90} | 10 +- ...val.f90 => stdlib_experimental_optval.F90} | 30 +++--- src/tests/io/CMakeLists.txt | 10 +- src/tests/optval/CMakeLists.txt | 9 +- .../{test_optval.f90 => test_optval.F90} | 41 ++++---- 10 files changed, 185 insertions(+), 116 deletions(-) create mode 100644 src/io_qp.f90 create mode 100644 src/opt_qp.f90 rename src/{stdlib_experimental_io.f90 => stdlib_experimental_io.F90} (85%) rename src/{stdlib_experimental_kinds.f90 => stdlib_experimental_kinds.F90} (65%) rename src/{stdlib_experimental_optval.f90 => stdlib_experimental_optval.F90} (88%) rename src/tests/optval/{test_optval.f90 => test_optval.F90} (98%) diff --git a/CMakeLists.txt b/CMakeLists.txt index ffd1c0def..1b62dadb4 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -7,6 +7,8 @@ enable_testing() # and thereby can clash if module/submodule names are the same in different parts of library set(CMAKE_Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}) +option(REAL128 "make real128 precision available") + # --- compiler options if(CMAKE_Fortran_COMPILER_ID STREQUAL GNU) add_compile_options(-fimplicit-none) @@ -21,5 +23,8 @@ include(CheckFortranSourceCompiles) include(CheckFortranSourceRuns) check_fortran_source_compiles("error stop i; end" f18errorstop SRC_EXT f90) check_fortran_source_runs("use, intrinsic :: iso_fortran_env, only : real128; real(real128) :: x; x = x+1; end" f03real128) +if(NOT f03real128) + set(REAL128 false) +endif() add_subdirectory(src) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index ee5a7aa22..17c34b91e 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -1,9 +1,9 @@ set(SRC stdlib_experimental_ascii.f90 - stdlib_experimental_io.f90 + stdlib_experimental_io.F90 stdlib_experimental_error.f90 - stdlib_experimental_optval.f90 - stdlib_experimental_kinds.f90 + stdlib_experimental_optval.F90 + stdlib_experimental_kinds.F90 ) add_library(fortran_stdlib ${SRC}) @@ -14,6 +14,11 @@ else() target_sources(fortran_stdlib PRIVATE f08estop.f90) endif() +if(REAL128) + target_compile_definitions(fortran_stdlib PRIVATE REAL128) + target_sources(fortran_stdlib PRIVATE io_qp.f90 opt_qp.f90) +endif() + add_subdirectory(tests) install(TARGETS fortran_stdlib diff --git a/src/io_qp.f90 b/src/io_qp.f90 new file mode 100644 index 000000000..669c83811 --- /dev/null +++ b/src/io_qp.f90 @@ -0,0 +1,74 @@ +submodule (stdlib_experimental_io) io_qp + +use stdlib_experimental_kinds, only : qp + +implicit none + +contains + +module procedure qloadtxt +! Loads a 2D array from a text file. +! +! Arguments +! --------- +! +! Filename to load the array from +! The array 'd' will be automatically allocated with the correct dimensions +! +! Example +! ------- +! +! real(qp), allocatable :: data(:, :) +! call loadtxt("log.txt", data) ! 'data' will be automatically allocated +! +! Where 'log.txt' contains for example:: +! +! 1 2 3 +! 2 4 6 +! 8 9 10 +! 11 12 13 +! ... +! +integer :: s +integer :: nrow,ncol,i + +s = open(filename) + +! determine number of columns +ncol = number_of_columns(s) + +! determine number or rows +nrow = number_of_rows_numeric(s) + +allocate(d(nrow, ncol)) +do i = 1, nrow + read(s, *) d(i, :) +end do +close(s) +end procedure + +module procedure qsavetxt + ! Saves a 2D array into a textfile. + ! + ! Arguments + ! --------- + ! + ! + ! Example + ! ------- + ! + ! real(dp) :: data(3, 2) + ! call savetxt("log.txt", data) + + integer :: s, i + character(len=14) :: format_string + + write(format_string, '(a1,i06,a7)') '(', size(d, 2), 'f40.34)' + s = open(filename, "w") + do i = 1, size(d, 1) + write(s, format_string) d(i, :) + end do + close(s) +end procedure + +end submodule \ No newline at end of file diff --git a/src/opt_qp.f90 b/src/opt_qp.f90 new file mode 100644 index 000000000..6f409779a --- /dev/null +++ b/src/opt_qp.f90 @@ -0,0 +1,15 @@ +submodule (stdlib_experimental_optval) opt_qp + +implicit none + +contains + +module procedure optval_qp + if (present(x)) then + y = x + else + y = default + end if +end procedure optval_qp + +end submodule opt_qp \ No newline at end of file diff --git a/src/stdlib_experimental_io.f90 b/src/stdlib_experimental_io.F90 similarity index 85% rename from src/stdlib_experimental_io.f90 rename to src/stdlib_experimental_io.F90 index 8a0058c20..97f18d6f5 100644 --- a/src/stdlib_experimental_io.f90 +++ b/src/stdlib_experimental_io.F90 @@ -1,12 +1,15 @@ module stdlib_experimental_io -use stdlib_experimental_kinds, only: sp, dp, qp +use stdlib_experimental_kinds, only: sp, dp +#ifdef REAL128 +use stdlib_experimental_kinds, only: qp +#endif use stdlib_experimental_error, only: error_stop use stdlib_experimental_optval, only: optval use stdlib_experimental_ascii, only: is_blank implicit none private ! Public API -public :: loadtxt, savetxt, open +public :: loadtxt, savetxt, open, number_of_columns, number_of_rows_numeric ! Private API that is exposed so that we can test it in tests public :: parse_mode @@ -15,15 +18,34 @@ module stdlib_experimental_io interface loadtxt module procedure sloadtxt module procedure dloadtxt +#ifdef REAL128 module procedure qloadtxt +#endif end interface interface savetxt module procedure ssavetxt module procedure dsavetxt +#ifdef REAL128 module procedure qsavetxt +#endif end interface +#ifdef REAL128 +interface +module subroutine qsavetxt(filename, d) +character(len=*), intent(in) :: filename ! File to save the array to +real(qp), intent(in) :: d(:,:) ! The 2D array to save +end subroutine + +module subroutine qloadtxt(filename, d) +character(len=*), intent(in) :: filename +real(qp), allocatable, intent(out) :: d(:,:) +end subroutine + +end interface +#endif + contains subroutine sloadtxt(filename, d) @@ -112,49 +134,6 @@ subroutine dloadtxt(filename, d) close(s) end subroutine -subroutine qloadtxt(filename, d) -! Loads a 2D array from a text file. -! -! Arguments -! --------- -! -! Filename to load the array from -character(len=*), intent(in) :: filename -! The array 'd' will be automatically allocated with the correct dimensions -real(qp), allocatable, intent(out) :: d(:,:) -! -! Example -! ------- -! -! real(qp), allocatable :: data(:, :) -! call loadtxt("log.txt", data) ! 'data' will be automatically allocated -! -! Where 'log.txt' contains for example:: -! -! 1 2 3 -! 2 4 6 -! 8 9 10 -! 11 12 13 -! ... -! -integer :: s -integer :: nrow,ncol,i - -s = open(filename) - -! determine number of columns -ncol = number_of_columns(s) - -! determine number or rows -nrow = number_of_rows_numeric(s) - -allocate(d(nrow, ncol)) -do i = 1, nrow - read(s, *) d(i, :) -end do -close(s) -end subroutine - subroutine ssavetxt(filename, d) ! Saves a 2D array into a textfile. @@ -202,33 +181,6 @@ subroutine dsavetxt(filename, d) close(s) end subroutine -subroutine qsavetxt(filename, d) -! Saves a 2D array into a textfile. -! -! Arguments -! --------- -! -character(len=*), intent(in) :: filename ! File to save the array to -real(qp), intent(in) :: d(:,:) ! The 2D array to save -! -! Example -! ------- -! -! real(dp) :: data(3, 2) -! call savetxt("log.txt", data) - -integer :: s, i -character(len=14) :: format_string - -write(format_string, '(a1,i06,a7)') '(', size(d, 2), 'f40.34)' -s = open(filename, "w") -do i = 1, size(d, 1) - write(s, format_string) d(i, :) -end do -close(s) -end subroutine - - integer function number_of_columns(s) ! determine number of columns integer,intent(in)::s diff --git a/src/stdlib_experimental_kinds.f90 b/src/stdlib_experimental_kinds.F90 similarity index 65% rename from src/stdlib_experimental_kinds.f90 rename to src/stdlib_experimental_kinds.F90 index d40a947b1..e6228148e 100644 --- a/src/stdlib_experimental_kinds.f90 +++ b/src/stdlib_experimental_kinds.F90 @@ -1,10 +1,16 @@ module stdlib_experimental_kinds -use iso_fortran_env, only: sp=>real32, dp=>real64, qp=>real128 +use iso_fortran_env, only: sp=>real32, dp=>real64 +#ifdef REAL128 +use iso_fortran_env, only: qp=>real128 +#endif use iso_fortran_env, only: int8, int16, int32, int64 ! If we decide later to use iso_fortran_env instead of iso_fortran_env: !use iso_c_binding, only: sp=>c_float, dp=>c_double, qp=>c_float128 !use iso_c_binding, only: int8=>c_int8_t, int16=>c_int16_t, int32=>c_int32_t, int64=>c_int64_t implicit none private -public sp, dp, qp, int8, int16, int32, int64 +public :: sp, dp, int8, int16, int32, int64 +#ifdef REAL128 +public :: qp +#endif end module diff --git a/src/stdlib_experimental_optval.f90 b/src/stdlib_experimental_optval.F90 similarity index 88% rename from src/stdlib_experimental_optval.f90 rename to src/stdlib_experimental_optval.F90 index 6672d414c..d1c9ddae6 100644 --- a/src/stdlib_experimental_optval.f90 +++ b/src/stdlib_experimental_optval.F90 @@ -8,7 +8,11 @@ module stdlib_experimental_optval !! !! It is an error to call `optval` with a single actual argument. !! - use stdlib_experimental_kinds, only: sp, dp, qp, int8, int16, int32, int64 + use stdlib_experimental_kinds, only: sp, dp, int8, int16, int32, int64 +#ifdef REAL128 + use stdlib_experimental_kinds, only : qp +#endif + implicit none @@ -19,7 +23,9 @@ module stdlib_experimental_optval interface optval module procedure optval_sp module procedure optval_dp +#ifdef REAL128 module procedure optval_qp +#endif module procedure optval_int8 module procedure optval_int16 module procedure optval_int32 @@ -30,6 +36,15 @@ module stdlib_experimental_optval ! TODO: differentiate ascii & ucs char kinds end interface optval +#ifdef REAL128 + interface + module pure function optval_qp(x, default) result(y) + real(qp), intent(in), optional :: x + real(qp), intent(in) :: default + real(qp) :: y + end function + end interface +#endif contains @@ -60,19 +75,6 @@ pure function optval_dp(x, default) result(y) end function optval_dp - pure function optval_qp(x, default) result(y) - real(qp), intent(in), optional :: x - real(qp), intent(in) :: default - real(qp) :: y - - if (present(x)) then - y = x - else - y = default - end if - end function optval_qp - - pure function optval_int8(x, default) result(y) integer(int8), intent(in), optional :: x integer(int8), intent(in) :: default diff --git a/src/tests/io/CMakeLists.txt b/src/tests/io/CMakeLists.txt index 68388a5e5..52524facc 100644 --- a/src/tests/io/CMakeLists.txt +++ b/src/tests/io/CMakeLists.txt @@ -1,10 +1,12 @@ ADDTEST(loadtxt) ADDTEST(savetxt) -ADDTEST(loadtxt_qp) -ADDTEST(savetxt_qp) -set_tests_properties(loadtxt_qp PROPERTIES LABELS quadruple_precision) -set_tests_properties(savetxt_qp PROPERTIES LABELS quadruple_precision) +if(REAL128) + ADDTEST(loadtxt_qp) + ADDTEST(savetxt_qp) + set_tests_properties(loadtxt_qp PROPERTIES LABELS quadruple_precision) + set_tests_properties(savetxt_qp PROPERTIES LABELS quadruple_precision) +endif() ADDTEST(open) ADDTEST(parse_mode) diff --git a/src/tests/optval/CMakeLists.txt b/src/tests/optval/CMakeLists.txt index 19193fe1e..91aab97a6 100644 --- a/src/tests/optval/CMakeLists.txt +++ b/src/tests/optval/CMakeLists.txt @@ -1 +1,8 @@ -ADDTEST(optval) +add_executable(test_optval test_optval.F90) +target_link_libraries(test_optval fortran_stdlib) +if(REAL128) + target_compile_definitions(test_optval PRIVATE REAL128) +endif() +add_test(NAME optval + COMMAND $ ${CMAKE_CURRENT_BINARY_DIR} + WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) diff --git a/src/tests/optval/test_optval.f90 b/src/tests/optval/test_optval.F90 similarity index 98% rename from src/tests/optval/test_optval.f90 rename to src/tests/optval/test_optval.F90 index 85d9748c9..11bbc01ae 100644 --- a/src/tests/optval/test_optval.f90 +++ b/src/tests/optval/test_optval.F90 @@ -9,8 +9,9 @@ program test_optval call test_optval_sp call test_optval_dp +#ifdef REAL128 call test_optval_qp - +#endif call test_optval_int8 call test_optval_int16 call test_optval_int32 @@ -22,14 +23,14 @@ program test_optval contains - + subroutine test_optval_sp print *, "test_optval_sp" call assert(foo_sp(1.0_sp) == 1.0_sp) call assert(foo_sp() == 2.0_sp) end subroutine test_optval_sp - + function foo_sp(x) result(z) real(sp), intent(in), optional :: x real(sp) :: z @@ -43,41 +44,41 @@ subroutine test_optval_dp call assert(foo_dp() == 2.0_dp) end subroutine test_optval_dp - + function foo_dp(x) result(z) real(dp), intent(in), optional :: x real(dp) :: z z = optval(x, 2.0_dp) endfunction foo_dp - +#ifdef REAL128 subroutine test_optval_qp print *, "test_optval_qp" call assert(foo_qp(1.0_qp) == 1.0_qp) call assert(foo_qp() == 2.0_qp) end subroutine test_optval_qp - + function foo_qp(x) result(z) real(qp), intent(in), optional :: x real(qp) :: z z = optval(x, 2.0_qp) endfunction foo_qp - - +#endif + subroutine test_optval_int8 print *, "test_optval_int8" call assert(foo_int8(1_int8) == 1_int8) call assert(foo_int8() == 2_int8) end subroutine test_optval_int8 - + function foo_int8(x) result(z) integer(int8), intent(in), optional :: x integer(int8) :: z z = optval(x, 2_int8) endfunction foo_int8 - + subroutine test_optval_int16 print *, "test_optval_int16" @@ -85,41 +86,41 @@ subroutine test_optval_int16 call assert(foo_int16() == 2_int16) end subroutine test_optval_int16 - + function foo_int16(x) result(z) integer(int16), intent(in), optional :: x integer(int16) :: z z = optval(x, 2_int16) endfunction foo_int16 - + subroutine test_optval_int32 print *, "test_optval_int32" call assert(foo_int32(1_int32) == 1_int32) call assert(foo_int32() == 2_int32) end subroutine test_optval_int32 - + function foo_int32(x) result(z) integer(int32), intent(in), optional :: x integer(int32) :: z z = optval(x, 2_int32) endfunction foo_int32 - + subroutine test_optval_int64 print *, "test_optval_int64" call assert(foo_int64(1_int64) == 1_int64) call assert(foo_int64() == 2_int64) end subroutine test_optval_int64 - + function foo_int64(x) result(z) integer(int64), intent(in), optional :: x integer(int64) :: z z = optval(x, 2_int64) endfunction foo_int64 - + subroutine test_optval_logical print *, "test_optval_logical" @@ -127,13 +128,13 @@ subroutine test_optval_logical call assert(.not.foo_logical()) end subroutine test_optval_logical - + function foo_logical(x) result(z) logical, intent(in), optional :: x logical :: z z = optval(x, .false.) endfunction foo_logical - + subroutine test_optval_character print *, "test_optval_character" @@ -141,11 +142,11 @@ subroutine test_optval_character call assert(foo_character() == "y") end subroutine test_optval_character - + function foo_character(x) result(z) character(len=*), intent(in), optional :: x character(len=:), allocatable :: z z = optval(x, "y") endfunction foo_character - + end program test_optval From 738bde2f95b5b895670784f7ca49171c42836c15 Mon Sep 17 00:00:00 2001 From: "Michael Hirsch, Ph.D" Date: Mon, 6 Jan 2020 12:33:43 -0500 Subject: [PATCH 2/2] ci: add real128 test --- .github/workflows/ci_real128.yml | 46 ++++++++++++++++++++++++++++++++ .github/workflows/ci_windows.yml | 2 +- 2 files changed, 47 insertions(+), 1 deletion(-) create mode 100644 .github/workflows/ci_real128.yml diff --git a/.github/workflows/ci_real128.yml b/.github/workflows/ci_real128.yml new file mode 100644 index 000000000..d992554cd --- /dev/null +++ b/.github/workflows/ci_real128.yml @@ -0,0 +1,46 @@ +name: ci_real128 + +on: [push, pull_request] + +env: + CI: "ON" + +jobs: + linux: + runs-on: ubuntu-latest + strategy: + fail-fast: false + + steps: + - uses: actions/checkout@v1 + + - name: Set up Python 3.x + uses: actions/setup-python@v1 + with: + python-version: 3.x + + - name: Set up CMake + run: pip install --upgrade cmake + + - name: Cmake configure + - run: cmake -DREAL128=true -B build + env: + FC: gfortran + CC: gcc + CXX: g++ + + - name: CMake build + run: cmake --build build --parallel + + - run: cmake --build build --verbose --parallel 1 + if: failure() + + - name: CTest + run: ctest --output-on-failure --parallel -V + working-directory: build + + - uses: actions/upload-artifact@v1 + if: failure() + with: + name: Real128CMakeTestlog + path: build/Testing/Temporary/LastTest.log \ No newline at end of file diff --git a/.github/workflows/ci_windows.yml b/.github/workflows/ci_windows.yml index 077db6bb2..30abe4d58 100644 --- a/.github/workflows/ci_windows.yml +++ b/.github/workflows/ci_windows.yml @@ -6,7 +6,7 @@ env: CI: "ON" jobs: - Build: + cmake: runs-on: windows-latest strategy: fail-fast: false