OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
schksy_rook.f
Go to the documentation of this file.
1*> \brief \b SCHKSY_ROOK
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8* Definition:
9* ===========
10*
11* SUBROUTINE SCHKSY_ROOK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
12* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
13* XACT, WORK, RWORK, IWORK, NOUT )
14*
15* .. Scalar Arguments ..
16* LOGICAL TSTERR
17* INTEGER NMAX, NN, NNB, NNS, NOUT
18* REAL THRESH
19* ..
20* .. Array Arguments ..
21* LOGICAL DOTYPE( * )
22* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
23* REAL A( * ), AFAC( * ), AINV( * ), B( * ),
24* $ RWORK( * ), WORK( * ), X( * ), XACT( * )
25* ..
26*
27*
28*> \par Purpose:
29* =============
30*>
31*> \verbatim
32*>
33*> SCHKSY_ROOK tests SSYTRF_ROOK, -TRI_ROOK, -TRS_ROOK,
34*> and -CON_ROOK.
35*> \endverbatim
36*
37* Arguments:
38* ==========
39*
40*> \param[in] DOTYPE
41*> \verbatim
42*> DOTYPE is LOGICAL array, dimension (NTYPES)
43*> The matrix types to be used for testing. Matrices of type j
44*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
45*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
46*> \endverbatim
47*>
48*> \param[in] NN
49*> \verbatim
50*> NN is INTEGER
51*> The number of values of N contained in the vector NVAL.
52*> \endverbatim
53*>
54*> \param[in] NVAL
55*> \verbatim
56*> NVAL is INTEGER array, dimension (NN)
57*> The values of the matrix dimension N.
58*> \endverbatim
59*>
60*> \param[in] NNB
61*> \verbatim
62*> NNB is INTEGER
63*> The number of values of NB contained in the vector NBVAL.
64*> \endverbatim
65*>
66*> \param[in] NBVAL
67*> \verbatim
68*> NBVAL is INTEGER array, dimension (NNB)
69*> The values of the blocksize NB.
70*> \endverbatim
71*>
72*> \param[in] NNS
73*> \verbatim
74*> NNS is INTEGER
75*> The number of values of NRHS contained in the vector NSVAL.
76*> \endverbatim
77*>
78*> \param[in] NSVAL
79*> \verbatim
80*> NSVAL is INTEGER array, dimension (NNS)
81*> The values of the number of right hand sides NRHS.
82*> \endverbatim
83*>
84*> \param[in] THRESH
85*> \verbatim
86*> THRESH is REAL
87*> The threshold value for the test ratios. A result is
88*> included in the output file if RESULT >= THRESH. To have
89*> every test ratio printed, use THRESH = 0.
90*> \endverbatim
91*>
92*> \param[in] TSTERR
93*> \verbatim
94*> TSTERR is LOGICAL
95*> Flag that indicates whether error exits are to be tested.
96*> \endverbatim
97*>
98*> \param[in] NMAX
99*> \verbatim
100*> NMAX is INTEGER
101*> The maximum value permitted for N, used in dimensioning the
102*> work arrays.
103*> \endverbatim
104*>
105*> \param[out] A
106*> \verbatim
107*> A is REAL array, dimension (NMAX*NMAX)
108*> \endverbatim
109*>
110*> \param[out] AFAC
111*> \verbatim
112*> AFAC is REAL array, dimension (NMAX*NMAX)
113*> \endverbatim
114*>
115*> \param[out] AINV
116*> \verbatim
117*> AINV is REAL array, dimension (NMAX*NMAX)
118*> \endverbatim
119*>
120*> \param[out] B
121*> \verbatim
122*> B is REAL array, dimension (NMAX*NSMAX)
123*> where NSMAX is the largest entry in NSVAL.
124*> \endverbatim
125*>
126*> \param[out] X
127*> \verbatim
128*> X is REAL array, dimension (NMAX*NSMAX)
129*> \endverbatim
130*>
131*> \param[out] XACT
132*> \verbatim
133*> XACT is REAL array, dimension (NMAX*NSMAX)
134*> \endverbatim
135*>
136*> \param[out] WORK
137*> \verbatim
138*> WORK is REAL array, dimension (NMAX*max(3,NSMAX))
139*> \endverbatim
140*>
141*> \param[out] RWORK
142*> \verbatim
143*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX))
144*> \endverbatim
145*>
146*> \param[out] IWORK
147*> \verbatim
148*> IWORK is INTEGER array, dimension (2*NMAX)
149*> \endverbatim
150*>
151*> \param[in] NOUT
152*> \verbatim
153*> NOUT is INTEGER
154*> The unit number for output.
155*> \endverbatim
156*
157* Authors:
158* ========
159*
160*> \author Univ. of Tennessee
161*> \author Univ. of California Berkeley
162*> \author Univ. of Colorado Denver
163*> \author NAG Ltd.
164*
165*> \ingroup single_lin
166*
167* =====================================================================
168 SUBROUTINE schksy_rook( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL,
169 $ THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X,
170 $ XACT, WORK, RWORK, IWORK, NOUT )
171*
172* -- LAPACK test routine --
173* -- LAPACK is a software package provided by Univ. of Tennessee, --
174* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
175*
176* .. Scalar Arguments ..
177 LOGICAL TSTERR
178 INTEGER NMAX, NN, NNB, NNS, NOUT
179 REAL THRESH
180* ..
181* .. Array Arguments ..
182 LOGICAL DOTYPE( * )
183 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
184 REAL A( * ), AFAC( * ), AINV( * ), B( * ),
185 $ rwork( * ), work( * ), x( * ), xact( * )
186* ..
187*
188* =====================================================================
189*
190* .. Parameters ..
191 REAL ZERO, ONE
192 PARAMETER ( ZERO = 0.0d+0, one = 1.0d+0 )
193 REAL EIGHT, SEVTEN
194 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
195 INTEGER NTYPES
196 parameter( ntypes = 10 )
197 INTEGER NTESTS
198 parameter( ntests = 7 )
199* ..
200* .. Local Scalars ..
201 LOGICAL TRFCON, ZEROT
202 CHARACTER DIST, TYPE, UPLO, XTYPE
203 CHARACTER*3 PATH, MATPATH
204 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
205 $ iuplo, izero, j, k, kl, ku, lda, lwork, mode,
206 $ n, nb, nerrs, nfail, nimat, nrhs, nrun, nt
207 REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
208 $ SING_MIN, RCOND, RCONDC, STEMP
209* ..
210* .. Local Arrays ..
211 CHARACTER UPLOS( 2 )
212 INTEGER ISEED( 4 ), ISEEDY( 4 )
213 REAL BLOCK( 2, 2 ), RESULT( NTESTS ), SDUMMY( 1 )
214* ..
215* .. External Functions ..
216 REAL SGET06, SLANGE, SLANSY
217 EXTERNAL SGET06, SLANGE, SLANSY
218* ..
219* .. External Subroutines ..
220 EXTERNAL alaerh, alahd, alasum, serrsy, sget04, slacpy,
221 $ slarhs, slatb4, slatms, spot02, spot03, sgesvd,
222 $ ssycon_rook, ssyt01_rook, ssytrf_rook,
223 $ ssytri_rook, ssytrs_rook, xlaenv
224* ..
225* .. Intrinsic Functions ..
226 INTRINSIC max, min, sqrt
227* ..
228* .. Scalars in Common ..
229 LOGICAL LERR, OK
230 CHARACTER*32 SRNAMT
231 INTEGER INFOT, NUNIT
232* ..
233* .. Common blocks ..
234 COMMON / infoc / infot, nunit, ok, lerr
235 COMMON / srnamc / srnamt
236* ..
237* .. Data statements ..
238 DATA iseedy / 1988, 1989, 1990, 1991 /
239 DATA uplos / 'U', 'L' /
240* ..
241* .. Executable Statements ..
242*
243* Initialize constants and the random number seed.
244*
245 alpha = ( one+sqrt( sevten ) ) / eight
246*
247* Test path
248*
249 path( 1: 1 ) = 'Single precision'
250 path( 2: 3 ) = 'SR'
251*
252* Path to generate matrices
253*
254 matpath( 1: 1 ) = 'Single precision'
255 matpath( 2: 3 ) = 'SY'
256*
257 nrun = 0
258 nfail = 0
259 nerrs = 0
260 DO 10 i = 1, 4
261 iseed( i ) = iseedy( i )
262 10 CONTINUE
263*
264* Test the error exits
265*
266 IF( tsterr )
267 $ CALL serrsy( path, nout )
268 infot = 0
269*
270* Set the minimum block size for which the block routine should
271* be used, which will be later returned by ILAENV
272*
273 CALL xlaenv( 2, 2 )
274*
275* Do for each value of N in NVAL
276*
277 DO 270 in = 1, nn
278 n = nval( in )
279 lda = max( n, 1 )
280 xtype = 'N'
281 nimat = ntypes
282 IF( n.LE.0 )
283 $ nimat = 1
284*
285 izero = 0
286*
287* Do for each value of matrix type IMAT
288*
289 DO 260 imat = 1, nimat
290*
291* Do the tests only if DOTYPE( IMAT ) is true.
292*
293 IF( .NOT.dotype( imat ) )
294 $ GO TO 260
295*
296* Skip types 3, 4, 5, or 6 if the matrix size is too small.
297*
298 zerot = imat.GE.3 .AND. imat.LE.6
299 IF( zerot .AND. n.LT.imat-2 )
300 $ GO TO 260
301*
302* Do first for UPLO = 'U', then for UPLO = 'L'
303*
304 DO 250 iuplo = 1, 2
305 uplo = uplos( iuplo )
306*
307* Begin generate the test matrix A.
308*
309* Set up parameters with SLATB4 for the matrix generator
310* based on the type of matrix to be generated.
311*
312 CALL slatb4( matpath, imat, n, n, TYPE, kl, ku, anorm,
313 $ MODE, cndnum, dist )
314*
315* Generate a matrix with SLATMS.
316*
317 srnamt = 'SLATMS'
318 CALL slatms( n, n, dist, iseed, TYPE, rwork, mode,
319 $ cndnum, anorm, kl, ku, uplo, a, lda, work,
320 $ info )
321*
322* Check error code from SLATMS and handle error.
323*
324 IF( info.NE.0 ) THEN
325 CALL alaerh( path, 'SLATMS', info, 0, uplo, n, n, -1,
326 $ -1, -1, imat, nfail, nerrs, nout )
327*
328* Skip all tests for this generated matrix
329*
330 GO TO 250
331 END IF
332*
333* For matrix types 3-6, zero one or more rows and
334* columns of the matrix to test that INFO is returned
335* correctly.
336*
337 IF( zerot ) THEN
338 IF( imat.EQ.3 ) THEN
339 izero = 1
340 ELSE IF( imat.EQ.4 ) THEN
341 izero = n
342 ELSE
343 izero = n / 2 + 1
344 END IF
345*
346 IF( imat.LT.6 ) THEN
347*
348* Set row and column IZERO to zero.
349*
350 IF( iuplo.EQ.1 ) THEN
351 ioff = ( izero-1 )*lda
352 DO 20 i = 1, izero - 1
353 a( ioff+i ) = zero
354 20 CONTINUE
355 ioff = ioff + izero
356 DO 30 i = izero, n
357 a( ioff ) = zero
358 ioff = ioff + lda
359 30 CONTINUE
360 ELSE
361 ioff = izero
362 DO 40 i = 1, izero - 1
363 a( ioff ) = zero
364 ioff = ioff + lda
365 40 CONTINUE
366 ioff = ioff - izero
367 DO 50 i = izero, n
368 a( ioff+i ) = zero
369 50 CONTINUE
370 END IF
371 ELSE
372 IF( iuplo.EQ.1 ) THEN
373*
374* Set the first IZERO rows and columns to zero.
375*
376 ioff = 0
377 DO 70 j = 1, n
378 i2 = min( j, izero )
379 DO 60 i = 1, i2
380 a( ioff+i ) = zero
381 60 CONTINUE
382 ioff = ioff + lda
383 70 CONTINUE
384 ELSE
385*
386* Set the last IZERO rows and columns to zero.
387*
388 ioff = 0
389 DO 90 j = 1, n
390 i1 = max( j, izero )
391 DO 80 i = i1, n
392 a( ioff+i ) = zero
393 80 CONTINUE
394 ioff = ioff + lda
395 90 CONTINUE
396 END IF
397 END IF
398 ELSE
399 izero = 0
400 END IF
401*
402* End generate the test matrix A.
403*
404*
405* Do for each value of NB in NBVAL
406*
407 DO 240 inb = 1, nnb
408*
409* Set the optimal blocksize, which will be later
410* returned by ILAENV.
411*
412 nb = nbval( inb )
413 CALL xlaenv( 1, nb )
414*
415* Copy the test matrix A into matrix AFAC which
416* will be factorized in place. This is needed to
417* preserve the test matrix A for subsequent tests.
418*
419 CALL slacpy( uplo, n, n, a, lda, afac, lda )
420*
421* Compute the L*D*L**T or U*D*U**T factorization of the
422* matrix. IWORK stores details of the interchanges and
423* the block structure of D. AINV is a work array for
424* block factorization, LWORK is the length of AINV.
425*
426 lwork = max( 2, nb )*lda
427 srnamt = 'SSYTRF_ROOK'
428 CALL ssytrf_rook( uplo, n, afac, lda, iwork, ainv,
429 $ lwork, info )
430*
431* Adjust the expected value of INFO to account for
432* pivoting.
433*
434 k = izero
435 IF( k.GT.0 ) THEN
436 100 CONTINUE
437 IF( iwork( k ).LT.0 ) THEN
438 IF( iwork( k ).NE.-k ) THEN
439 k = -iwork( k )
440 GO TO 100
441 END IF
442 ELSE IF( iwork( k ).NE.k ) THEN
443 k = iwork( k )
444 GO TO 100
445 END IF
446 END IF
447*
448* Check error code from SSYTRF_ROOK and handle error.
449*
450 IF( info.NE.k)
451 $ CALL alaerh( path, 'SSYTRF_ROOK', info, k,
452 $ uplo, n, n, -1, -1, nb, imat,
453 $ nfail, nerrs, nout )
454*
455* Set the condition estimate flag if the INFO is not 0.
456*
457 IF( info.NE.0 ) THEN
458 trfcon = .true.
459 ELSE
460 trfcon = .false.
461 END IF
462*
463*+ TEST 1
464* Reconstruct matrix from factors and compute residual.
465*
466 CALL ssyt01_rook( uplo, n, a, lda, afac, lda, iwork,
467 $ ainv, lda, rwork, result( 1 ) )
468 nt = 1
469*
470*+ TEST 2
471* Form the inverse and compute the residual,
472* if the factorization was competed without INFO > 0
473* (i.e. there is no zero rows and columns).
474* Do it only for the first block size.
475*
476 IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
477 CALL slacpy( uplo, n, n, afac, lda, ainv, lda )
478 srnamt = 'SSYTRI_ROOK'
479 CALL ssytri_rook( uplo, n, ainv, lda, iwork, work,
480 $ info )
481*
482* Check error code from SSYTRI_ROOK and handle error.
483*
484 IF( info.NE.0 )
485 $ CALL alaerh( path, 'ssytri_rook', INFO, -1,
486 $ UPLO, N, N, -1, -1, -1, IMAT,
487 $ NFAIL, NERRS, NOUT )
488*
489* Compute the residual for a symmetric matrix times
490* its inverse.
491*
492 CALL SPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA,
493 $ RWORK, RCONDC, RESULT( 2 ) )
494 NT = 2
495 END IF
496*
497* Print information about the tests that did not pass
498* the threshold.
499*
500 DO 110 K = 1, NT
501.GE. IF( RESULT( K )THRESH ) THEN
502.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
503 $ CALL ALAHD( NOUT, PATH )
504 WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
505 $ RESULT( K )
506 NFAIL = NFAIL + 1
507 END IF
508 110 CONTINUE
509 NRUN = NRUN + NT
510*
511*+ TEST 3
512* Compute largest element in U or L
513*
514 RESULT( 3 ) = ZERO
515 STEMP = ZERO
516*
517 CONST = ONE / ( ONE-ALPHA )
518*
519.EQ. IF( IUPLO1 ) THEN
520*
521* Compute largest element in U
522*
523 K = N
524 120 CONTINUE
525.LE. IF( K1 )
526 $ GO TO 130
527*
528.GT. IF( IWORK( K )ZERO ) THEN
529*
530* Get max absolute value from elements
531* in column k in in U
532*
533 STEMP = SLANGE( 'm', K-1, 1,
534 $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK )
535 ELSE
536*
537* Get max absolute value from elements
538* in columns k and k-1 in U
539*
540 STEMP = SLANGE( 'm', K-2, 2,
541 $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK )
542 K = K - 1
543*
544 END IF
545*
546* STEMP should be bounded by CONST
547*
548 STEMP = STEMP - CONST + THRESH
549.GT. IF( STEMPRESULT( 3 ) )
550 $ RESULT( 3 ) = STEMP
551*
552 K = K - 1
553*
554 GO TO 120
555 130 CONTINUE
556*
557 ELSE
558*
559* Compute largest element in L
560*
561 K = 1
562 140 CONTINUE
563.GE. IF( KN )
564 $ GO TO 150
565*
566.GT. IF( IWORK( K )ZERO ) THEN
567*
568* Get max absolute value from elements
569* in column k in in L
570*
571 STEMP = SLANGE( 'm', N-K, 1,
572 $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK )
573 ELSE
574*
575* Get max absolute value from elements
576* in columns k and k+1 in L
577*
578 STEMP = SLANGE( 'm', N-K-1, 2,
579 $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK )
580 K = K + 1
581*
582 END IF
583*
584* STEMP should be bounded by CONST
585*
586 STEMP = STEMP - CONST + THRESH
587.GT. IF( STEMPRESULT( 3 ) )
588 $ RESULT( 3 ) = STEMP
589*
590 K = K + 1
591*
592 GO TO 140
593 150 CONTINUE
594 END IF
595*
596*
597*+ TEST 4
598* Compute largest 2-Norm (condition number)
599* of 2-by-2 diag blocks
600*
601 RESULT( 4 ) = ZERO
602 STEMP = ZERO
603*
604 CONST = ( ONE+ALPHA ) / ( ONE-ALPHA )
605 CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
606*
607.EQ. IF( IUPLO1 ) THEN
608*
609* Loop backward for UPLO = 'U'
610*
611 K = N
612 160 CONTINUE
613.LE. IF( K1 )
614 $ GO TO 170
615*
616.LT. IF( IWORK( K )ZERO ) THEN
617*
618* Get the two singular values
619* (real and non-negative) of a 2-by-2 block,
620* store them in RWORK array
621*
622 BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 )
623 BLOCK( 1, 2 ) = AFAC( (K-1)*LDA+K-1 )
624 BLOCK( 2, 1 ) = BLOCK( 1, 2 )
625 BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K )
626*
627 CALL SGESVD( 'n', 'n', 2, 2, BLOCK, 2, RWORK,
628 $ SDUMMY, 1, SDUMMY, 1,
629 $ WORK, 10, INFO )
630*
631*
632 SING_MAX = RWORK( 1 )
633 SING_MIN = RWORK( 2 )
634*
635 STEMP = SING_MAX / SING_MIN
636*
637* STEMP should be bounded by CONST
638*
639 STEMP = STEMP - CONST + THRESH
640.GT. IF( STEMPRESULT( 4 ) )
641 $ RESULT( 4 ) = STEMP
642 K = K - 1
643*
644 END IF
645*
646 K = K - 1
647*
648 GO TO 160
649 170 CONTINUE
650*
651 ELSE
652*
653* Loop forward for UPLO = 'L'
654*
655 K = 1
656 180 CONTINUE
657.GE. IF( KN )
658 $ GO TO 190
659*
660.LT. IF( IWORK( K )ZERO ) THEN
661*
662* Get the two singular values
663* (real and non-negative) of a 2-by-2 block,
664* store them in RWORK array
665*
666 BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K )
667 BLOCK( 2, 1 ) = AFAC( ( K-1 )*LDA+K+1 )
668 BLOCK( 1, 2 ) = BLOCK( 2, 1 )
669 BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 )
670*
671 CALL SGESVD( 'n', 'n', 2, 2, BLOCK, 2, RWORK,
672 $ SDUMMY, 1, SDUMMY, 1,
673 $ WORK, 10, INFO )
674*
675*
676 SING_MAX = RWORK( 1 )
677 SING_MIN = RWORK( 2 )
678*
679 STEMP = SING_MAX / SING_MIN
680*
681* STEMP should be bounded by CONST
682*
683 STEMP = STEMP - CONST + THRESH
684.GT. IF( STEMPRESULT( 4 ) )
685 $ RESULT( 4 ) = STEMP
686 K = K + 1
687*
688 END IF
689*
690 K = K + 1
691*
692 GO TO 180
693 190 CONTINUE
694 END IF
695*
696* Print information about the tests that did not pass
697* the threshold.
698*
699 DO 200 K = 3, 4
700.GE. IF( RESULT( K )THRESH ) THEN
701.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
702 $ CALL ALAHD( NOUT, PATH )
703 WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K,
704 $ RESULT( K )
705 NFAIL = NFAIL + 1
706 END IF
707 200 CONTINUE
708 NRUN = NRUN + 2
709*
710* Skip the other tests if this is not the first block
711* size.
712*
713.GT. IF( INB1 )
714 $ GO TO 240
715*
716* Do only the condition estimate if INFO is not 0.
717*
718 IF( TRFCON ) THEN
719 RCONDC = ZERO
720 GO TO 230
721 END IF
722*
723* Do for each value of NRHS in NSVAL.
724*
725 DO 220 IRHS = 1, NNS
726 NRHS = NSVAL( IRHS )
727*
728*+ TEST 5 ( Using TRS_ROOK)
729* Solve and compute residual for A * X = B.
730*
731* Choose a set of NRHS random solution vectors
732* stored in XACT and set up the right hand side B
733*
734 SRNAMT = 'slarhs'
735 CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N,
736 $ KL, KU, NRHS, A, LDA, XACT, LDA,
737 $ B, LDA, ISEED, INFO )
738 CALL SLACPY( 'full', N, NRHS, B, LDA, X, LDA )
739*
740 SRNAMT = 'ssytrs_rook'
741 CALL SSYTRS_ROOK( UPLO, N, NRHS, AFAC, LDA, IWORK,
742 $ X, LDA, INFO )
743*
744* Check error code from SSYTRS_ROOK and handle error.
745*
746.NE. IF( INFO0 )
747 $ CALL ALAERH( PATH, 'ssytrs_rook', info, 0,
748 $ uplo, n, n, -1, -1, nrhs, imat,
749 $ nfail, nerrs, nout )
750*
751 CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
752*
753* Compute the residual for the solution
754*
755 CALL spot02( uplo, n, nrhs, a, lda, x, lda, work,
756 $ lda, rwork, result( 5 ) )
757*
758*+ TEST 6
759* Check solution from generated exact solution.
760*
761 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
762 $ result( 6 ) )
763*
764* Print information about the tests that did not pass
765* the threshold.
766*
767 DO 210 k = 5, 6
768 IF( result( k ).GE.thresh ) THEN
769 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
770 $ CALL alahd( nout, path )
771 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
772 $ imat, k, result( k )
773 nfail = nfail + 1
774 END IF
775 210 CONTINUE
776 nrun = nrun + 2
777*
778* End do for each value of NRHS in NSVAL.
779*
780 220 CONTINUE
781*
782*+ TEST 7
783* Get an estimate of RCOND = 1/CNDNUM.
784*
785 230 CONTINUE
786 anorm = slansy( '1', uplo, n, a, lda, rwork )
787 srnamt = 'ssycon_rook'
788 CALL SSYCON_ROOK( UPLO, N, AFAC, LDA, IWORK, ANORM,
789 $ RCOND, WORK, IWORK( N+1 ), INFO )
790*
791* Check error code from SSYCON_ROOK and handle error.
792*
793.NE. IF( INFO0 )
794 $ CALL ALAERH( PATH, 'ssycon_rook', INFO, 0,
795 $ UPLO, N, N, -1, -1, -1, IMAT,
796 $ NFAIL, NERRS, NOUT )
797*
798* Compute the test ratio to compare values of RCOND
799*
800 RESULT( 7 ) = SGET06( RCOND, RCONDC )
801*
802* Print information about the tests that did not pass
803* the threshold.
804*
805.GE. IF( RESULT( 7 )THRESH ) THEN
806.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
807 $ CALL ALAHD( NOUT, PATH )
808 WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7,
809 $ RESULT( 7 )
810 NFAIL = NFAIL + 1
811 END IF
812 NRUN = NRUN + 1
813 240 CONTINUE
814*
815 250 CONTINUE
816 260 CONTINUE
817 270 CONTINUE
818*
819* Print a summary of the results.
820*
821 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
822*
823 9999 FORMAT( ' uplo = ''', A1, ''', n =', i5, ', NB =', i4, ', type ',
824 $ i2, ', test ', i2, ', ratio =', g12.5 )
825 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
826 $ i2, ', test(', i2, ') =', g12.5 )
827 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
828 $ ', test(', i2, ') =', g12.5 )
829 RETURN
830*
831* End of SCHKSY_ROOK
832*
833 END
slacpy
subroutine slacpy(uplo, m, n, a, lda, b, ldb)
SLACPY copies all or part of one two-dimensional array to another.
Definition slacpy.f:103
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
alahd
subroutine alahd(iounit, path)
ALAHD
Definition alahd.f:107
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
sgesvd
subroutine sgesvd(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, info)
SGESVD computes the singular value decomposition (SVD) for GE matrices
Definition sgesvd.f:211
ssycon_rook
subroutine ssycon_rook(uplo, n, a, lda, ipiv, anorm, rcond, work, iwork, info)
SSYCON_ROOK
Definition ssycon_rook.f:144
ssytrf_rook
subroutine ssytrf_rook(uplo, n, a, lda, ipiv, work, lwork, info)
SSYTRF_ROOK
Definition ssytrf_rook.f:208
ssytrs_rook
subroutine ssytrs_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
SSYTRS_ROOK
Definition ssytrs_rook.f:136
ssytri_rook
subroutine ssytri_rook(uplo, n, a, lda, ipiv, work, info)
SSYTRI_ROOK
Definition ssytri_rook.f:129
slatms
subroutine slatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
SLATMS
Definition slatms.f:321
slarhs
subroutine slarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
SLARHS
Definition slarhs.f:205
spot02
subroutine spot02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
SPOT02
Definition spot02.f:127
ssyt01_rook
subroutine ssyt01_rook(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
SSYT01_ROOK
Definition ssyt01_rook.f:124
serrsy
subroutine serrsy(path, nunit)
SERRSY
Definition serrsy.f:55
schksy_rook
subroutine schksy_rook(dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
SCHKSY_ROOK
Definition schksy_rook.f:171
spot03
subroutine spot03(uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
SPOT03
Definition spot03.f:125
sget04
subroutine sget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
SGET04
Definition sget04.f:102
slatb4
subroutine slatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
SLATB4
Definition slatb4.f:120
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21