Skip to content

Commit fc51937

Browse files
perazzperazz
committed
enable xdp in all interfaces and tests
1 parent 278ac99 commit fc51937

8 files changed

+7
-72
lines changed

‎src/stdlib_linalg.fypp

-20
Original file line numberDiff line numberDiff line change
@@ -251,11 +251,9 @@ module stdlib_linalg
251251
!! or several (from a 2-d right-hand-side vector `b(:,:)`) systems.
252252
!!
253253
!!@note The solution is based on LAPACK's generic LU decomposition based solvers `*GESV`.
254-
!!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``).
255254
!!
256255
#:for nd,ndsuf,nde in ALL_RHS
257256
#:for rk,rt,ri in RC_KINDS_TYPES
258-
#:if rk!="xdp"
259257
module function stdlib_linalg_${ri}$_solve_${ndsuf}$(a,b,overwrite_a,err) result(x)
260258
!> Input matrix a[n,n]
261259
${rt}$, intent(inout), target :: a(:,:)
@@ -276,7 +274,6 @@ module stdlib_linalg
276274
!> Result array/matrix x[n] or x[n,nrhs]
277275
${rt}$, allocatable, target :: x${nd}$
278276
end function stdlib_linalg_${ri}$_pure_solve_${ndsuf}$
279-
#:endif
280277
#:endfor
281278
#:endfor
282279
end interface solve
@@ -302,11 +299,9 @@ module stdlib_linalg
302299
!! or several (from a 2-d right-hand-side vector `b(:,:)`) systems.
303300
!!
304301
!!@note The solution is based on LAPACK's generic LU decomposition based solvers `*GESV`.
305-
!!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``).
306302
!!
307303
#:for nd,ndsuf,nde in ALL_RHS
308304
#:for rk,rt,ri in RC_KINDS_TYPES
309-
#:if rk!="xdp"
310305
pure module subroutine stdlib_linalg_${ri}$_solve_lu_${ndsuf}$(a,b,x,pivot,overwrite_a,err)
311306
!> Input matrix a[n,n]
312307
${rt}$, intent(inout), target :: a(:,:)
@@ -321,7 +316,6 @@ module stdlib_linalg
321316
!> [optional] state return flag. On error if not requested, the code will stop
322317
type(linalg_state_type), optional, intent(out) :: err
323318
end subroutine stdlib_linalg_${ri}$_solve_lu_${ndsuf}$
324-
#:endif
325319
#:endfor
326320
#:endfor
327321
end interface solve_lu
@@ -342,11 +336,9 @@ module stdlib_linalg
342336
!! Supported data types include `real` and `complex`.
343337
!!
344338
!!@note The solution is based on LAPACK's singular value decomposition `*GELSD` methods.
345-
!!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``).
346339
!!
347340
#:for nd,ndsuf,nde in ALL_RHS
348341
#:for rk,rt,ri in RC_KINDS_TYPES
349-
#:if rk!="xdp"
350342
module function stdlib_linalg_${ri}$_lstsq_${ndsuf}$(a,b,cond,overwrite_a,rank,err) result(x)
351343
!> Input matrix a[n,n]
352344
${rt}$, intent(inout), target :: a(:,:)
@@ -363,7 +355,6 @@ module stdlib_linalg
363355
!> Result array/matrix x[n] or x[n,nrhs]
364356
${rt}$, allocatable, target :: x${nd}$
365357
end function stdlib_linalg_${ri}$_lstsq_${ndsuf}$
366-
#:endif
367358
#:endfor
368359
#:endfor
369360
end interface lstsq
@@ -385,11 +376,9 @@ module stdlib_linalg
385376
!! are provided, no internal memory allocations take place when using this interface.
386377
!!
387378
!!@note The solution is based on LAPACK's singular value decomposition `*GELSD` methods.
388-
!!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``).
389379
!!
390380
#:for nd,ndsuf,nde in ALL_RHS
391381
#:for rk,rt,ri in RC_KINDS_TYPES
392-
#:if rk!="xdp"
393382
module subroutine stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$(a,b,x,real_storage,int_storage,&
394383
#{if rt.startswith('c')}#cmpl_storage,#{endif}#cond,singvals,overwrite_a,rank,err)
395384
!> Input matrix a[n,n]
@@ -417,7 +406,6 @@ module stdlib_linalg
417406
!> [optional] state return flag. On error if not requested, the code will stop
418407
type(linalg_state_type), optional, intent(out) :: err
419408
end subroutine stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$
420-
#:endif
421409
#:endfor
422410
#:endfor
423411
end interface solve_lstsq
@@ -438,7 +426,6 @@ module stdlib_linalg
438426
!!
439427
#:for nd,ndsuf,nde in ALL_RHS
440428
#:for rk,rt,ri in RC_KINDS_TYPES
441-
#:if rk!="xdp"
442429
pure module subroutine stdlib_linalg_${ri}$_lstsq_space_${ndsuf}$(a,b,lrwork,liwork#{if rt.startswith('c')}#,lcwork#{endif}#)
443430
!> Input matrix a[m,n]
444431
${rt}$, intent(in), target :: a(:,:)
@@ -447,7 +434,6 @@ module stdlib_linalg
447434
!> Size of the working space arrays
448435
integer(ilp), intent(out) :: lrwork,liwork#{if rt.startswith('c')}#,lcwork#{endif}#
449436
end subroutine stdlib_linalg_${ri}$_lstsq_space_${ndsuf}$
450-
#:endif
451437
#:endfor
452438
#:endfor
453439
end interface lstsq_space
@@ -573,7 +559,6 @@ module stdlib_linalg
573559
!! It is possible to use partial storage [m,k] and [k,n], `k=min(m,n)`, choosing `full_matrices=.false.`.
574560
!!
575561
!!@note The solution is based on LAPACK's singular value decomposition `*GESDD` methods.
576-
!!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``).
577562
!!
578563
!!### Example
579564
!!
@@ -586,7 +571,6 @@ module stdlib_linalg
586571
!!```
587572
!!
588573
#:for rk,rt,ri in RC_KINDS_TYPES
589-
#:if rk!="xdp"
590574
module subroutine stdlib_linalg_svd_${ri}$(a,s,u,vt,overwrite_a,full_matrices,err)
591575
!!### Summary
592576
!! Compute singular value decomposition of a matrix \( A = U \cdot S \cdot \V^T \)
@@ -622,7 +606,6 @@ module stdlib_linalg
622606
!> [optional] state return flag. On error if not requested, the code will stop
623607
type(linalg_state_type), optional, intent(out) :: err
624608
end subroutine stdlib_linalg_svd_${ri}$
625-
#:endif
626609
#:endfor
627610
end interface svd
628611

@@ -645,7 +628,6 @@ module stdlib_linalg
645628
!! singular values, with size [min(m,n)].
646629
!!
647630
!!@note The solution is based on LAPACK's singular value decomposition `*GESDD` methods.
648-
!!@note BLAS/LAPACK backends do not currently support extended precision (``xdp``).
649631
!!
650632
!!### Example
651633
!!
@@ -658,7 +640,6 @@ module stdlib_linalg
658640
!!```
659641
!!
660642
#:for rk,rt,ri in RC_KINDS_TYPES
661-
#:if rk!="xdp"
662643
module function stdlib_linalg_svdvals_${ri}$(a,err) result(s)
663644
!!### Summary
664645
!! Compute singular values \(S \) from the singular-value decomposition of a matrix \( A = U \cdot S \cdot \V^T \).
@@ -682,7 +663,6 @@ module stdlib_linalg
682663
!> Array of singular values
683664
real(${rk}$), allocatable :: s(:)
684665
end function stdlib_linalg_svdvals_${ri}$
685-
#:endif
686666
#:endfor
687667
end interface svdvals
688668

‎src/stdlib_linalg_least_squares.fypp

-4
Original file line numberDiff line numberDiff line change
@@ -36,7 +36,6 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
3636
end subroutine handle_gelsd_info
3737

3838
#:for rk,rt,ri in RC_KINDS_TYPES
39-
#:if rk!="xdp"
4039
! Workspace needed by gelsd
4140
elemental subroutine ${ri}$gelsd_space(m,n,nrhs,lrwork,liwork,lcwork)
4241
integer(ilp), intent(in) :: m,n,nrhs
@@ -74,12 +73,10 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
7473

7574
end subroutine ${ri}$gelsd_space
7675

77-
#:endif
7876
#:endfor
7977

8078
#:for nd,ndsuf,nde in ALL_RHS
8179
#:for rk,rt,ri in RC_KINDS_TYPES
82-
#:if rk!="xdp"
8380

8481
! Compute the integer, real, [complex] working space requested byu the least squares procedure
8582
pure module subroutine stdlib_linalg_${ri}$_lstsq_space_${ndsuf}$(a,b,lrwork,liwork#{if rt.startswith('c')}#,lcwork#{endif}#)
@@ -357,7 +354,6 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
357354

358355
end subroutine stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$
359356

360-
#:endif
361357
#:endfor
362358
#:endfor
363359

‎src/stdlib_linalg_solve.fypp

-2
Original file line numberDiff line numberDiff line change
@@ -42,7 +42,6 @@ submodule (stdlib_linalg) stdlib_linalg_solve
4242

4343
#:for nd,ndsuf,nde in ALL_RHS
4444
#:for rk,rt,ri in RC_KINDS_TYPES
45-
#:if rk!="xdp"
4645
! Compute the solution to a real system of linear equations A * X = B
4746
module function stdlib_linalg_${ri}$_solve_${ndsuf}$(a,b,overwrite_a,err) result(x)
4847
!> Input matrix a[n,n]
@@ -163,7 +162,6 @@ submodule (stdlib_linalg) stdlib_linalg_solve
163162

164163
end subroutine stdlib_linalg_${ri}$_solve_lu_${ndsuf}$
165164

166-
#:endif
167165
#:endfor
168166
#:endfor
169167

‎src/stdlib_linalg_svd.fypp

-2
Original file line numberDiff line numberDiff line change
@@ -59,7 +59,6 @@ submodule(stdlib_linalg) stdlib_linalg_svd
5959

6060

6161
#:for rk,rt,ri in RC_KINDS_TYPES
62-
#:if rk!="xdp"
6362

6463
!> Singular values of matrix A
6564
module function stdlib_linalg_svdvals_${ri}$(a,err) result(s)
@@ -287,7 +286,6 @@ submodule(stdlib_linalg) stdlib_linalg_svd
287286
call linalg_error_handling(err0,err)
288287

289288
end subroutine stdlib_linalg_svd_${ri}$
290-
#:endif
291289
#:endfor
292290

293291
end submodule stdlib_linalg_svd

‎test/linalg/test_blas_lapack.fypp

+7-20
Original file line numberDiff line numberDiff line change
@@ -10,13 +10,6 @@ module test_blas_lapack
1010

1111
implicit none
1212

13-
real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
14-
real(dp), parameter :: dptol = 1000 * epsilon(1._dp)
15-
#:if WITH_QP
16-
real(qp), parameter :: qptol = 1000 * epsilon(1._qp)
17-
#:endif
18-
19-
2013

2114
contains
2215

@@ -41,10 +34,8 @@ contains
4134
!> Error handling
4235
type(error_type), allocatable, intent(out) :: error
4336

44-
#:if k1=="xdp"
45-
call skip_test(error, "Extended precision is not enabled")
46-
#:else
4737
${t1}$ :: A(3,3),x(3),y(3),ylap(3),yintr(3),alpha,beta
38+
real(${k1}$), parameter :: tol = 1000 * epsilon(1.0_${k1}$)
4839
call random_number(alpha)
4940
call random_number(beta)
5041
call random_number(A)
@@ -54,26 +45,22 @@ contains
5445
call gemv('No transpose',size(A,1),size(A,2),alpha,A,size(A,1),x,1,beta,ylap,1)
5546
yintr = alpha*matmul(A,x)+beta*y
5647

57-
call check(error, sum(abs(ylap - yintr)) < sptol, &
58-
"blas vs. intrinsics axpy: sum() < sptol failed")
48+
call check(error, sum(abs(ylap - yintr)) < tol, &
49+
"blas vs. intrinsics axpy: sum() < tol failed")
5950
if (allocated(error)) return
60-
#:endif
51+
6152
end subroutine test_gemv${t1[0]}$${k1}$
6253

6354
! Find matrix inverse from LU decomposition
6455
subroutine test_getri${t1[0]}$${k1}$(error)
6556
!> Error handling
6657
type(error_type), allocatable, intent(out) :: error
6758

68-
#:if k1=="xdp"
69-
call skip_test(error, "Extended precision is not enabled")
70-
#:else
71-
7259
integer(ilp), parameter :: n = 3
7360
${t1}$ :: A(n,n)
7461
${t1}$,allocatable :: work(:)
7562
integer(ilp) :: ipiv(n),info,lwork,nb
76-
63+
real(${k1}$), parameter :: tol = 1000 * epsilon(1.0_${k1}$)
7764

7865
A = eye(n)
7966

@@ -93,10 +80,10 @@ contains
9380
call check(error, info==0, "lapack getri returned info/=0")
9481
if (allocated(error)) return
9582

96-
call check(error, sum(abs(A - eye(3))) < sptol, &
83+
call check(error, sum(abs(A - eye(3))) < tol, &
9784
"lapack eye inversion: tolerance check failed")
9885
if (allocated(error)) return
99-
#:endif
86+
10087
end subroutine test_getri${t1[0]}$${k1}$
10188
#:endfor
10289

‎test/linalg/test_linalg_lstsq.fypp

-4
Original file line numberDiff line numberDiff line change
@@ -24,16 +24,13 @@ module test_linalg_least_squares
2424
tests = [tests,new_unittest("issue_823",test_issue_823)]
2525

2626
#:for rk,rt,ri in REAL_KINDS_TYPES
27-
#:if rk!="xdp"
2827
tests = [tests,new_unittest("least_squares_${ri}$",test_lstsq_one_${ri}$), &
2928
new_unittest("least_squares_randm_${ri}$",test_lstsq_random_${ri}$)]
30-
#:endif
3129
#:endfor
3230

3331
end subroutine test_least_squares
3432

3533
#:for rk,rt,ri in REAL_KINDS_TYPES
36-
#:if rk!="xdp"
3734
!> Simple polynomial fit
3835
subroutine test_lstsq_one_${ri}$(error)
3936
type(error_type), allocatable, intent(out) :: error
@@ -100,7 +97,6 @@ module test_linalg_least_squares
10097

10198
end subroutine test_lstsq_random_${ri}$
10299

103-
#:endif
104100
#:endfor
105101

106102
! Test issue #823

‎test/linalg/test_linalg_solve.fypp

-8
Original file line numberDiff line numberDiff line change
@@ -22,23 +22,18 @@ module test_linalg_solve
2222
allocate(tests(0))
2323

2424
#:for rk,rt,ri in REAL_KINDS_TYPES
25-
#:if rk!="xdp"
2625
tests = [tests,new_unittest("solve_${ri}$",test_${ri}$_solve), &
2726
new_unittest("solve_${ri}$_multiple",test_${ri}$_solve_multiple)]
28-
#:endif
2927
#:endfor
3028

3129
#:for ck,ct,ci in CMPLX_KINDS_TYPES
32-
#:if ck!="xdp"
3330
tests = [tests,new_unittest("solve_complex_${ci}$",test_${ci}$_solve), &
3431
new_unittest("solve_2x2_complex_${ci}$",test_2x2_${ci}$_solve)]
35-
#:endif
3632
#:endfor
3733

3834
end subroutine test_linear_systems
3935

4036
#:for rk,rt,ri in REAL_KINDS_TYPES
41-
#:if rk!="xdp"
4237
!> Simple linear system
4338
subroutine test_${ri}$_solve(error)
4439
type(error_type), allocatable, intent(out) :: error
@@ -88,11 +83,9 @@ module test_linalg_solve
8883
if (allocated(error)) return
8984

9085
end subroutine test_${ri}$_solve_multiple
91-
#:endif
9286
#:endfor
9387

9488
#:for rk,rt,ri in CMPLX_KINDS_TYPES
95-
#:if rk!="xdp"
9689
!> Complex linear system
9790
!> Militaru, Popa, "On the numerical solving of complex linear systems",
9891
!> Int J Pure Appl Math 76(1), 113-122, 2012.
@@ -157,7 +150,6 @@ module test_linalg_solve
157150

158151

159152
end subroutine test_2x2_${ri}$_solve
160-
#:endif
161153
#:endfor
162154

163155
end module test_linalg_solve

0 commit comments

Comments
 (0)