Skip to content

Commit 4ba480e

Browse files
martin-frbgmartin-frbg
authored
Merge pull request #5851 from martin-frbg/lapack1272
Fix operand number in errors of ?GGSVD3,?UN/ORBDB4, ?UN/ORCSD (Reference-LAPACK PR 1272)
2 parents a36e22c + aae8526 commit 4ba480e

16 files changed

Lines changed: 209 additions & 144 deletions

File tree

‎lapack-netlib/SRC/cggsvd3.f‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -5,15 +5,13 @@
55
* Online html documentation available at
66
* http://www.netlib.org/lapack/explore-html/
77
*
8-
*> \htmlonly
98
*> Download CGGSVD3 + dependencies
109
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cggsvd3.f">
1110
*> [TGZ]</a>
1211
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cggsvd3.f">
1312
*> [ZIP]</a>
1413
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cggsvd3.f">
1514
*> [TXT]</a>
16-
*> \endhtmlonly
1715
*
1816
* Definition:
1917
* ===========
@@ -351,6 +349,7 @@
351349
SUBROUTINE CGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B,
352350
$ LDB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ,
353351
$ WORK, LWORK, RWORK, IWORK, INFO )
352+
IMPLICIT NONE
354353
*
355354
* -- LAPACK driver routine --
356355
* -- LAPACK is a software package provided by Univ. of Tennessee, --
@@ -422,13 +421,14 @@ SUBROUTINE CGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B,
422421
ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
423422
INFO = -20
424423
ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
425-
INFO = -24
424+
INFO = -22
426425
END IF
427426
*
428427
* Compute workspace
429428
*
430429
IF( INFO.EQ.0 ) THEN
431-
CALL CGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA,
430+
CALL CGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB,
431+
$ TOLA,
432432
$ TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, RWORK,
433433
$ WORK, WORK, -1, INFO )
434434
LWKOPT = N + INT( WORK( 1 ) )
@@ -455,8 +455,8 @@ SUBROUTINE CGGSVD3( JOBU, JOBV, JOBQ, M, N, P, K, L, A, LDA, B,
455455
*
456456
ULP = SLAMCH( 'Precision' )
457457
UNFL = SLAMCH( 'Safe Minimum' )
458-
TOLA = MAX( M, N )*MAX( ANORM, UNFL )*ULP
459-
TOLB = MAX( P, N )*MAX( BNORM, UNFL )*ULP
458+
TOLA = REAL( MAX( M, N ) )*MAX( ANORM, UNFL )*ULP
459+
TOLB = REAL( MAX( P, N ) )*MAX( BNORM, UNFL )*ULP
460460
*
461461
CALL CGGSVP3( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA,
462462
$ TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, RWORK,

‎lapack-netlib/SRC/claqz0.f‎

Lines changed: 25 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -5,15 +5,13 @@
55
* Online html documentation available at
66
* http://www.netlib.org/lapack/explore-html/
77
*
8-
*> \htmlonly
98
*> Download CLAQZ0 + dependencies
109
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/CLAQZ0.f">
1110
*> [TGZ]</a>
1211
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/CLAQZ0.f">
1312
*> [ZIP]</a>
1413
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/CLAQZ0.f">
1514
*> [TXT]</a>
16-
*> \endhtmlonly
1715
*
1816
* Definition:
1917
* ===========
@@ -274,10 +272,11 @@
274272
*
275273
*> \date May 2020
276274
*
277-
*> \ingroup complexGEcomputational
275+
*> \ingroup laqz0
278276
*>
279277
* =====================================================================
280-
RECURSIVE SUBROUTINE CLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
278+
RECURSIVE SUBROUTINE CLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI,
279+
$ A,
281280
$ LDA, B, LDB, ALPHA, BETA, Q, LDQ, Z,
282281
$ LDZ, WORK, LWORK, RWORK, REC,
283282
$ INFO )
@@ -412,12 +411,14 @@ RECURSIVE SUBROUTINE CLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
412411
NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
413412

414413
RCOST = ILAENV( 17, 'CLAQZ0', JBCMPZ, N, ILO, IHI, LWORK )
415-
ITEMP1 = INT( NSR/SQRT( 1+2*NSR/( REAL( RCOST )/100*N ) ) )
414+
ITEMP1 = INT( REAL( NSR )/SQRT( 1+2*REAL( NSR )/
415+
$ ( REAL( RCOST )/100*REAL( N ) ) ) )
416416
ITEMP1 = ( ( ITEMP1-1 )/4 )*4+4
417417
NBR = NSR+ITEMP1
418418

419419
IF( N .LT. NMIN .OR. REC .GE. 2 ) THEN
420-
CALL CHGEQZ( WANTS, WANTQ, WANTZ, N, ILO, IHI, A, LDA, B, LDB,
420+
CALL CHGEQZ( WANTS, WANTQ, WANTZ, N, ILO, IHI, A, LDA, B,
421+
$ LDB,
421422
$ ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK,
422423
$ INFO )
423424
RETURN
@@ -429,7 +430,8 @@ RECURSIVE SUBROUTINE CLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
429430

430431
* Workspace query to CLAQZ2
431432
NW = MAX( NWR, NMIN )
432-
CALL CLAQZ2( ILSCHUR, ILQ, ILZ, N, ILO, IHI, NW, A, LDA, B, LDB,
433+
CALL CLAQZ2( ILSCHUR, ILQ, ILZ, N, ILO, IHI, NW, A, LDA, B,
434+
$ LDB,
433435
$ Q, LDQ, Z, LDZ, N_UNDEFLATED, N_DEFLATED, ALPHA,
434436
$ BETA, WORK, NW, WORK, NW, WORK, -1, RWORK, REC,
435437
$ AED_INFO )
@@ -445,10 +447,10 @@ RECURSIVE SUBROUTINE CLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
445447
WORK( 1 ) = REAL( LWORKREQ )
446448
RETURN
447449
ELSE IF ( LWORK .LT. LWORKREQ ) THEN
448-
INFO = -19
450+
INFO = -18
449451
END IF
450452
IF( INFO.NE.0 ) THEN
451-
CALL XERBLA( 'CLAQZ0', INFO )
453+
CALL XERBLA( 'CLAQZ0', -INFO )
452454
RETURN
453455
END IF
454456
*
@@ -536,17 +538,20 @@ RECURSIVE SUBROUTINE CLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
536538
* to the top and deflate it
537539

538540
DO K2 = K, ISTART2+1, -1
539-
CALL CLARTG( B( K2-1, K2 ), B( K2-1, K2-1 ), C1, S1,
541+
CALL CLARTG( B( K2-1, K2 ), B( K2-1, K2-1 ), C1,
542+
$ S1,
540543
$ TEMP )
541544
B( K2-1, K2 ) = TEMP
542545
B( K2-1, K2-1 ) = CZERO
543546

544547
CALL CROT( K2-2-ISTARTM+1, B( ISTARTM, K2 ), 1,
545548
$ B( ISTARTM, K2-1 ), 1, C1, S1 )
546-
CALL CROT( MIN( K2+1, ISTOP )-ISTARTM+1, A( ISTARTM,
549+
CALL CROT( MIN( K2+1, ISTOP )-ISTARTM+1,
550+
$ A( ISTARTM,
547551
$ K2 ), 1, A( ISTARTM, K2-1 ), 1, C1, S1 )
548552
IF ( ILZ ) THEN
549-
CALL CROT( N, Z( 1, K2 ), 1, Z( 1, K2-1 ), 1, C1,
553+
CALL CROT( N, Z( 1, K2 ), 1, Z( 1, K2-1 ), 1,
554+
$ C1,
550555
$ S1 )
551556
END IF
552557

@@ -556,9 +561,11 @@ RECURSIVE SUBROUTINE CLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
556561
A( K2, K2-1 ) = TEMP
557562
A( K2+1, K2-1 ) = CZERO
558563

559-
CALL CROT( ISTOPM-K2+1, A( K2, K2 ), LDA, A( K2+1,
564+
CALL CROT( ISTOPM-K2+1, A( K2, K2 ), LDA,
565+
$ A( K2+1,
560566
$ K2 ), LDA, C1, S1 )
561-
CALL CROT( ISTOPM-K2+1, B( K2, K2 ), LDB, B( K2+1,
567+
CALL CROT( ISTOPM-K2+1, B( K2, K2 ), LDB,
568+
$ B( K2+1,
562569
$ K2 ), LDB, C1, S1 )
563570
IF( ILQ ) THEN
564571
CALL CROT( N, Q( 1, K2 ), 1, Q( 1, K2+1 ), 1,
@@ -620,7 +627,8 @@ RECURSIVE SUBROUTINE CLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
620627
*
621628
* Time for AED
622629
*
623-
CALL CLAQZ2( ILSCHUR, ILQ, ILZ, N, ISTART2, ISTOP, NW, A, LDA,
630+
CALL CLAQZ2( ILSCHUR, ILQ, ILZ, N, ISTART2, ISTOP, NW, A,
631+
$ LDA,
624632
$ B, LDB, Q, LDQ, Z, LDZ, N_UNDEFLATED, N_DEFLATED,
625633
$ ALPHA, BETA, WORK, NW, WORK( NW**2+1 ), NW,
626634
$ WORK( 2*NW**2+1 ), LWORK-2*NW**2, RWORK, REC,
@@ -663,7 +671,8 @@ RECURSIVE SUBROUTINE CLAQZ0( WANTS, WANTQ, WANTZ, N, ILO, IHI, A,
663671
*
664672
* Time for a QZ sweep
665673
*
666-
CALL CLAQZ3( ILSCHUR, ILQ, ILZ, N, ISTART2, ISTOP, NS, NBLOCK,
674+
CALL CLAQZ3( ILSCHUR, ILQ, ILZ, N, ISTART2, ISTOP, NS,
675+
$ NBLOCK,
667676
$ ALPHA( SHIFTPOS ), BETA( SHIFTPOS ), A, LDA, B,
668677
$ LDB, Q, LDQ, Z, LDZ, WORK, NBLOCK, WORK( NBLOCK**
669678
$ 2+1 ), NBLOCK, WORK( 2*NBLOCK**2+1 ),

‎lapack-netlib/SRC/claqz2.f‎

Lines changed: 25 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -5,15 +5,13 @@
55
* Online html documentation available at
66
* http://www.netlib.org/lapack/explore-html/
77
*
8-
*> \htmlonly
98
*> Download CLAQZ2 + dependencies
109
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/CLAQZ2.f">
1110
*> [TGZ]</a>
1211
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/CLAQZ2.f">
1312
*> [ZIP]</a>
1413
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/CLAQZ2.f">
1514
*> [TXT]</a>
16-
*> \endhtmlonly
1715
*
1816
* Definition:
1917
* ===========
@@ -209,6 +207,7 @@
209207
*> REC is INTEGER
210208
*> REC indicates the current recursion level. Should be set
211209
*> to 0 on first call.
210+
*> \endverbatim
212211
*>
213212
*> \param[out] INFO
214213
*> \verbatim
@@ -224,10 +223,11 @@
224223
*
225224
*> \date May 2020
226225
*
227-
*> \ingroup complexGEcomputational
226+
*> \ingroup laqz2
228227
*>
229228
* =====================================================================
230-
RECURSIVE SUBROUTINE CLAQZ2( ILSCHUR, ILQ, ILZ, N, ILO, IHI, NW,
229+
RECURSIVE SUBROUTINE CLAQZ2( ILSCHUR, ILQ, ILZ, N, ILO, IHI,
230+
$ NW,
231231
$ A, LDA, B, LDB, Q, LDQ, Z, LDZ, NS,
232232
$ ND, ALPHA, BETA, QC, LDQC, ZC, LDZC,
233233
$ WORK, LWORK, RWORK, REC, INFO )
@@ -257,7 +257,7 @@ RECURSIVE SUBROUTINE CLAQZ2( ILSCHUR, ILQ, ILZ, N, ILO, IHI, NW,
257257
COMPLEX :: S, S1, TEMP
258258

259259
* External Functions
260-
EXTERNAL :: XERBLA, CLAQZ0, CLAQZ1, SLABAD, CLACPY, CLASET, CGEMM,
260+
EXTERNAL :: XERBLA, CLAQZ0, CLAQZ1, CLACPY, CLASET, CGEMM,
261261
$ CTGEXC, CLARTG, CROT
262262
REAL, EXTERNAL :: SLAMCH
263263

@@ -282,10 +282,10 @@ RECURSIVE SUBROUTINE CLAQZ2( ILSCHUR, ILQ, ILZ, N, ILO, IHI, NW,
282282
LWORKREQ = MAX( LWORKREQ, N*NW, 2*NW**2+N )
283283
IF ( LWORK .EQ.-1 ) THEN
284284
* workspace query, quick return
285-
WORK( 1 ) = LWORKREQ
285+
WORK( 1 ) = CMPLX( LWORKREQ )
286286
RETURN
287287
ELSE IF ( LWORK .LT. LWORKREQ ) THEN
288-
INFO = -26
288+
INFO = -25
289289
END IF
290290

291291
IF( INFO.NE.0 ) THEN
@@ -296,7 +296,6 @@ RECURSIVE SUBROUTINE CLAQZ2( ILSCHUR, ILQ, ILZ, N, ILO, IHI, NW,
296296
* Get machine constants
297297
SAFMIN = SLAMCH( 'SAFE MINIMUM' )
298298
SAFMAX = ONE/SAFMIN
299-
CALL SLABAD( SAFMIN, SAFMAX )
300299
ULP = SLAMCH( 'PRECISION' )
301300
SMLNUM = SAFMIN*( REAL( N )/ULP )
302301

@@ -319,7 +318,8 @@ RECURSIVE SUBROUTINE CLAQZ2( ILSCHUR, ILQ, ILZ, N, ILO, IHI, NW,
319318

320319
* Store window in case of convergence failure
321320
CALL CLACPY( 'ALL', JW, JW, A( KWTOP, KWTOP ), LDA, WORK, JW )
322-
CALL CLACPY( 'ALL', JW, JW, B( KWTOP, KWTOP ), LDB, WORK( JW**2+
321+
CALL CLACPY( 'ALL', JW, JW, B( KWTOP, KWTOP ), LDB,
322+
$ WORK( JW**2+
323323
$ 1 ), JW )
324324

325325
* Transform window to real schur form
@@ -334,7 +334,8 @@ RECURSIVE SUBROUTINE CLAQZ2( ILSCHUR, ILQ, ILZ, N, ILO, IHI, NW,
334334
* Convergence failure, restore the window and exit
335335
ND = 0
336336
NS = JW-QZ_SMALL_INFO
337-
CALL CLACPY( 'ALL', JW, JW, WORK, JW, A( KWTOP, KWTOP ), LDA )
337+
CALL CLACPY( 'ALL', JW, JW, WORK, JW, A( KWTOP, KWTOP ),
338+
$ LDA )
338339
CALL CLACPY( 'ALL', JW, JW, WORK( JW**2+1 ), JW, B( KWTOP,
339340
$ KWTOP ), LDB )
340341
RETURN
@@ -391,11 +392,14 @@ RECURSIVE SUBROUTINE CLAQZ2( ILSCHUR, ILQ, ILZ, N, ILO, IHI, NW,
391392
A( K, KWTOP-1 ) = TEMP
392393
A( K+1, KWTOP-1 ) = CZERO
393394
K2 = MAX( KWTOP, K-1 )
394-
CALL CROT( IHI-K2+1, A( K, K2 ), LDA, A( K+1, K2 ), LDA, C1,
395+
CALL CROT( IHI-K2+1, A( K, K2 ), LDA, A( K+1, K2 ), LDA,
396+
$ C1,
395397
$ S1 )
396-
CALL CROT( IHI-( K-1 )+1, B( K, K-1 ), LDB, B( K+1, K-1 ),
398+
CALL CROT( IHI-( K-1 )+1, B( K, K-1 ), LDB, B( K+1,
399+
$ K-1 ),
397400
$ LDB, C1, S1 )
398-
CALL CROT( JW, QC( 1, K-KWTOP+1 ), 1, QC( 1, K+1-KWTOP+1 ),
401+
CALL CROT( JW, QC( 1, K-KWTOP+1 ), 1, QC( 1,
402+
$ K+1-KWTOP+1 ),
399403
$ 1, C1, CONJG( S1 ) )
400404
END DO
401405

@@ -437,25 +441,29 @@ RECURSIVE SUBROUTINE CLAQZ2( ILSCHUR, ILQ, ILZ, N, ILO, IHI, NW,
437441
$ IHI+1 ), LDB )
438442
END IF
439443
IF ( ILQ ) THEN
440-
CALL CGEMM( 'N', 'N', N, JW, JW, CONE, Q( 1, KWTOP ), LDQ, QC,
444+
CALL CGEMM( 'N', 'N', N, JW, JW, CONE, Q( 1, KWTOP ), LDQ,
445+
$ QC,
441446
$ LDQC, CZERO, WORK, N )
442447
CALL CLACPY( 'ALL', N, JW, WORK, N, Q( 1, KWTOP ), LDQ )
443448
END IF
444449

445450
IF ( KWTOP-1-ISTARTM+1 > 0 ) THEN
446-
CALL CGEMM( 'N', 'N', KWTOP-ISTARTM, JW, JW, CONE, A( ISTARTM,
451+
CALL CGEMM( 'N', 'N', KWTOP-ISTARTM, JW, JW, CONE,
452+
$ A( ISTARTM,
447453
$ KWTOP ), LDA, ZC, LDZC, CZERO, WORK,
448454
$ KWTOP-ISTARTM )
449455
CALL CLACPY( 'ALL', KWTOP-ISTARTM, JW, WORK, KWTOP-ISTARTM,
450456
$ A( ISTARTM, KWTOP ), LDA )
451-
CALL CGEMM( 'N', 'N', KWTOP-ISTARTM, JW, JW, CONE, B( ISTARTM,
457+
CALL CGEMM( 'N', 'N', KWTOP-ISTARTM, JW, JW, CONE,
458+
$ B( ISTARTM,
452459
$ KWTOP ), LDB, ZC, LDZC, CZERO, WORK,
453460
$ KWTOP-ISTARTM )
454461
CALL CLACPY( 'ALL', KWTOP-ISTARTM, JW, WORK, KWTOP-ISTARTM,
455462
$ B( ISTARTM, KWTOP ), LDB )
456463
END IF
457464
IF ( ILZ ) THEN
458-
CALL CGEMM( 'N', 'N', N, JW, JW, CONE, Z( 1, KWTOP ), LDZ, ZC,
465+
CALL CGEMM( 'N', 'N', N, JW, JW, CONE, Z( 1, KWTOP ), LDZ,
466+
$ ZC,
459467
$ LDZC, CZERO, WORK, N )
460468
CALL CLACPY( 'ALL', N, JW, WORK, N, Z( 1, KWTOP ), LDZ )
461469
END IF

‎lapack-netlib/SRC/cunbdb4.f‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -280,7 +280,7 @@ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
280280
LWORKMIN = LWORKOPT
281281
WORK(1) = SROUNDUP_LWORK(LWORKOPT)
282282
IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
283-
INFO = -14
283+
INFO = -15
284284
END IF
285285
END IF
286286
IF( INFO .NE. 0 ) THEN

0 commit comments

Comments
 (0)