Skip to content

Commit e832a10

Browse files
perazzperazz
committed
fix test
extend to all routines; add test add test extend checks to all routines where applicable Revert "fix test" This reverts commit de9a53d024aba03bbcb1741a674ccd578c8d9236. Reapply "fix test" This reverts commit ffe726d1bb9861eb15a7c46cc40d74de3cb9c0bb. Revert "Reapply "fix test"" This reverts commit 720ce1199e9bf965ad43834fd1df3af17e1ae57d. add checks everywhere applicable
1 parent 326bb27 commit e832a10

6 files changed

+116
-116
lines changed

‎src/stdlib_linalg_lapack_c.fypp

Lines changed: 24 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -68327,7 +68327,7 @@ module stdlib_linalg_lapack_c
6832768327
call stdlib_cgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, &
6832868328
ierr )
6832968329
! zero out above l
68330-
call stdlib_claset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda )
68330+
if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda )
6833168331
ie = 1
6833268332
itauq = 1
6833368333
itaup = itauq + m
@@ -68483,7 +68483,7 @@ module stdlib_linalg_lapack_c
6848368483
1, ierr )
6848468484
! copy l to u, zeroing about above it
6848568485
call stdlib_clacpy( 'L', m, m, a, lda, u, ldu )
68486-
call stdlib_claset( 'U', m-1, m-1, czero, czero, u( 1, 2 ),ldu )
68486+
if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero, u( 1, 2 ),ldu )
6848768487
! generate q in a
6848868488
! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb)
6848968489
! (rworkspace: 0)
@@ -68540,7 +68540,7 @@ module stdlib_linalg_lapack_c
6854068540
1, ierr )
6854168541
! copy l to u, zeroing out above it
6854268542
call stdlib_clacpy( 'L', m, m, a, lda, u, ldu )
68543-
call stdlib_claset( 'U', m-1, m-1, czero, czero, u( 1, 2 ),ldu )
68543+
if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero, u( 1, 2 ),ldu )
6854468544
! generate q in a
6854568545
! (cworkspace: need 2*m, prefer m+m*nb)
6854668546
! (rworkspace: 0)
@@ -68654,7 +68654,7 @@ module stdlib_linalg_lapack_c
6865468654
itaup = itauq + m
6865568655
iwork = itaup + m
6865668656
! zero out above l in a
68657-
call stdlib_claset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda )
68657+
if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda )
6865868658
! bidiagonalize l in a
6865968659
! (cworkspace: need 3*m, prefer 2*m+2*m*nb)
6866068660
! (rworkspace: need m)
@@ -68774,7 +68774,7 @@ module stdlib_linalg_lapack_c
6877468774
itaup = itauq + m
6877568775
iwork = itaup + m
6877668776
! zero out above l in a
68777-
call stdlib_claset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda )
68777+
if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda )
6877868778
! bidiagonalize l in a
6877968779
! (cworkspace: need 3*m, prefer 2*m+2*m*nb)
6878068780
! (rworkspace: need m)
@@ -68882,7 +68882,7 @@ module stdlib_linalg_lapack_c
6888268882
lwork-iwork+1, ierr )
6888368883
! copy l to u, zeroing out above it
6888468884
call stdlib_clacpy( 'L', m, m, a, lda, u, ldu )
68885-
call stdlib_claset( 'U', m-1, m-1, czero, czero,u( 1, 2 ), ldu )
68885+
if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero,u( 1, 2 ), ldu )
6888668886
ie = 1
6888768887
itauq = itau
6888868888
itaup = itauq + m
@@ -68995,7 +68995,7 @@ module stdlib_linalg_lapack_c
6899568995
itaup = itauq + m
6899668996
iwork = itaup + m
6899768997
! zero out above l in a
68998-
call stdlib_claset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda )
68998+
if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda )
6899968999
! bidiagonalize l in a
6900069000
! (cworkspace: need 3*m, prefer 2*m+2*m*nb)
6900169001
! (rworkspace: need m)
@@ -69117,7 +69117,7 @@ module stdlib_linalg_lapack_c
6911769117
itaup = itauq + m
6911869118
iwork = itaup + m
6911969119
! zero out above l in a
69120-
call stdlib_claset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda )
69120+
if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda )
6912169121
! bidiagonalize l in a
6912269122
! (cworkspace: need 3*m, prefer 2*m+2*m*nb)
6912369123
! (rworkspace: need m)
@@ -69228,7 +69228,7 @@ module stdlib_linalg_lapack_c
6922869228
lwork-iwork+1, ierr )
6922969229
! copy l to u, zeroing out above it
6923069230
call stdlib_clacpy( 'L', m, m, a, lda, u, ldu )
69231-
call stdlib_claset( 'U', m-1, m-1, czero, czero,u( 1, 2 ), ldu )
69231+
if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero,u( 1, 2 ), ldu )
6923269232
ie = 1
6923369233
itauq = itau
6923469234
itaup = itauq + m
@@ -70098,7 +70098,7 @@ module stdlib_linalg_lapack_c
7009870098
v(q,p) = conjg(u(p,nr+q))
7009970099
end do
7010070100
end do
70101-
call stdlib_claset('U',nr-1,nr-1,czero,czero,v(1,2),ldv)
70101+
if (nr>1) call stdlib_claset('U',nr-1,nr-1,czero,czero,v(1,2),ldv)
7010270102
call stdlib_cgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, cwork(n+nr+&
7010370103
1),lcwork-n-nr,rwork, info )
7010470104
call stdlib_claset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv)
@@ -75163,7 +75163,7 @@ module stdlib_linalg_lapack_c
7516375163
end do
7516475164
end do
7516575165
else
75166-
call stdlib_claset( 'U', nr-1,nr-1, czero,czero, a(1,2),lda )
75166+
if (nr>1) call stdlib_claset( 'U', nr-1,nr-1, czero,czero, a(1,2),lda )
7516775167
end if
7516875168
! Second Preconditioning Using The Qr Factorization
7516975169
call stdlib_cgeqrf( n,nr, a,lda, cwork, cwork(n+1),lwork-n, ierr )
@@ -75188,7 +75188,7 @@ module stdlib_linalg_lapack_c
7518875188
end do
7518975189
end do
7519075190
else
75191-
call stdlib_claset( 'U', nr-1, nr-1, czero, czero, a(1,2), lda )
75191+
if (nr>1) call stdlib_claset( 'U', nr-1, nr-1, czero, czero, a(1,2), lda )
7519275192
end if
7519375193
! .. and one-sided jacobi rotations are started on a lower
7519475194
! triangular matrix (plus perturbation which is ignored in
@@ -75206,25 +75206,25 @@ module stdlib_linalg_lapack_c
7520675206
call stdlib_ccopy( n-p+1, a(p,p), lda, v(p,p), 1 )
7520775207
call stdlib_clacgv( n-p+1, v(p,p), 1 )
7520875208
end do
75209-
call stdlib_claset( 'U', nr-1,nr-1, czero, czero, v(1,2), ldv )
75209+
if (nr>1) call stdlib_claset( 'U', nr-1,nr-1, czero, czero, v(1,2), ldv )
7521075210
call stdlib_cgesvj( 'L','U','N', n, nr, v, ldv, sva, nr, a, lda,cwork, lwork, &
7521175211
rwork, lrwork, info )
7521275212
scalem = rwork(1)
7521375213
numrank = nint(rwork(2),KIND=ilp)
7521475214
else
7521575215
! .. two more qr factorizations ( one qrf is not enough, two require
7521675216
! accumulated product of jacobi rotations, three are perfect )
75217-
call stdlib_claset( 'L', nr-1,nr-1, czero, czero, a(2,1), lda )
75217+
if (nr>1) call stdlib_claset( 'L', nr-1,nr-1, czero, czero, a(2,1), lda )
7521875218
call stdlib_cgelqf( nr,n, a, lda, cwork, cwork(n+1), lwork-n, ierr)
7521975219
call stdlib_clacpy( 'L', nr, nr, a, lda, v, ldv )
75220-
call stdlib_claset( 'U', nr-1,nr-1, czero, czero, v(1,2), ldv )
75220+
if (nr>1) call stdlib_claset( 'U', nr-1,nr-1, czero, czero, v(1,2), ldv )
7522175221
call stdlib_cgeqrf( nr, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr )
7522275222

7522375223
do p = 1, nr
7522475224
call stdlib_ccopy( nr-p+1, v(p,p), ldv, v(p,p), 1 )
7522575225
call stdlib_clacgv( nr-p+1, v(p,p), 1 )
7522675226
end do
75227-
call stdlib_claset('U', nr-1, nr-1, czero, czero, v(1,2), ldv)
75227+
if (nr>1) call stdlib_claset('U', nr-1, nr-1, czero, czero, v(1,2), ldv)
7522875228
call stdlib_cgesvj( 'L', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, cwork(n+1), &
7522975229
lwork-n, rwork, lrwork, info )
7523075230
scalem = rwork(1)
@@ -75247,7 +75247,7 @@ module stdlib_linalg_lapack_c
7524775247
call stdlib_clacpy( 'A', n, n, v, ldv, u, ldu )
7524875248
end if
7524975249
else if ( jracc .and. (.not. lsvec) .and. ( nr== n ) ) then
75250-
call stdlib_claset( 'L', n-1,n-1, czero, czero, a(2,1), lda )
75250+
if (n>1) call stdlib_claset( 'L', n-1,n-1, czero, czero, a(2,1), lda )
7525175251
call stdlib_cgesvj( 'U','N','V', n, n, a, lda, sva, n, v, ldv,cwork, lwork, rwork, &
7525275252
lrwork, info )
7525375253
scalem = rwork(1)
@@ -75261,14 +75261,14 @@ module stdlib_linalg_lapack_c
7526175261
call stdlib_ccopy( n-p+1, a(p,p), lda, u(p,p), 1 )
7526275262
call stdlib_clacgv( n-p+1, u(p,p), 1 )
7526375263
end do
75264-
call stdlib_claset( 'U', nr-1, nr-1, czero, czero, u(1,2), ldu )
75264+
if (nr>1) call stdlib_claset( 'U', nr-1, nr-1, czero, czero, u(1,2), ldu )
7526575265
call stdlib_cgeqrf( n, nr, u, ldu, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr )
7526675266

7526775267
do p = 1, nr - 1
7526875268
call stdlib_ccopy( nr-p, u(p,p+1), ldu, u(p+1,p), 1 )
7526975269
call stdlib_clacgv( n-p+1, u(p,p), 1 )
7527075270
end do
75271-
call stdlib_claset( 'U', nr-1, nr-1, czero, czero, u(1,2), ldu )
75271+
if (nr>1) call stdlib_claset( 'U', nr-1, nr-1, czero, czero, u(1,2), ldu )
7527275272
call stdlib_cgesvj( 'L', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, cwork(n+1), lwork-&
7527375273
n, rwork, lrwork, info )
7527475274
scalem = rwork(1)
@@ -75327,7 +75327,7 @@ module stdlib_linalg_lapack_c
7532775327
end do
7532875328
end do
7532975329
else
75330-
call stdlib_claset( 'U', nr-1, nr-1, czero, czero, v(1,2), ldv )
75330+
if (nr>1) call stdlib_claset( 'U', nr-1, nr-1, czero, czero, v(1,2), ldv )
7533175331
end if
7533275332
! estimate the row scaled condition number of r1
7533375333
! (if r1 is rectangular, n > nr, then the condition number
@@ -75409,7 +75409,7 @@ module stdlib_linalg_lapack_c
7540975409
end do
7541075410
end do
7541175411
else
75412-
call stdlib_claset( 'L',nr-1,nr-1,czero,czero,v(2,1),ldv )
75412+
if (nr>1) call stdlib_claset( 'L',nr-1,nr-1,czero,czero,v(2,1),ldv )
7541375413
end if
7541475414
! now, compute r2 = l3 * q3, the lq factorization.
7541575415
call stdlib_cgelqf( nr, nr, v, ldv, cwork(2*n+n*nr+1),cwork(2*n+n*nr+nr+1), &
@@ -75443,7 +75443,7 @@ module stdlib_linalg_lapack_c
7544375443
end do
7544475444
end do
7544575445
else
75446-
call stdlib_claset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv )
75446+
if (nr>1) call stdlib_claset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv )
7544775447
end if
7544875448
! second preconditioning finished; continue with jacobi svd
7544975449
! the input matrix is lower trinagular.
@@ -75662,7 +75662,7 @@ module stdlib_linalg_lapack_c
7566275662
end do
7566375663
end do
7566475664
else
75665-
call stdlib_claset( 'U', nr-1, nr-1, czero, czero, v(1,2), ldv )
75665+
if (nr>1) call stdlib_claset( 'U', nr-1, nr-1, czero, czero, v(1,2), ldv )
7566675666
end if
7566775667
call stdlib_cgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr )
7566875668

@@ -75681,7 +75681,7 @@ module stdlib_linalg_lapack_c
7568175681
end do
7568275682
end do
7568375683
else
75684-
call stdlib_claset('U', nr-1, nr-1, czero, czero, u(1,2), ldu )
75684+
if (nr>1) call stdlib_claset('U', nr-1, nr-1, czero, czero, u(1,2), ldu )
7568575685
end if
7568675686
call stdlib_cgesvj( 'L', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, cwork(2*n+n*nr+1),&
7568775687
lwork-2*n-n*nr,rwork, lrwork, info )

‎src/stdlib_linalg_lapack_d.fypp

Lines changed: 10 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -77363,7 +77363,7 @@ module stdlib_linalg_lapack_d
7736377363
call stdlib_dgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, &
7736477364
ierr )
7736577365
! zero out above l
77366-
call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda )
77366+
if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda )
7736777367
ie = 1
7736877368
itauq = ie + m
7736977369
itaup = itauq + m
@@ -77506,7 +77506,7 @@ module stdlib_linalg_lapack_d
7750677506
1, ierr )
7750777507
! copy l to u, zeroing about above it
7750877508
call stdlib_dlacpy( 'L', m, m, a, lda, u, ldu )
77509-
call stdlib_dlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu )
77509+
if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu )
7751077510
! generate q in a
7751177511
! (workspace: need m*m + 2*m, prefer m*m + m + m*nb)
7751277512
call stdlib_dorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-&
@@ -77556,7 +77556,7 @@ module stdlib_linalg_lapack_d
7755677556
1, ierr )
7755777557
! copy l to u, zeroing out above it
7755877558
call stdlib_dlacpy( 'L', m, m, a, lda, u, ldu )
77559-
call stdlib_dlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu )
77559+
if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu )
7756077560
! generate q in a
7756177561
! (workspace: need 2*m, prefer m + m*nb)
7756277562
call stdlib_dorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-&
@@ -77657,7 +77657,7 @@ module stdlib_linalg_lapack_d
7765777657
itaup = itauq + m
7765877658
iwork = itaup + m
7765977659
! zero out above l in a
77660-
call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda )
77660+
if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda )
7766177661
! bidiagonalize l in a
7766277662
! (workspace: need 4*m, prefer 3*m + 2*m*nb)
7766377663
call stdlib_dgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( &
@@ -77764,7 +77764,7 @@ module stdlib_linalg_lapack_d
7776477764
itaup = itauq + m
7776577765
iwork = itaup + m
7776677766
! zero out above l in a
77767-
call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda )
77767+
if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda )
7776877768
! bidiagonalize l in a
7776977769
! (workspace: need 4*m, prefer 3*m + 2*m*nb)
7777077770
call stdlib_dgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( &
@@ -77859,7 +77859,7 @@ module stdlib_linalg_lapack_d
7785977859
lwork-iwork+1, ierr )
7786077860
! copy l to u, zeroing out above it
7786177861
call stdlib_dlacpy( 'L', m, m, a, lda, u, ldu )
77862-
call stdlib_dlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu )
77862+
if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu )
7786377863
ie = itau
7786477864
itauq = ie + m
7786577865
itaup = itauq + m
@@ -77960,7 +77960,7 @@ module stdlib_linalg_lapack_d
7796077960
itaup = itauq + m
7796177961
iwork = itaup + m
7796277962
! zero out above l in a
77963-
call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda )
77963+
if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda )
7796477964
! bidiagonalize l in a
7796577965
! (workspace: need 4*m, prefer 3*m + 2*m*nb)
7796677966
call stdlib_dgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( &
@@ -78070,7 +78070,7 @@ module stdlib_linalg_lapack_d
7807078070
itaup = itauq + m
7807178071
iwork = itaup + m
7807278072
! zero out above l in a
78073-
call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda )
78073+
if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda )
7807478074
! bidiagonalize l in a
7807578075
! (workspace: need 4*m, prefer 3*m + 2*m*nb)
7807678076
call stdlib_dgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( &
@@ -78168,7 +78168,7 @@ module stdlib_linalg_lapack_d
7816878168
lwork-iwork+1, ierr )
7816978169
! copy l to u, zeroing out above it
7817078170
call stdlib_dlacpy( 'L', m, m, a, lda, u, ldu )
78171-
call stdlib_dlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu )
78171+
if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu )
7817278172
ie = itau
7817378173
itauq = ie + m
7817478174
itaup = itauq + m
@@ -79029,7 +79029,7 @@ module stdlib_linalg_lapack_d
7902979029
v(q,p) = u(p,nr+q)
7903079030
end do
7903179031
end do
79032-
call stdlib_dlaset('U',nr-1,nr-1,zero,zero,v(1,2),ldv)
79032+
if (nr>1) call stdlib_dlaset('U',nr-1,nr-1,zero,zero,v(1,2),ldv)
7903379033
call stdlib_dgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, work(n+nr+1)&
7903479034
,lwork-n-nr, info )
7903579035
call stdlib_dlaset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv)

0 commit comments

Comments
 (0)