Skip to content

Commit 6a66b8e

Browse files
scivisionscivision
committed
make real128 optional
1 parent e2b0cda commit 6a66b8e

10 files changed

+185
-116
lines changed

‎CMakeLists.txt

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,8 @@ enable_testing()
77
# and thereby can clash if module/submodule names are the same in different parts of library
88
set(CMAKE_Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR})
99

10+
option(REAL128 "make real128 precision available")
11+
1012
# --- compiler options
1113
if(CMAKE_Fortran_COMPILER_ID STREQUAL GNU)
1214
add_compile_options(-fimplicit-none)
@@ -21,5 +23,8 @@ include(CheckFortranSourceCompiles)
2123
include(CheckFortranSourceRuns)
2224
check_fortran_source_compiles("error stop i; end" f18errorstop SRC_EXT f90)
2325
check_fortran_source_runs("use, intrinsic :: iso_fortran_env, only : real128; real(real128) :: x; x = x+1; end" f03real128)
26+
if(NOT f03real128)
27+
set(REAL128 false)
28+
endif()
2429

2530
add_subdirectory(src)

‎src/CMakeLists.txt

Lines changed: 8 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,9 @@
11
set(SRC
22
stdlib_experimental_ascii.f90
3-
stdlib_experimental_io.f90
3+
stdlib_experimental_io.F90
44
stdlib_experimental_error.f90
5-
stdlib_experimental_optval.f90
6-
stdlib_experimental_kinds.f90
5+
stdlib_experimental_optval.F90
6+
stdlib_experimental_kinds.F90
77
)
88

99
add_library(fortran_stdlib ${SRC})
@@ -14,6 +14,11 @@ else()
1414
target_sources(fortran_stdlib PRIVATE f08estop.f90)
1515
endif()
1616

17+
if(REAL128)
18+
target_compile_definitions(fortran_stdlib PRIVATE REAL128)
19+
target_sources(fortran_stdlib PRIVATE io_qp.f90 opt_qp.f90)
20+
endif()
21+
1722
add_subdirectory(tests)
1823

1924
install(TARGETS fortran_stdlib

‎src/io_qp.f90

Lines changed: 74 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,74 @@
1+
submodule (stdlib_experimental_io) io_qp
2+
3+
use stdlib_experimental_kinds, only : qp
4+
5+
implicit none
6+
7+
contains
8+
9+
module procedure qloadtxt
10+
! Loads a 2D array from a text file.
11+
!
12+
! Arguments
13+
! ---------
14+
!
15+
! Filename to load the array from
16+
! The array 'd' will be automatically allocated with the correct dimensions
17+
!
18+
! Example
19+
! -------
20+
!
21+
! real(qp), allocatable :: data(:, :)
22+
! call loadtxt("log.txt", data) ! 'data' will be automatically allocated
23+
!
24+
! Where 'log.txt' contains for example::
25+
!
26+
! 1 2 3
27+
! 2 4 6
28+
! 8 9 10
29+
! 11 12 13
30+
! ...
31+
!
32+
integer :: s
33+
integer :: nrow,ncol,i
34+
35+
s = open(filename)
36+
37+
! determine number of columns
38+
ncol = number_of_columns(s)
39+
40+
! determine number or rows
41+
nrow = number_of_rows_numeric(s)
42+
43+
allocate(d(nrow, ncol))
44+
do i = 1, nrow
45+
read(s, *) d(i, :)
46+
end do
47+
close(s)
48+
end procedure
49+
50+
module procedure qsavetxt
51+
! Saves a 2D array into a textfile.
52+
!
53+
! Arguments
54+
! ---------
55+
!
56+
!
57+
! Example
58+
! -------
59+
!
60+
! real(dp) :: data(3, 2)
61+
! call savetxt("log.txt", data)
62+
63+
integer :: s, i
64+
character(len=14) :: format_string
65+
66+
write(format_string, '(a1,i06,a7)') '(', size(d, 2), 'f40.34)'
67+
s = open(filename, "w")
68+
do i = 1, size(d, 1)
69+
write(s, format_string) d(i, :)
70+
end do
71+
close(s)
72+
end procedure
73+
74+
end submodule

‎src/opt_qp.f90

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
submodule (stdlib_experimental_optval) opt_qp
2+
3+
implicit none
4+
5+
contains
6+
7+
module procedure optval_qp
8+
if (present(x)) then
9+
y = x
10+
else
11+
y = default
12+
end if
13+
end procedure optval_qp
14+
15+
end submodule opt_qp

‎src/stdlib_experimental_io.f90 renamed to ‎src/stdlib_experimental_io.F90

Lines changed: 24 additions & 72 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,15 @@
11
module stdlib_experimental_io
2-
use stdlib_experimental_kinds, only: sp, dp, qp
2+
use stdlib_experimental_kinds, only: sp, dp
3+
#ifdef REAL128
4+
use stdlib_experimental_kinds, only: qp
5+
#endif
36
use stdlib_experimental_error, only: error_stop
47
use stdlib_experimental_optval, only: optval
58
use stdlib_experimental_ascii, only: is_blank
69
implicit none
710
private
811
! Public API
9-
public :: loadtxt, savetxt, open
12+
public :: loadtxt, savetxt, open, number_of_columns, number_of_rows_numeric
1013

1114
! Private API that is exposed so that we can test it in tests
1215
public :: parse_mode
@@ -15,15 +18,34 @@ module stdlib_experimental_io
1518
interface loadtxt
1619
module procedure sloadtxt
1720
module procedure dloadtxt
21+
#ifdef REAL128
1822
module procedure qloadtxt
23+
#endif
1924
end interface
2025

2126
interface savetxt
2227
module procedure ssavetxt
2328
module procedure dsavetxt
29+
#ifdef REAL128
2430
module procedure qsavetxt
31+
#endif
2532
end interface
2633

34+
#ifdef REAL128
35+
interface
36+
module subroutine qsavetxt(filename, d)
37+
character(len=*), intent(in) :: filename ! File to save the array to
38+
real(qp), intent(in) :: d(:,:) ! The 2D array to save
39+
end subroutine
40+
41+
module subroutine qloadtxt(filename, d)
42+
character(len=*), intent(in) :: filename
43+
real(qp), allocatable, intent(out) :: d(:,:)
44+
end subroutine
45+
46+
end interface
47+
#endif
48+
2749
contains
2850

2951
subroutine sloadtxt(filename, d)
@@ -112,49 +134,6 @@ subroutine dloadtxt(filename, d)
112134
close(s)
113135
end subroutine
114136

115-
subroutine qloadtxt(filename, d)
116-
! Loads a 2D array from a text file.
117-
!
118-
! Arguments
119-
! ---------
120-
!
121-
! Filename to load the array from
122-
character(len=*), intent(in) :: filename
123-
! The array 'd' will be automatically allocated with the correct dimensions
124-
real(qp), allocatable, intent(out) :: d(:,:)
125-
!
126-
! Example
127-
! -------
128-
!
129-
! real(qp), allocatable :: data(:, :)
130-
! call loadtxt("log.txt", data) ! 'data' will be automatically allocated
131-
!
132-
! Where 'log.txt' contains for example::
133-
!
134-
! 1 2 3
135-
! 2 4 6
136-
! 8 9 10
137-
! 11 12 13
138-
! ...
139-
!
140-
integer :: s
141-
integer :: nrow,ncol,i
142-
143-
s = open(filename)
144-
145-
! determine number of columns
146-
ncol = number_of_columns(s)
147-
148-
! determine number or rows
149-
nrow = number_of_rows_numeric(s)
150-
151-
allocate(d(nrow, ncol))
152-
do i = 1, nrow
153-
read(s, *) d(i, :)
154-
end do
155-
close(s)
156-
end subroutine
157-
158137

159138
subroutine ssavetxt(filename, d)
160139
! Saves a 2D array into a textfile.
@@ -202,33 +181,6 @@ subroutine dsavetxt(filename, d)
202181
close(s)
203182
end subroutine
204183

205-
subroutine qsavetxt(filename, d)
206-
! Saves a 2D array into a textfile.
207-
!
208-
! Arguments
209-
! ---------
210-
!
211-
character(len=*), intent(in) :: filename ! File to save the array to
212-
real(qp), intent(in) :: d(:,:) ! The 2D array to save
213-
!
214-
! Example
215-
! -------
216-
!
217-
! real(dp) :: data(3, 2)
218-
! call savetxt("log.txt", data)
219-
220-
integer :: s, i
221-
character(len=14) :: format_string
222-
223-
write(format_string, '(a1,i06,a7)') '(', size(d, 2), 'f40.34)'
224-
s = open(filename, "w")
225-
do i = 1, size(d, 1)
226-
write(s, format_string) d(i, :)
227-
end do
228-
close(s)
229-
end subroutine
230-
231-
232184
integer function number_of_columns(s)
233185
! determine number of columns
234186
integer,intent(in)::s

‎src/stdlib_experimental_kinds.f90 renamed to ‎src/stdlib_experimental_kinds.F90

Lines changed: 8 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,16 @@
11
module stdlib_experimental_kinds
2-
use iso_fortran_env, only: sp=>real32, dp=>real64, qp=>real128
2+
use iso_fortran_env, only: sp=>real32, dp=>real64
3+
#ifdef REAL128
4+
use iso_fortran_env, only: qp=>real128
5+
#endif
36
use iso_fortran_env, only: int8, int16, int32, int64
47
! If we decide later to use iso_fortran_env instead of iso_fortran_env:
58
!use iso_c_binding, only: sp=>c_float, dp=>c_double, qp=>c_float128
69
!use iso_c_binding, only: int8=>c_int8_t, int16=>c_int16_t, int32=>c_int32_t, int64=>c_int64_t
710
implicit none
811
private
9-
public sp, dp, qp, int8, int16, int32, int64
12+
public :: sp, dp, int8, int16, int32, int64
13+
#ifdef REAL128
14+
public :: qp
15+
#endif
1016
end module

‎src/stdlib_experimental_optval.f90 renamed to ‎src/stdlib_experimental_optval.F90

Lines changed: 16 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,11 @@ module stdlib_experimental_optval
88
!!
99
!! It is an error to call `optval` with a single actual argument.
1010
!!
11-
use stdlib_experimental_kinds, only: sp, dp, qp, int8, int16, int32, int64
11+
use stdlib_experimental_kinds, only: sp, dp, int8, int16, int32, int64
12+
#ifdef REAL128
13+
use stdlib_experimental_kinds, only : qp
14+
#endif
15+
1216
implicit none
1317

1418

@@ -19,7 +23,9 @@ module stdlib_experimental_optval
1923
interface optval
2024
module procedure optval_sp
2125
module procedure optval_dp
26+
#ifdef REAL128
2227
module procedure optval_qp
28+
#endif
2329
module procedure optval_int8
2430
module procedure optval_int16
2531
module procedure optval_int32
@@ -30,6 +36,15 @@ module stdlib_experimental_optval
3036
! TODO: differentiate ascii & ucs char kinds
3137
end interface optval
3238

39+
#ifdef REAL128
40+
interface
41+
module pure function optval_qp(x, default) result(y)
42+
real(qp), intent(in), optional :: x
43+
real(qp), intent(in) :: default
44+
real(qp) :: y
45+
end function
46+
end interface
47+
#endif
3348

3449
contains
3550

@@ -60,19 +75,6 @@ pure function optval_dp(x, default) result(y)
6075
end function optval_dp
6176

6277

63-
pure function optval_qp(x, default) result(y)
64-
real(qp), intent(in), optional :: x
65-
real(qp), intent(in) :: default
66-
real(qp) :: y
67-
68-
if (present(x)) then
69-
y = x
70-
else
71-
y = default
72-
end if
73-
end function optval_qp
74-
75-
7678
pure function optval_int8(x, default) result(y)
7779
integer(int8), intent(in), optional :: x
7880
integer(int8), intent(in) :: default

‎src/tests/io/CMakeLists.txt

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,12 @@
11
ADDTEST(loadtxt)
22
ADDTEST(savetxt)
33

4-
ADDTEST(loadtxt_qp)
5-
ADDTEST(savetxt_qp)
6-
set_tests_properties(loadtxt_qp PROPERTIES LABELS quadruple_precision)
7-
set_tests_properties(savetxt_qp PROPERTIES LABELS quadruple_precision)
4+
if(REAL128)
5+
ADDTEST(loadtxt_qp)
6+
ADDTEST(savetxt_qp)
7+
set_tests_properties(loadtxt_qp PROPERTIES LABELS quadruple_precision)
8+
set_tests_properties(savetxt_qp PROPERTIES LABELS quadruple_precision)
9+
endif()
810

911
ADDTEST(open)
1012
ADDTEST(parse_mode)

‎src/tests/optval/CMakeLists.txt

Lines changed: 8 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1 +1,8 @@
1-
ADDTEST(optval)
1+
add_executable(test_optval test_optval.F90)
2+
target_link_libraries(test_optval fortran_stdlib)
3+
if(REAL128)
4+
target_compile_definitions(test_optval PRIVATE REAL128)
5+
endif()
6+
add_test(NAME optval
7+
COMMAND $<TARGET_FILE:test_optval> ${CMAKE_CURRENT_BINARY_DIR}
8+
WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR})

0 commit comments

Comments
 (0)