@@ -31,6 +31,7 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
31
31
err = linalg_state_type(this,LINALG_ERROR,'SVD did not converge.')
32
32
case default
33
33
err = linalg_state_type(this,LINALG_INTERNAL_ERROR,'catastrophic error')
34
+ end select
34
35
35
36
end subroutine handle_gelsd_info
36
37
@@ -80,6 +81,26 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
80
81
#:for rk,rt,ri in RC_KINDS_TYPES
81
82
#:if rk!="xdp"
82
83
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
+
83
104
! Compute the least-squares solution to a real system of linear equations Ax = b
84
105
module function stdlib_linalg_${ri}$_lstsq_${ndsuf}$(a,b,cond,overwrite_a,rank,err) result(x)
85
106
!!### Summary
@@ -98,7 +119,7 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
98
119
!! param: err [optional] State return flag.
99
120
!! return: x Solution vector of size [n] or solution matrix of size [n,nrhs].
100
121
!!
101
- !> Input matrix a[n ,n]
122
+ !> Input matrix a[m ,n]
102
123
${rt}$, intent(inout), target :: a(:,:)
103
124
!> Right hand side vector or array, b[n] or b[n,nrhs]
104
125
${rt}$, intent(in) :: b${nd}$
@@ -122,8 +143,8 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
122
143
end function stdlib_linalg_${ri}$_lstsq_${ndsuf}$
123
144
124
145
! 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)
127
148
128
149
!!### Summary
129
150
!! Compute least-squares solution to a real system of linear equations \( Ax = b \)
@@ -134,12 +155,18 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
134
155
!!
135
156
!! param: a Input matrix of size [m,n].
136
157
!! 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
137
164
!! param: cond [optional] Real input threshold indicating that singular values `s_i <= cond*maxval(s)`
138
165
!! do not contribute to the matrix rank.
166
+ !! param: singvals [optional] Real array of size [min(m,n)] returning a list of singular values.
139
167
!! param: overwrite_a [optional] Flag indicating if the input matrix can be overwritten.
140
168
!! 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.
143
170
!!
144
171
!> Input matrix a[n,n]
145
172
${rt}$, intent(inout), target :: a(:,:)
@@ -157,6 +184,8 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
157
184
#:endif
158
185
!> [optional] cutoff for rank evaluation: singular values s(i)<=cond*maxval(s) are considered 0.
159
186
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(:)
160
189
!> [optional] Can A,b data be overwritten and destroyed?
161
190
logical(lk), optional, intent(in) :: overwrite_a
162
191
!> [optional] Return rank of A
@@ -167,12 +196,11 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
167
196
!! Local variables
168
197
type(linalg_state_type) :: err0
169
198
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
171
200
integer(ilp), pointer :: iwork(:)
172
201
logical(lk) :: copy_a
173
202
real(${rk}$) :: acond,rcond
174
- real(${rk}$), allocatable :: singular(:)
175
- real(${rk}$), pointer :: rwork(:)
203
+ real(${rk}$), pointer :: rwork(:),singular(:)
176
204
${rt}$, pointer :: xmat(:,:),amat(:,:),cwork(:)
177
205
178
206
! Problem sizes
@@ -213,8 +241,14 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
213
241
xmat(1:n,1:nrhs) => x
214
242
215
243
! 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
+
218
252
! rcond is used to determine the effective rank of A.
219
253
! Singular values S(i) <= RCOND*maxval(S) are treated as zero.
220
254
! Use same default value as NumPy
@@ -254,12 +288,14 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
254
288
ncs = size(iwork,kind=ilp)
255
289
#:endif
256
290
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
258
293
! Halt on insufficient space
259
294
err0 = linalg_state_type(this,LINALG_VALUE_ERROR,'insufficient working space: ',&
260
295
'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)
263
299
264
300
else
265
301
@@ -270,23 +306,24 @@ submodule (stdlib_linalg) stdlib_linalg_least_squares
270
306
#:else
271
307
rwork,nrs,iwork,info)
272
308
#: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)
273
315
274
316
endif
275
317
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
-
282
318
! Process output and return
283
- 1 if (copy_a) deallocate(amat)
319
+ if (copy_a) deallocate(amat)
284
320
if (present(rank)) rank = arank
285
321
if (.not.present(real_storage)) deallocate(rwork)
286
322
if (.not.present(int_storage)) deallocate(iwork)
287
323
#:if rt.startswith('complex')
288
324
if (.not.present(cmpl_storage)) deallocate(cwork)
289
325
#:endif
326
+ if (.not.present(singvals)) deallocate(singular)
290
327
call linalg_error_handling(err0,err)
291
328
292
329
end subroutine stdlib_linalg_${ri}$_solve_lstsq_${ndsuf}$
0 commit comments