Skip to content

Commit 2e370f4

Browse files
committed
export working space interface
1 parent 42f2de1 commit 2e370f4

File tree

2 files changed

+93
-22
lines changed

2 files changed

+93
-22
lines changed

src/stdlib_linalg.fypp

Lines changed: 36 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -21,6 +21,8 @@ module stdlib_linalg
2121
public :: diag
2222
public :: eye
2323
public :: lstsq
24+
public :: lstsq_space
25+
public :: solve_lstsq
2426
public :: trace
2527
public :: outer_product
2628
public :: kronecker_product
@@ -273,7 +275,7 @@ module stdlib_linalg
273275
!! version: experimental
274276
!!
275277
!! Computes the squares solution to system \( A \cdot x = b \).
276-
!! ([Specification](../page/specs/stdlib_linalg.html#XXXXXxXxxxxxxx))xxxxx
278+
!! ([Specification](../page/specs/stdlib_linalg.html))
277279
!!
278280
!!### Summary
279281
!! Subroutine interface for computing least squares, i.e. the 2-norm \( || (b-A \cdot x ||_2 \) minimizing solution.
@@ -291,7 +293,7 @@ module stdlib_linalg
291293
#:for rk,rt,ri in RC_KINDS_TYPES
292294
#:if rk!="xdp"
293295
module subroutine stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$(a,b,x,real_storage,int_storage,&
294-
#{if rt.startswith('c')}#cmpl_storage,#{endif}#cond,overwrite_a,rank,err)
296+
#{if rt.startswith('c')}#cmpl_storage,#{endif}#cond,singvals,overwrite_a,rank,err)
295297
!> Input matrix a[n,n]
296298
${rt}$, intent(inout), target :: a(:,:)
297299
!> Right hand side vector or array, b[n] or b[n,nrhs]
@@ -308,6 +310,8 @@ module stdlib_linalg
308310
#:endif
309311
!> [optional] cutoff for rank evaluation: singular values s(i)<=cond*maxval(s) are considered 0.
310312
real(${rk}$), optional, intent(in) :: cond
313+
!> [optional] list of singular values [min(m,n)], in descending magnitude order, returned by the SVD
314+
real(${rk}$), optional, intent(out), target :: singvals(:)
311315
!> [optional] Can A,b data be overwritten and destroyed?
312316
logical(lk), optional, intent(in) :: overwrite_a
313317
!> [optional] Return rank of A
@@ -320,6 +324,36 @@ module stdlib_linalg
320324
#:endfor
321325
end interface solve_lstsq
322326

327+
! Return the working array space required by the least squares solver
328+
interface lstsq_space
329+
!! version: experimental
330+
!!
331+
!! Computes the integer, real [, complex] working space required by the least-squares solver
332+
!! ([Specification](../page/specs/stdlib_linalg.html))
333+
!!
334+
!!### Description
335+
!!
336+
!! This interface provides sizes of integer, real [, complex] working spaces required by the
337+
!! least-squares solver. These sizes can be used to pre-allocated working arrays in case several
338+
!! repeated least-squares solutions to a same system are sought. If pre-allocated working arrays
339+
!! are provided, no internal allocations will take place.
340+
!!
341+
#:for nd,ndsuf,nde in ALL_RHS
342+
#:for rk,rt,ri in RC_KINDS_TYPES
343+
#:if rk!="xdp"
344+
pure module subroutine stdlib_linalg_${ri}$_lstsq_space_${ndsuf}$(a,b,lrwork,liwork#{if rt.startswith('c')}#,lcwork#{endif}#)
345+
!> Input matrix a[m,n]
346+
${rt}$, intent(inout), target :: a(:,:)
347+
!> Right hand side vector or array, b[n] or b[n,nrhs]
348+
${rt}$, intent(in) :: b${nd}$
349+
!> Size of the working space arrays
350+
integer(ilp), intent(out) :: lrwork,liwork#{if rt.startswith('c')}#,lcwork#{endif}#
351+
end subroutine stdlib_linalg_${ri}$_lstsq_space_${ndsuf}$
352+
#:endif
353+
#:endfor
354+
#:endfor
355+
end interface lstsq_space
356+
323357
interface det
324358
!! version: experimental
325359
!!

src/stdlib_linalg_least_squares.fypp

Lines changed: 57 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -31,6 +31,7 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
3131
err = linalg_state_type(this,LINALG_ERROR,'SVD did not converge.')
3232
case default
3333
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
34+
end select
3435

3536
end subroutine handle_gelsd_info
3637

@@ -80,6 +81,26 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
8081
#:for rk,rt,ri in RC_KINDS_TYPES
8182
#:if rk!="xdp"
8283

84+
! Compute the integer, real, [complex] working space requested byu the least squares procedure
85+
pure module subroutine stdlib_linalg_${ri}$_lstsq_space_${ndsuf}$(a,b,lrwork,liwork#{if rt.startswith('c')}#,lcwork#{endif}#)
86+
!> Input matrix a[m,n]
87+
${rt}$, intent(inout), target :: a(:,:)
88+
!> Right hand side vector or array, b[n] or b[n,nrhs]
89+
${rt}$, intent(in) :: b${nd}$
90+
!> Size of the working space arrays
91+
integer(ilp), intent(out) :: lrwork,liwork
92+
integer(ilp) #{if rt.startswith('c')}#, intent(out)#{endif}# :: lcwork
93+
94+
integer(ilp) :: m,n,nrhs
95+
96+
m = size(a,1,kind=ilp)
97+
n = size(a,2,kind=ilp)
98+
nrhs = size(b,kind=ilp)/size(b,1,kind=ilp)
99+
100+
call ${ri}$gelsd_space(m,n,nrhs,lrwork,liwork,lcwork)
101+
102+
end subroutine stdlib_linalg_${ri}$_lstsq_space_${ndsuf}$
103+
83104
! Compute the least-squares solution to a real system of linear equations Ax = b
84105
module function stdlib_linalg_${ri}$_lstsq_${ndsuf}$(a,b,cond,overwrite_a,rank,err) result(x)
85106
!!### Summary
@@ -98,7 +119,7 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
98119
!! param: err [optional] State return flag.
99120
!! return: x Solution vector of size [n] or solution matrix of size [n,nrhs].
100121
!!
101-
!> Input matrix a[n,n]
122+
!> Input matrix a[m,n]
102123
${rt}$, intent(inout), target :: a(:,:)
103124
!> Right hand side vector or array, b[n] or b[n,nrhs]
104125
${rt}$, intent(in) :: b${nd}$
@@ -122,8 +143,8 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
122143
end function stdlib_linalg_${ri}$_lstsq_${ndsuf}$
123144

124145
! Compute the least-squares solution to a real system of linear equations Ax = b
125-
module subroutine stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$(a,b,x, &
126-
real_storage,int_storage#{if rt.startswith('c')}#,cmpl_storage#{endif}#,cond,overwrite_a,rank,err)
146+
module subroutine stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$(a,b,x,real_storage,int_storage, &
147+
#{if rt.startswith('c')}#cmpl_storage,#{endif}# cond,singvals,overwrite_a,rank,err)
127148

128149
!!### Summary
129150
!! Compute least-squares solution to a real system of linear equations \( Ax = b \)
@@ -134,12 +155,18 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
134155
!!
135156
!! param: a Input matrix of size [m,n].
136157
!! param: b Right-hand-side vector of size [n] or matrix of size [n,nrhs].
158+
!! param: x Solution vector of size [n] or solution matrix of size [n,nrhs].
159+
!! param: real_storage [optional] Real working space
160+
!! param: int_storage [optional] Integer working space
161+
#:if rt.startswith('c')
162+
!! param: cmpl_storage [optional] Complex working space
163+
#:endif
137164
!! param: cond [optional] Real input threshold indicating that singular values `s_i <= cond*maxval(s)`
138165
!! do not contribute to the matrix rank.
166+
!! param: singvals [optional] Real array of size [min(m,n)] returning a list of singular values.
139167
!! param: overwrite_a [optional] Flag indicating if the input matrix can be overwritten.
140168
!! param: rank [optional] integer flag returning matrix rank.
141-
!! param: err [optional] State return flag.
142-
!! return: x Solution vector of size [n] or solution matrix of size [n,nrhs].
169+
!! param: err [optional] State return flag.
143170
!!
144171
!> Input matrix a[n,n]
145172
${rt}$, intent(inout), target :: a(:,:)
@@ -157,6 +184,8 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
157184
#:endif
158185
!> [optional] cutoff for rank evaluation: singular values s(i)<=cond*maxval(s) are considered 0.
159186
real(${rk}$), optional, intent(in) :: cond
187+
!> [optional] list of singular values [min(m,n)], in descending magnitude order, returned by the SVD
188+
real(${rk}$), optional, intent(out), target :: singvals(:)
160189
!> [optional] Can A,b data be overwritten and destroyed?
161190
logical(lk), optional, intent(in) :: overwrite_a
162191
!> [optional] Return rank of A
@@ -167,12 +196,11 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
167196
!! Local variables
168197
type(linalg_state_type) :: err0
169198
integer(ilp) :: m,n,lda,ldb,nrhs,ldx,nrhsx,info,mnmin,mnmax,arank,lrwork,liwork,lcwork
170-
integer(ilp) :: nrs,nis,ncs
199+
integer(ilp) :: nrs,nis,ncs,nsvd
171200
integer(ilp), pointer :: iwork(:)
172201
logical(lk) :: copy_a
173202
real(${rk}$) :: acond,rcond
174-
real(${rk}$), allocatable :: singular(:)
175-
real(${rk}$), pointer :: rwork(:)
203+
real(${rk}$), pointer :: rwork(:),singular(:)
176204
${rt}$, pointer :: xmat(:,:),amat(:,:),cwork(:)
177205

178206
! Problem sizes
@@ -213,8 +241,14 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
213241
xmat(1:n,1:nrhs) => x
214242

215243
! Singular values array (in decreasing order)
216-
allocate(singular(mnmin))
217-
244+
if (present(singvals)) then
245+
singular => singvals
246+
nsvd = size(singular,kind=ilp)
247+
else
248+
allocate(singular(mnmin))
249+
nsvd = mnmin
250+
endif
251+
218252
! rcond is used to determine the effective rank of A.
219253
! Singular values S(i) <= RCOND*maxval(S) are treated as zero.
220254
! Use same default value as NumPy
@@ -254,12 +288,14 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
254288
ncs = size(iwork,kind=ilp)
255289
#:endif
256290

257-
if (nrs<lrwork .or. nis<liwork#{if rt.startswith('c')}# .or. ncs<lcwork#{endif}#) then
291+
if (nrs<lrwork .or. nis<liwork#{if rt.startswith('c')}# .or. ncs<lcwork#{endif}# &
292+
.or. nsvd<mnmin) then
258293
! Halt on insufficient space
259294
err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient working space: ',&
260295
'real=',nrs,' should be >=',lrwork, &
261-
', int=',nis,' should be >=',liwork &
262-
#{if rt.startswith('complex')}#,', cmplx=',ncs,' should be >=',lcwork#{endif}#)
296+
', int=',nis,' should be >=',liwork, &
297+
#{if rt.startswith('complex')}#', cmplx=',ncs,' should be >=',lcwork, &#{endif}#
298+
', singv=',nsvd,' should be >=',mnmin)
263299

264300
else
265301

@@ -270,23 +306,24 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
270306
#:else
271307
rwork,nrs,iwork,info)
272308
#:endif
309+
310+
! The condition number of A in the 2-norm = S(1)/S(min(m,n)).
311+
acond = singular(1)/singular(mnmin)
312+
313+
! Process output
314+
call handle_gelsd_info(info,lda,n,ldb,nrhs,err0)
273315

274316
endif
275317

276-
! The condition number of A in the 2-norm = S(1)/S(min(m,n)).
277-
acond = singular(1)/singular(mnmin)
278-
279-
! Process output
280-
call handle_gelsd_info(info,lda,n,ldb,nrhs,err0)
281-
282318
! Process output and return
283-
1 if (copy_a) deallocate(amat)
319+
if (copy_a) deallocate(amat)
284320
if (present(rank)) rank = arank
285321
if (.not.present(real_storage)) deallocate(rwork)
286322
if (.not.present(int_storage)) deallocate(iwork)
287323
#:if rt.startswith('complex')
288324
if (.not.present(cmpl_storage)) deallocate(cwork)
289325
#:endif
326+
if (.not.present(singvals)) deallocate(singular)
290327
call linalg_error_handling(err0,err)
291328

292329
end subroutine stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$

0 commit comments

Comments
 (0)