1*> \brief \b SDRVSY_RK
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 SDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
12*    $                      NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
13*    $                      RWORK, IWORK, NOUT )
14*
15*       .. Scalar Arguments ..
16*       LOGICAL            TSTERR
17*       INTEGER            NMAX, NN, NOUT, NRHS
18*       REAL               THRESH
19*       ..
20*       .. Array Arguments ..
21*       LOGICAL            DOTYPE( * )
22*       INTEGER            IWORK( * ), NVAL( * )
23*       REAL               A( * ), AFAC( * ), E( * ), AINV( * ), B( * ),
24*      $                   RWORK( * ), WORK( * ), X( * ), XACT( * )
25*       ..
26*
27*
28*> \par Purpose:
29*  =============
30*>
31*> \verbatim
32*> SDRVSY_RK tests the driver routines SSYSV_RK.
33*> \endverbatim
34*
35*  Arguments:
36*  ==========
37*
38*> \param[in] DOTYPE
39*> \verbatim
40*>          DOTYPE is LOGICAL array, dimension (NTYPES)
41*>          The matrix types to be used for testing.  Matrices of type j
42*>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
43*>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
44*> \endverbatim
45*>
46*> \param[in] NN
47*> \verbatim
48*>          NN is INTEGER
49*>          The number of values of N contained in the vector NVAL.
50*> \endverbatim
51*>
52*> \param[in] NVAL
53*> \verbatim
54*>          NVAL is INTEGER array, dimension (NN)
55*>          The values of the matrix dimension N.
56*> \endverbatim
57*>
58*> \param[in] NRHS
59*> \verbatim
60*>          NRHS is INTEGER
61*>          The number of right hand side vectors to be generated for
62*>          each linear system.
63*> \endverbatim
64*>
65*> \param[in] THRESH
66*> \verbatim
67*>          THRESH is REAL
68*>          The threshold value for the test ratios.  A result is
69*>          included in the output file if RESULT >= THRESH.  To have
70*>          every test ratio printed, use THRESH = 0.
71*> \endverbatim
72*>
73*> \param[in] TSTERR
74*> \verbatim
75*>          TSTERR is LOGICAL
76*>          Flag that indicates whether error exits are to be tested.
77*> \endverbatim
78*>
79*> \param[in] NMAX
80*> \verbatim
81*>          NMAX is INTEGER
82*>          The maximum value permitted for N, used in dimensioning the
83*>          work arrays.
84*> \endverbatim
85*>
86*> \param[out] A
87*> \verbatim
88*>          A is REAL array, dimension (NMAX*NMAX)
89*> \endverbatim
90*>
91*> \param[out] AFAC
92*> \verbatim
93*>          AFAC is REAL array, dimension (NMAX*NMAX)
94*> \endverbatim
95*>
96*> \param[out] E
97*> \verbatim
98*>          E is REAL array, dimension (NMAX)
99*> \endverbatim
100*>
101*> \param[out] AINV
102*> \verbatim
103*>          AINV is REAL array, dimension (NMAX*NMAX)
104*> \endverbatim
105*>
106*> \param[out] B
107*> \verbatim
108*>          B is REAL array, dimension (NMAX*NRHS)
109*> \endverbatim
110*>
111*> \param[out] X
112*> \verbatim
113*>          X is REAL array, dimension (NMAX*NRHS)
114*> \endverbatim
115*>
116*> \param[out] XACT
117*> \verbatim
118*>          XACT is REAL array, dimension (NMAX*NRHS)
119*> \endverbatim
120*>
121*> \param[out] WORK
122*> \verbatim
123*>          WORK is REAL array, dimension (NMAX*max(2,NRHS))
124*> \endverbatim
125*>
126*> \param[out] RWORK
127*> \verbatim
128*>          RWORK is REAL array, dimension (NMAX+2*NRHS)
129*> \endverbatim
130*>
131*> \param[out] IWORK
132*> \verbatim
133*>          IWORK is INTEGER array, dimension (2*NMAX)
134*> \endverbatim
135*>
136*> \param[in] NOUT
137*> \verbatim
138*>          NOUT is INTEGER
139*>          The unit number for output.
140*> \endverbatim
141*
142*  Authors:
143*  ========
144*
145*> \author Univ. of Tennessee
146*> \author Univ. of California Berkeley
147*> \author Univ. of Colorado Denver
148*> \author NAG Ltd.
149*
150*> \ingroup single_lin
151*
152*  =====================================================================
153      SUBROUTINE SDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
154     $                      NMAX, A, AFAC, E, AINV, B, X, XACT, WORK,
155     $                      RWORK, IWORK, NOUT )
156*
157*  -- LAPACK test routine --
158*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
159*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
160*
161*     .. Scalar Arguments ..
162      LOGICAL            TSTERR
163      INTEGER            NMAX, NN, NOUT, NRHS
164      REAL               THRESH
165*     ..
166*     .. Array Arguments ..
167      LOGICAL            DOTYPE( * )
168      INTEGER            IWORK( * ), NVAL( * )
169      REAL               A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
170     $                   RWORK( * ), WORK( * ), X( * ), XACT( * )
171*     ..
172*
173*  =====================================================================
174*
175*     .. Parameters ..
176      REAL               ONE, ZERO
177      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
178      INTEGER            NTYPES, NTESTS
179      PARAMETER          ( NTYPES = 10, NTESTS = 3 )
180      INTEGER            NFACT
181      PARAMETER          ( NFACT = 2 )
182*     ..
183*     .. Local Scalars ..
184      LOGICAL            ZEROT
185      CHARACTER          DIST, FACT, TYPE, UPLO, XTYPE
186      CHARACTER*3        PATH, MATPATH
187      INTEGER            I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
188     $                   IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
189     $                   NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
190      REAL               AINVNM, ANORM, CNDNUM, RCONDC
191*     ..
192*     .. Local Arrays ..
193      CHARACTER          FACTS( NFACT ), UPLOS( 2 )
194      INTEGER            ISEED( 4 ), ISEEDY( 4 )
195      REAL               RESULT( NTESTS )
196*     ..
197*     .. External Functions ..
198      REAL               SLANSY
199      EXTERNAL           SLANSY
200*     ..
201*     .. External Subroutines ..
202      EXTERNAL           ALADHD, ALAERH, ALASVM, SERRVX, SGET04, SLACPY,
203     $                   SLARHS, SLATB4, SLATMS, SPOT02, SSYSV_RK,
204     $                   SSYT01_3, SSYTRF_RK, SSYTRI_3, XLAENV
205*     ..
206*     .. Scalars in Common ..
207      LOGICAL            LERR, OK
208      CHARACTER*32       SRNAMT
209      INTEGER            INFOT, NUNIT
210*     ..
211*     .. Common blocks ..
212      COMMON             / INFOC / INFOT, NUNIT, OK, LERR
213      COMMON             / SRNAMC / SRNAMT
214*     ..
215*     .. Intrinsic Functions ..
216      INTRINSIC          MAX, MIN
217*     ..
218*     .. Data statements ..
219      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
220      DATA               UPLOS / 'U', 'L' / , FACTS / 'F', 'N' /
221*     ..
222*     .. Executable Statements ..
223*
224*     Initialize constants and the random number seed.
225*
226*     Test path
227*
228      PATH( 1: 1 ) = 'Single precision'
229      PATH( 2: 3 ) = 'SK'
230*
231*     Path to generate matrices
232*
233      MATPATH( 1: 1 ) = 'Single precision'
234      MATPATH( 2: 3 ) = 'SY'
235*
236      NRUN = 0
237      NFAIL = 0
238      NERRS = 0
239      DO 10 I = 1, 4
240         ISEED( I ) = ISEEDY( I )
241   10 CONTINUE
242      LWORK = MAX( 2*NMAX, NMAX*NRHS )
243*
244*     Test the error exits
245*
246      IF( TSTERR )
247     $   CALL SERRVX( PATH, NOUT )
248      INFOT = 0
249*
250*     Set the block size and minimum block size for which the block
251*     routine should be used, which will be later returned by ILAENV.
252*
253      NB = 1
254      NBMIN = 2
255      CALL XLAENV( 1, NB )
256      CALL XLAENV( 2, NBMIN )
257*
258*     Do for each value of N in NVAL
259*
260      DO 180 IN = 1, NN
261         N = NVAL( IN )
262         LDA = MAX( N, 1 )
263         XTYPE = 'N'
264         NIMAT = NTYPES
265         IF( N.LE.0 )
266     $      NIMAT = 1
267*
268         DO 170 IMAT = 1, NIMAT
269*
270*           Do the tests only if DOTYPE( IMAT ) is true.
271*
272            IF( .NOT.DOTYPE( IMAT ) )
273     $         GO TO 170
274*
275*           Skip types 3, 4, 5, or 6 if the matrix size is too small.
276*
277            ZEROT = IMAT.GE.3 .AND. IMAT.LE.6
278            IF( ZEROT .AND. N.LT.IMAT-2 )
279     $         GO TO 170
280*
281*           Do first for UPLO = 'U', then for UPLO = 'L'
282*
283            DO 160 IUPLO = 1, 2
284               UPLO = UPLOS( IUPLO )
285*
286*              Begin generate the test matrix A.
287*
288*              Set up parameters with SLATB4 for the matrix generator
289*              based on the type of matrix to be generated.
290*
291               CALL SLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM,
292     $                      MODE, CNDNUM, DIST )
293*
294*              Generate a matrix with SLATMS.
295*
296               SRNAMT = 'SLATMS'
297               CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
298     $                      CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
299     $                      INFO )
300*
301*              Check error code from SLATMS and handle error.
302*
303               IF( INFO.NE.0 ) THEN
304                  CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1,
305     $                         -1, -1, IMAT, NFAIL, NERRS, NOUT )
306*
307*                 Skip all tests for this generated matrix
308*
309                  GO TO 160
310               END IF
311*
312*              For types 3-6, zero one or more rows and columns of the
313*              matrix to test that INFO is returned correctly.
314*
315               IF( ZEROT ) THEN
316                  IF( IMAT.EQ.3 ) THEN
317                     IZERO = 1
318                  ELSE IF( IMAT.EQ.4 ) THEN
319                     IZERO = N
320                  ELSE
321                     IZERO = N / 2 + 1
322                  END IF
323*
324                  IF( IMAT.LT.6 ) THEN
325*
326*                    Set row and column IZERO to zero.
327*
328                     IF( IUPLO.EQ.1 ) THEN
329                        IOFF = ( IZERO-1 )*LDA
330                        DO 20 I = 1, IZERO - 1
331                           A( IOFF+I ) = ZERO
332   20                   CONTINUE
333                        IOFF = IOFF + IZERO
334                        DO 30 I = IZERO, N
335                           A( IOFF ) = ZERO
336                           IOFF = IOFF + LDA
337   30                   CONTINUE
338                     ELSE
339                        IOFF = IZERO
340                        DO 40 I = 1, IZERO - 1
341                           A( IOFF ) = ZERO
342                           IOFF = IOFF + LDA
343   40                   CONTINUE
344                        IOFF = IOFF - IZERO
345                        DO 50 I = IZERO, N
346                           A( IOFF+I ) = ZERO
347   50                   CONTINUE
348                     END IF
349                  ELSE
350                     IOFF = 0
351                     IF( IUPLO.EQ.1 ) THEN
352*
353*                       Set the first IZERO rows and columns to zero.
354*
355                        DO 70 J = 1, N
356                           I2 = MIN( J, IZERO )
357                           DO 60 I = 1, I2
358                              A( IOFF+I ) = ZERO
359   60                      CONTINUE
360                           IOFF = IOFF + LDA
361   70                   CONTINUE
362                     ELSE
363*
364*                       Set the last IZERO rows and columns to zero.
365*
366                        DO 90 J = 1, N
367                           I1 = MAX( J, IZERO )
368                           DO 80 I = I1, N
369                              A( IOFF+I ) = ZERO
370   80                      CONTINUE
371                           IOFF = IOFF + LDA
372   90                   CONTINUE
373                     END IF
374                  END IF
375               ELSE
376                  IZERO = 0
377               END IF
378*
379*              End generate the test matrix A.
380*
381               DO 150 IFACT = 1, NFACT
382*
383*                 Do first for FACT = 'F', then for other values.
384*
385                  FACT = FACTS( IFACT )
386*
387*                 Compute the condition number
388*
389                  IF( ZEROT ) THEN
390                     IF( IFACT.EQ.1 )
391     $                  GO TO 150
392                     RCONDC = ZERO
393*
394                  ELSE IF( IFACT.EQ.1 ) THEN
395*
396*                    Compute the 1-norm of A.
397*
398                     ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK )
399*
400*                    Factor the matrix A.
401*
402                     CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
403                     CALL SSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK,
404     $                               LWORK, INFO )
405*
406*                    Compute inv(A) and take its norm.
407*
408                     CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA )
409                     LWORK = (N+NB+1)*(NB+3)
410*
411*                    We need to compute the inverse to compute
412*                    RCONDC that is used later in TEST3.
413*
414                     CALL SSYTRI_3( UPLO, N, AINV, LDA, E, IWORK,
415     $                              WORK, LWORK, INFO )
416                     AINVNM = SLANSY( '1', UPLO, N, AINV, LDA, RWORK )
417*
418*                    Compute the 1-norm condition number of A.
419*
420                     IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
421                        RCONDC = ONE
422                     ELSE
423                        RCONDC = ( ONE / ANORM ) / AINVNM
424                     END IF
425                  END IF
426*
427*                 Form an exact solution and set the right hand side.
428*
429                  SRNAMT = 'SLARHS'
430                  CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU,
431     $                         NRHS, A, LDA, XACT, LDA, B, LDA, ISEED,
432     $                         INFO )
433                  XTYPE = 'C'
434*
435*                 --- Test SSYSV_RK  ---
436*
437                  IF( IFACT.EQ.2 ) THEN
438                     CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
439                     CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
440*
441*                    Factor the matrix and solve the system using
442*                    SSYSV_RK.
443*
444                     SRNAMT = 'SSYSV_RK'
445                     CALL SSYSV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK,
446     $                              X, LDA, WORK, LWORK, INFO )
447*
448*                    Adjust the expected value of INFO to account for
449*                    pivoting.
450*
451                     K = IZERO
452                     IF( K.GT.0 ) THEN
453  100                   CONTINUE
454                        IF( IWORK( K ).LT.0 ) THEN
455                           IF( IWORK( K ).NE.-K ) THEN
456                              K = -IWORK( K )
457                              GO TO 100
458                           END IF
459                        ELSE IF( IWORK( K ).NE.K ) THEN
460                           K = IWORK( K )
461                           GO TO 100
462                        END IF
463                     END IF
464*
465*                    Check error code from SSYSV_RK and handle error.
466*
467                     IF( INFO.NE.K ) THEN
468                        CALL ALAERH( PATH, 'SSYSV_RK', INFO, K, UPLO,
469     $                               N, N, -1, -1, NRHS, IMAT, NFAIL,
470     $                               NERRS, NOUT )
471                        GO TO 120
472                     ELSE IF( INFO.NE.0 ) THEN
473                        GO TO 120
474                     END IF
475*
476*+    TEST 1      Reconstruct matrix from factors and compute
477*                 residual.
478*
479                     CALL SSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E,
480     $                              IWORK, AINV, LDA, RWORK,
481     $                              RESULT( 1 ) )
482*
483*+    TEST 2      Compute residual of the computed solution.
484*
485                     CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA )
486                     CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
487     $                            LDA, RWORK, RESULT( 2 ) )
488*
489*+    TEST 3
490*                 Check solution from generated exact solution.
491*
492                     CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
493     $                            RESULT( 3 ) )
494                     NT = 3
495*
496*                    Print information about the tests that did not pass
497*                    the threshold.
498*
499                     DO 110 K = 1, NT
500                        IF( RESULT( K ).GE.THRESH ) THEN
501                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
502     $                        CALL ALADHD( NOUT, PATH )
503                           WRITE( NOUT, FMT = 9999 )'SSYSV_RK', UPLO,
504     $                           N, IMAT, K, RESULT( K )
505                           NFAIL = NFAIL + 1
506                        END IF
507  110                CONTINUE
508                     NRUN = NRUN + NT
509  120                CONTINUE
510                  END IF
511*
512  150          CONTINUE
513*
514  160       CONTINUE
515  170    CONTINUE
516  180 CONTINUE
517*
518*     Print a summary of the results.
519*
520      CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
521*
522 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2,
523     $      ', test ', I2, ', ratio =', G12.5 )
524      RETURN
525*
526*     End of SDRVSY_RK
527*
528      END
529