Skip to content

Commit ad42828

Browse files
perazzperazz
authored
stdlib_*laset: array bound checks where hardcoded input address (#836)
2 parents c79c8b9 + bde2f3c commit ad42828

7 files changed

+177
-140
lines changed

Diff for: ‎src/stdlib_linalg_lapack_c.fypp

+28-28
Original file line numberDiff line numberDiff line change
@@ -65732,7 +65732,7 @@ module stdlib_linalg_lapack_c
6573265732
call stdlib_cgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, &
6573365733
ierr )
6573465734
! zero out below r
65735-
call stdlib_claset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda )
65735+
if (n>1) call stdlib_claset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda )
6573665736
ie = 1
6573765737
itauq = 1
6573865738
itaup = itauq + n
@@ -65918,7 +65918,7 @@ module stdlib_linalg_lapack_c
6591865918
call stdlib_cungqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork-nwork+&
6591965919
1, ierr )
6592065920
! produce r in a, zeroing out below it
65921-
call stdlib_claset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda )
65921+
if (n>1) call stdlib_claset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda )
6592265922
ie = 1
6592365923
itauq = itau
6592465924
itaup = itauq + n
@@ -66294,7 +66294,7 @@ module stdlib_linalg_lapack_c
6629466294
call stdlib_cgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, &
6629566295
ierr )
6629666296
! zero out above l
66297-
call stdlib_claset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda )
66297+
if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda )
6629866298
ie = 1
6629966299
itauq = 1
6630066300
itaup = itauq + m
@@ -66485,7 +66485,7 @@ module stdlib_linalg_lapack_c
6648566485
call stdlib_cunglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork-&
6648666486
nwork+1, ierr )
6648766487
! produce l in a, zeroing out above it
66488-
call stdlib_claset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda )
66488+
if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda )
6648966489
ie = 1
6649066490
itauq = itau
6649166491
itaup = itauq + m
@@ -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 )

0 commit comments

Comments
 (0)