Gitiles
Code Review Sign In
realtimeroboticsgroup.org / RealtimeRoboticsGroup / test / a57b70145cb0a950c1c3a9a4fddf0438c60126f2 / . / third_party / eigen / blas / testing / dblat3.f
blob: 8d37c7453164245ab6e0fbd40e0201760ea3403a [file] [log] [blame]
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]1*> \brief \b DBLAT3
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8* Definition:
9* ===========
10*
11* PROGRAM DBLAT3
12*
13*
14*> \par Purpose:
15* =============
16*>
17*> \verbatim
18*>
19*> Test program for the DOUBLE PRECISION Level 3 Blas.
20*>
21*> The program must be driven by a short data file. The first 14 records
22*> of the file are read using list-directed input, the last 6 records
23*> are read using the format ( A6, L2 ). An annotated example of a data
24*> file can be obtained by deleting the first 3 characters from the
25*> following 20 lines:
26*> 'dblat3.out' NAME OF SUMMARY OUTPUT FILE
27*> 6 UNIT NUMBER OF SUMMARY FILE
28*> 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
29*> -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
30*> F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
31*> F LOGICAL FLAG, T TO STOP ON FAILURES.
32*> T LOGICAL FLAG, T TO TEST ERROR EXITS.
33*> 16.0 THRESHOLD VALUE OF TEST RATIO
34*> 6 NUMBER OF VALUES OF N
35*> 0 1 2 3 5 9 VALUES OF N
36*> 3 NUMBER OF VALUES OF ALPHA
37*> 0.0 1.0 0.7 VALUES OF ALPHA
38*> 3 NUMBER OF VALUES OF BETA
39*> 0.0 1.0 1.3 VALUES OF BETA
40*> DGEMM T PUT F FOR NO TEST. SAME COLUMNS.
41*> DSYMM T PUT F FOR NO TEST. SAME COLUMNS.
42*> DTRMM T PUT F FOR NO TEST. SAME COLUMNS.
43*> DTRSM T PUT F FOR NO TEST. SAME COLUMNS.
44*> DSYRK T PUT F FOR NO TEST. SAME COLUMNS.
45*> DSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
46*>
47*> Further Details
48*> ===============
49*>
50*> See:
51*>
52*> Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
53*> A Set of Level 3 Basic Linear Algebra Subprograms.
54*>
55*> Technical Memorandum No.88 (Revision 1), Mathematics and
56*> Computer Science Division, Argonne National Laboratory, 9700
57*> South Cass Avenue, Argonne, Illinois 60439, US.
58*>
59*> -- Written on 8-February-1989.
60*> Jack Dongarra, Argonne National Laboratory.
61*> Iain Duff, AERE Harwell.
62*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
63*> Sven Hammarling, Numerical Algorithms Group Ltd.
64*>
65*> 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
66*> can be run multiple times without deleting generated
67*> output files (susan)
68*> \endverbatim
69*
70* Authors:
71* ========
72*
73*> \author Univ. of Tennessee
74*> \author Univ. of California Berkeley
75*> \author Univ. of Colorado Denver
76*> \author NAG Ltd.
77*
78*> \date April 2012
79*
80*> \ingroup double_blas_testing
81*
82* =====================================================================
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]83 PROGRAM DBLAT3
84*
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]85* -- Reference BLAS test routine (version 3.4.1) --
86* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
87* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
88* April 2012
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]89*
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]90* =====================================================================
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]91*
92* .. Parameters ..
93 INTEGER NIN
94 PARAMETER ( NIN = 5 )
95 INTEGER NSUBS
96 PARAMETER ( NSUBS = 6 )
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]97 DOUBLE PRECISION ZERO, ONE
98 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]99 INTEGER NMAX
100 PARAMETER ( NMAX = 65 )
101 INTEGER NIDMAX, NALMAX, NBEMAX
102 PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 )
103* .. Local Scalars ..
104 DOUBLE PRECISION EPS, ERR, THRESH
105 INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA
106 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
107 $ TSTERR
108 CHARACTER*1 TRANSA, TRANSB
109 CHARACTER*6 SNAMET
110 CHARACTER*32 SNAPS, SUMMRY
111* .. Local Arrays ..
112 DOUBLE PRECISION AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ),
113 $ ALF( NALMAX ), AS( NMAX*NMAX ),
114 $ BB( NMAX*NMAX ), BET( NBEMAX ),
115 $ BS( NMAX*NMAX ), C( NMAX, NMAX ),
116 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
117 $ G( NMAX ), W( 2*NMAX )
118 INTEGER IDIM( NIDMAX )
119 LOGICAL LTEST( NSUBS )
120 CHARACTER*6 SNAMES( NSUBS )
121* .. External Functions ..
122 DOUBLE PRECISION DDIFF
123 LOGICAL LDE
124 EXTERNAL DDIFF, LDE
125* .. External Subroutines ..
126 EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHKE, DMMCH
127* .. Intrinsic Functions ..
128 INTRINSIC MAX, MIN
129* .. Scalars in Common ..
130 INTEGER INFOT, NOUTC
131 LOGICAL LERR, OK
132 CHARACTER*6 SRNAMT
133* .. Common blocks ..
134 COMMON /INFOC/INFOT, NOUTC, OK, LERR
135 COMMON /SRNAMC/SRNAMT
136* .. Data statements ..
137 DATA SNAMES/'DGEMM ', 'DSYMM ', 'DTRMM ', 'DTRSM ',
138 $ 'DSYRK ', 'DSYR2K'/
139* .. Executable Statements ..
140*
141* Read name and unit number for summary output file and open file.
142*
143 READ( NIN, FMT = * )SUMMRY
144 READ( NIN, FMT = * )NOUT
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]145 OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]146 NOUTC = NOUT
147*
148* Read name and unit number for snapshot output file and open file.
149*
150 READ( NIN, FMT = * )SNAPS
151 READ( NIN, FMT = * )NTRA
152 TRACE = NTRA.GE.0
153 IF( TRACE )THEN
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]154 OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' )
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]155 END IF
156* Read the flag that directs rewinding of the snapshot file.
157 READ( NIN, FMT = * )REWI
158 REWI = REWI.AND.TRACE
159* Read the flag that directs stopping on any failure.
160 READ( NIN, FMT = * )SFATAL
161* Read the flag that indicates whether error exits are to be tested.
162 READ( NIN, FMT = * )TSTERR
163* Read the threshold value of the test ratio
164 READ( NIN, FMT = * )THRESH
165*
166* Read and check the parameter values for the tests.
167*
168* Values of N
169 READ( NIN, FMT = * )NIDIM
170 IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
171 WRITE( NOUT, FMT = 9997 )'N', NIDMAX
172 GO TO 220
173 END IF
174 READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
175 DO 10 I = 1, NIDIM
176 IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
177 WRITE( NOUT, FMT = 9996 )NMAX
178 GO TO 220
179 END IF
180 10 CONTINUE
181* Values of ALPHA
182 READ( NIN, FMT = * )NALF
183 IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
184 WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
185 GO TO 220
186 END IF
187 READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
188* Values of BETA
189 READ( NIN, FMT = * )NBET
190 IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
191 WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
192 GO TO 220
193 END IF
194 READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
195*
196* Report values of parameters.
197*
198 WRITE( NOUT, FMT = 9995 )
199 WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM )
200 WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF )
201 WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET )
202 IF( .NOT.TSTERR )THEN
203 WRITE( NOUT, FMT = * )
204 WRITE( NOUT, FMT = 9984 )
205 END IF
206 WRITE( NOUT, FMT = * )
207 WRITE( NOUT, FMT = 9999 )THRESH
208 WRITE( NOUT, FMT = * )
209*
210* Read names of subroutines and flags which indicate
211* whether they are to be tested.
212*
213 DO 20 I = 1, NSUBS
214 LTEST( I ) = .FALSE.
215 20 CONTINUE
216 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT
217 DO 40 I = 1, NSUBS
218 IF( SNAMET.EQ.SNAMES( I ) )
219 $ GO TO 50
220 40 CONTINUE
221 WRITE( NOUT, FMT = 9990 )SNAMET
222 STOP
223 50 LTEST( I ) = LTESTT
224 GO TO 30
225*
226 60 CONTINUE
227 CLOSE ( NIN )
228*
229* Compute EPS (the machine precision).
230*
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]231 EPS = EPSILON(ZERO)
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]232 WRITE( NOUT, FMT = 9998 )EPS
233*
234* Check the reliability of DMMCH using exact data.
235*
236 N = MIN( 32, NMAX )
237 DO 100 J = 1, N
238 DO 90 I = 1, N
239 AB( I, J ) = MAX( I - J + 1, 0 )
240 90 CONTINUE
241 AB( J, NMAX + 1 ) = J
242 AB( 1, NMAX + J ) = J
243 C( J, 1 ) = ZERO
244 100 CONTINUE
245 DO 110 J = 1, N
246 CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
247 110 CONTINUE
248* CC holds the exact result. On exit from DMMCH CT holds
249* the result computed by DMMCH.
250 TRANSA = 'N'
251 TRANSB = 'N'
252 CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
253 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
254 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
255 SAME = LDE( CC, CT, N )
256 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
257 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
258 STOP
259 END IF
260 TRANSB = 'T'
261 CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
262 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
263 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
264 SAME = LDE( CC, CT, N )
265 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
266 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
267 STOP
268 END IF
269 DO 120 J = 1, N
270 AB( J, NMAX + 1 ) = N - J + 1
271 AB( 1, NMAX + J ) = N - J + 1
272 120 CONTINUE
273 DO 130 J = 1, N
274 CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 -
275 $ ( ( J + 1 )*J*( J - 1 ) )/3
276 130 CONTINUE
277 TRANSA = 'T'
278 TRANSB = 'N'
279 CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
280 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
281 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
282 SAME = LDE( CC, CT, N )
283 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
284 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
285 STOP
286 END IF
287 TRANSB = 'T'
288 CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
289 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
290 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
291 SAME = LDE( CC, CT, N )
292 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
293 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
294 STOP
295 END IF
296*
297* Test each subroutine in turn.
298*
299 DO 200 ISNUM = 1, NSUBS
300 WRITE( NOUT, FMT = * )
301 IF( .NOT.LTEST( ISNUM ) )THEN
302* Subprogram is not to be tested.
303 WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM )
304 ELSE
305 SRNAMT = SNAMES( ISNUM )
306* Test error exits.
307 IF( TSTERR )THEN
308 CALL DCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
309 WRITE( NOUT, FMT = * )
310 END IF
311* Test computations.
312 INFOT = 0
313 OK = .TRUE.
314 FATAL = .FALSE.
315 GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM
316* Test DGEMM, 01.
317 140 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
318 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
319 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
320 $ CC, CS, CT, G )
321 GO TO 190
322* Test DSYMM, 02.
323 150 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
324 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
325 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
326 $ CC, CS, CT, G )
327 GO TO 190
328* Test DTRMM, 03, DTRSM, 04.
329 160 CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
330 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
331 $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C )
332 GO TO 190
333* Test DSYRK, 05.
334 170 CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
335 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
336 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
337 $ CC, CS, CT, G )
338 GO TO 190
339* Test DSYR2K, 06.
340 180 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
341 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
342 $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
343 GO TO 190
344*
345 190 IF( FATAL.AND.SFATAL )
346 $ GO TO 210
347 END IF
348 200 CONTINUE
349 WRITE( NOUT, FMT = 9986 )
350 GO TO 230
351*
352 210 CONTINUE
353 WRITE( NOUT, FMT = 9985 )
354 GO TO 230
355*
356 220 CONTINUE
357 WRITE( NOUT, FMT = 9991 )
358*
359 230 CONTINUE
360 IF( TRACE )
361 $ CLOSE ( NTRA )
362 CLOSE ( NOUT )
363 STOP
364*
365 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
366 $ 'S THAN', F8.2 )
367 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 )
368 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
369 $ 'THAN ', I2 )
370 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
371 9995 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 3 BLAS', //' THE F',
372 $ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
373 9994 FORMAT( ' FOR N ', 9I6 )
374 9993 FORMAT( ' FOR ALPHA ', 7F6.1 )
375 9992 FORMAT( ' FOR BETA ', 7F6.1 )
376 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
377 $ /' ******* TESTS ABANDONED *******' )
378 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
379 $ 'ESTS ABANDONED *******' )
380 9989 FORMAT( ' ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
381 $ 'ATED WRONGLY.', /' DMMCH WAS CALLED WITH TRANSA = ', A1,
382 $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ',
383 $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
384 $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
385 $ '*******' )
386 9988 FORMAT( A6, L2 )
387 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' )
388 9986 FORMAT( /' END OF TESTS' )
389 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
390 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
391*
392* End of DBLAT3.
393*
394 END
395 SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
396 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
397 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
398*
399* Tests DGEMM.
400*
401* Auxiliary routine for test program for Level 3 Blas.
402*
403* -- Written on 8-February-1989.
404* Jack Dongarra, Argonne National Laboratory.
405* Iain Duff, AERE Harwell.
406* Jeremy Du Croz, Numerical Algorithms Group Ltd.
407* Sven Hammarling, Numerical Algorithms Group Ltd.
408*
409* .. Parameters ..
410 DOUBLE PRECISION ZERO
411 PARAMETER ( ZERO = 0.0D0 )
412* .. Scalar Arguments ..
413 DOUBLE PRECISION EPS, THRESH
414 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
415 LOGICAL FATAL, REWI, TRACE
416 CHARACTER*6 SNAME
417* .. Array Arguments ..
418 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
419 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
420 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
421 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
422 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
423 INTEGER IDIM( NIDIM )
424* .. Local Scalars ..
425 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX
426 INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
427 $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
428 $ MA, MB, MS, N, NA, NARGS, NB, NC, NS
429 LOGICAL NULL, RESET, SAME, TRANA, TRANB
430 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB
431 CHARACTER*3 ICH
432* .. Local Arrays ..
433 LOGICAL ISAME( 13 )
434* .. External Functions ..
435 LOGICAL LDE, LDERES
436 EXTERNAL LDE, LDERES
437* .. External Subroutines ..
438 EXTERNAL DGEMM, DMAKE, DMMCH
439* .. Intrinsic Functions ..
440 INTRINSIC MAX
441* .. Scalars in Common ..
442 INTEGER INFOT, NOUTC
443 LOGICAL LERR, OK
444* .. Common blocks ..
445 COMMON /INFOC/INFOT, NOUTC, OK, LERR
446* .. Data statements ..
447 DATA ICH/'NTC'/
448* .. Executable Statements ..
449*
450 NARGS = 13
451 NC = 0
452 RESET = .TRUE.
453 ERRMAX = ZERO
454*
455 DO 110 IM = 1, NIDIM
456 M = IDIM( IM )
457*
458 DO 100 IN = 1, NIDIM
459 N = IDIM( IN )
460* Set LDC to 1 more than minimum value if room.
461 LDC = M
462 IF( LDC.LT.NMAX )
463 $ LDC = LDC + 1
464* Skip tests if not enough room.
465 IF( LDC.GT.NMAX )
466 $ GO TO 100
467 LCC = LDC*N
468 NULL = N.LE.0.OR.M.LE.0
469*
470 DO 90 IK = 1, NIDIM
471 K = IDIM( IK )
472*
473 DO 80 ICA = 1, 3
474 TRANSA = ICH( ICA: ICA )
475 TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
476*
477 IF( TRANA )THEN
478 MA = K
479 NA = M
480 ELSE
481 MA = M
482 NA = K
483 END IF
484* Set LDA to 1 more than minimum value if room.
485 LDA = MA
486 IF( LDA.LT.NMAX )
487 $ LDA = LDA + 1
488* Skip tests if not enough room.
489 IF( LDA.GT.NMAX )
490 $ GO TO 80
491 LAA = LDA*NA
492*
493* Generate the matrix A.
494*
495 CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
496 $ RESET, ZERO )
497*
498 DO 70 ICB = 1, 3
499 TRANSB = ICH( ICB: ICB )
500 TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
501*
502 IF( TRANB )THEN
503 MB = N
504 NB = K
505 ELSE
506 MB = K
507 NB = N
508 END IF
509* Set LDB to 1 more than minimum value if room.
510 LDB = MB
511 IF( LDB.LT.NMAX )
512 $ LDB = LDB + 1
513* Skip tests if not enough room.
514 IF( LDB.GT.NMAX )
515 $ GO TO 70
516 LBB = LDB*NB
517*
518* Generate the matrix B.
519*
520 CALL DMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB,
521 $ LDB, RESET, ZERO )
522*
523 DO 60 IA = 1, NALF
524 ALPHA = ALF( IA )
525*
526 DO 50 IB = 1, NBET
527 BETA = BET( IB )
528*
529* Generate the matrix C.
530*
531 CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX,
532 $ CC, LDC, RESET, ZERO )
533*
534 NC = NC + 1
535*
536* Save every datum before calling the
537* subroutine.
538*
539 TRANAS = TRANSA
540 TRANBS = TRANSB
541 MS = M
542 NS = N
543 KS = K
544 ALS = ALPHA
545 DO 10 I = 1, LAA
546 AS( I ) = AA( I )
547 10 CONTINUE
548 LDAS = LDA
549 DO 20 I = 1, LBB
550 BS( I ) = BB( I )
551 20 CONTINUE
552 LDBS = LDB
553 BLS = BETA
554 DO 30 I = 1, LCC
555 CS( I ) = CC( I )
556 30 CONTINUE
557 LDCS = LDC
558*
559* Call the subroutine.
560*
561 IF( TRACE )
562 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
563 $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB,
564 $ BETA, LDC
565 IF( REWI )
566 $ REWIND NTRA
567 CALL DGEMM( TRANSA, TRANSB, M, N, K, ALPHA,
568 $ AA, LDA, BB, LDB, BETA, CC, LDC )
569*
570* Check if error-exit was taken incorrectly.
571*
572 IF( .NOT.OK )THEN
573 WRITE( NOUT, FMT = 9994 )
574 FATAL = .TRUE.
575 GO TO 120
576 END IF
577*
578* See what data changed inside subroutines.
579*
580 ISAME( 1 ) = TRANSA.EQ.TRANAS
581 ISAME( 2 ) = TRANSB.EQ.TRANBS
582 ISAME( 3 ) = MS.EQ.M
583 ISAME( 4 ) = NS.EQ.N
584 ISAME( 5 ) = KS.EQ.K
585 ISAME( 6 ) = ALS.EQ.ALPHA
586 ISAME( 7 ) = LDE( AS, AA, LAA )
587 ISAME( 8 ) = LDAS.EQ.LDA
588 ISAME( 9 ) = LDE( BS, BB, LBB )
589 ISAME( 10 ) = LDBS.EQ.LDB
590 ISAME( 11 ) = BLS.EQ.BETA
591 IF( NULL )THEN
592 ISAME( 12 ) = LDE( CS, CC, LCC )
593 ELSE
594 ISAME( 12 ) = LDERES( 'GE', ' ', M, N, CS,
595 $ CC, LDC )
596 END IF
597 ISAME( 13 ) = LDCS.EQ.LDC
598*
599* If data was incorrectly changed, report
600* and return.
601*
602 SAME = .TRUE.
603 DO 40 I = 1, NARGS
604 SAME = SAME.AND.ISAME( I )
605 IF( .NOT.ISAME( I ) )
606 $ WRITE( NOUT, FMT = 9998 )I
607 40 CONTINUE
608 IF( .NOT.SAME )THEN
609 FATAL = .TRUE.
610 GO TO 120
611 END IF
612*
613 IF( .NOT.NULL )THEN
614*
615* Check the result.
616*
617 CALL DMMCH( TRANSA, TRANSB, M, N, K,
618 $ ALPHA, A, NMAX, B, NMAX, BETA,
619 $ C, NMAX, CT, G, CC, LDC, EPS,
620 $ ERR, FATAL, NOUT, .TRUE. )
621 ERRMAX = MAX( ERRMAX, ERR )
622* If got really bad answer, report and
623* return.
624 IF( FATAL )
625 $ GO TO 120
626 END IF
627*
628 50 CONTINUE
629*
630 60 CONTINUE
631*
632 70 CONTINUE
633*
634 80 CONTINUE
635*
636 90 CONTINUE
637*
638 100 CONTINUE
639*
640 110 CONTINUE
641*
642* Report result.
643*
644 IF( ERRMAX.LT.THRESH )THEN
645 WRITE( NOUT, FMT = 9999 )SNAME, NC
646 ELSE
647 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
648 END IF
649 GO TO 130
650*
651 120 CONTINUE
652 WRITE( NOUT, FMT = 9996 )SNAME
653 WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K,
654 $ ALPHA, LDA, LDB, BETA, LDC
655*
656 130 CONTINUE
657 RETURN
658*
659 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
660 $ 'S)' )
661 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
662 $ 'ANGED INCORRECTLY *******' )
663 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
664 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
665 $ ' - SUSPECT *******' )
666 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
667 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',',
668 $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ',
669 $ 'C,', I3, ').' )
670 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
671 $ '******' )
672*
673* End of DCHK1.
674*
675 END
676 SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
677 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
678 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
679*
680* Tests DSYMM.
681*
682* Auxiliary routine for test program for Level 3 Blas.
683*
684* -- Written on 8-February-1989.
685* Jack Dongarra, Argonne National Laboratory.
686* Iain Duff, AERE Harwell.
687* Jeremy Du Croz, Numerical Algorithms Group Ltd.
688* Sven Hammarling, Numerical Algorithms Group Ltd.
689*
690* .. Parameters ..
691 DOUBLE PRECISION ZERO
692 PARAMETER ( ZERO = 0.0D0 )
693* .. Scalar Arguments ..
694 DOUBLE PRECISION EPS, THRESH
695 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
696 LOGICAL FATAL, REWI, TRACE
697 CHARACTER*6 SNAME
698* .. Array Arguments ..
699 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
700 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
701 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
702 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
703 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
704 INTEGER IDIM( NIDIM )
705* .. Local Scalars ..
706 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX
707 INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
708 $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
709 $ NARGS, NC, NS
710 LOGICAL LEFT, NULL, RESET, SAME
711 CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
712 CHARACTER*2 ICHS, ICHU
713* .. Local Arrays ..
714 LOGICAL ISAME( 13 )
715* .. External Functions ..
716 LOGICAL LDE, LDERES
717 EXTERNAL LDE, LDERES
718* .. External Subroutines ..
719 EXTERNAL DMAKE, DMMCH, DSYMM
720* .. Intrinsic Functions ..
721 INTRINSIC MAX
722* .. Scalars in Common ..
723 INTEGER INFOT, NOUTC
724 LOGICAL LERR, OK
725* .. Common blocks ..
726 COMMON /INFOC/INFOT, NOUTC, OK, LERR
727* .. Data statements ..
728 DATA ICHS/'LR'/, ICHU/'UL'/
729* .. Executable Statements ..
730*
731 NARGS = 12
732 NC = 0
733 RESET = .TRUE.
734 ERRMAX = ZERO
735*
736 DO 100 IM = 1, NIDIM
737 M = IDIM( IM )
738*
739 DO 90 IN = 1, NIDIM
740 N = IDIM( IN )
741* Set LDC to 1 more than minimum value if room.
742 LDC = M
743 IF( LDC.LT.NMAX )
744 $ LDC = LDC + 1
745* Skip tests if not enough room.
746 IF( LDC.GT.NMAX )
747 $ GO TO 90
748 LCC = LDC*N
749 NULL = N.LE.0.OR.M.LE.0
750*
751* Set LDB to 1 more than minimum value if room.
752 LDB = M
753 IF( LDB.LT.NMAX )
754 $ LDB = LDB + 1
755* Skip tests if not enough room.
756 IF( LDB.GT.NMAX )
757 $ GO TO 90
758 LBB = LDB*N
759*
760* Generate the matrix B.
761*
762 CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET,
763 $ ZERO )
764*
765 DO 80 ICS = 1, 2
766 SIDE = ICHS( ICS: ICS )
767 LEFT = SIDE.EQ.'L'
768*
769 IF( LEFT )THEN
770 NA = M
771 ELSE
772 NA = N
773 END IF
774* Set LDA to 1 more than minimum value if room.
775 LDA = NA
776 IF( LDA.LT.NMAX )
777 $ LDA = LDA + 1
778* Skip tests if not enough room.
779 IF( LDA.GT.NMAX )
780 $ GO TO 80
781 LAA = LDA*NA
782*
783 DO 70 ICU = 1, 2
784 UPLO = ICHU( ICU: ICU )
785*
786* Generate the symmetric matrix A.
787*
788 CALL DMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA,
789 $ RESET, ZERO )
790*
791 DO 60 IA = 1, NALF
792 ALPHA = ALF( IA )
793*
794 DO 50 IB = 1, NBET
795 BETA = BET( IB )
796*
797* Generate the matrix C.
798*
799 CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC,
800 $ LDC, RESET, ZERO )
801*
802 NC = NC + 1
803*
804* Save every datum before calling the
805* subroutine.
806*
807 SIDES = SIDE
808 UPLOS = UPLO
809 MS = M
810 NS = N
811 ALS = ALPHA
812 DO 10 I = 1, LAA
813 AS( I ) = AA( I )
814 10 CONTINUE
815 LDAS = LDA
816 DO 20 I = 1, LBB
817 BS( I ) = BB( I )
818 20 CONTINUE
819 LDBS = LDB
820 BLS = BETA
821 DO 30 I = 1, LCC
822 CS( I ) = CC( I )
823 30 CONTINUE
824 LDCS = LDC
825*
826* Call the subroutine.
827*
828 IF( TRACE )
829 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE,
830 $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC
831 IF( REWI )
832 $ REWIND NTRA
833 CALL DSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA,
834 $ BB, LDB, BETA, CC, LDC )
835*
836* Check if error-exit was taken incorrectly.
837*
838 IF( .NOT.OK )THEN
839 WRITE( NOUT, FMT = 9994 )
840 FATAL = .TRUE.
841 GO TO 110
842 END IF
843*
844* See what data changed inside subroutines.
845*
846 ISAME( 1 ) = SIDES.EQ.SIDE
847 ISAME( 2 ) = UPLOS.EQ.UPLO
848 ISAME( 3 ) = MS.EQ.M
849 ISAME( 4 ) = NS.EQ.N
850 ISAME( 5 ) = ALS.EQ.ALPHA
851 ISAME( 6 ) = LDE( AS, AA, LAA )
852 ISAME( 7 ) = LDAS.EQ.LDA
853 ISAME( 8 ) = LDE( BS, BB, LBB )
854 ISAME( 9 ) = LDBS.EQ.LDB
855 ISAME( 10 ) = BLS.EQ.BETA
856 IF( NULL )THEN
857 ISAME( 11 ) = LDE( CS, CC, LCC )
858 ELSE
859 ISAME( 11 ) = LDERES( 'GE', ' ', M, N, CS,
860 $ CC, LDC )
861 END IF
862 ISAME( 12 ) = LDCS.EQ.LDC
863*
864* If data was incorrectly changed, report and
865* return.
866*
867 SAME = .TRUE.
868 DO 40 I = 1, NARGS
869 SAME = SAME.AND.ISAME( I )
870 IF( .NOT.ISAME( I ) )
871 $ WRITE( NOUT, FMT = 9998 )I
872 40 CONTINUE
873 IF( .NOT.SAME )THEN
874 FATAL = .TRUE.
875 GO TO 110
876 END IF
877*
878 IF( .NOT.NULL )THEN
879*
880* Check the result.
881*
882 IF( LEFT )THEN
883 CALL DMMCH( 'N', 'N', M, N, M, ALPHA, A,
884 $ NMAX, B, NMAX, BETA, C, NMAX,
885 $ CT, G, CC, LDC, EPS, ERR,
886 $ FATAL, NOUT, .TRUE. )
887 ELSE
888 CALL DMMCH( 'N', 'N', M, N, N, ALPHA, B,
889 $ NMAX, A, NMAX, BETA, C, NMAX,
890 $ CT, G, CC, LDC, EPS, ERR,
891 $ FATAL, NOUT, .TRUE. )
892 END IF
893 ERRMAX = MAX( ERRMAX, ERR )
894* If got really bad answer, report and
895* return.
896 IF( FATAL )
897 $ GO TO 110
898 END IF
899*
900 50 CONTINUE
901*
902 60 CONTINUE
903*
904 70 CONTINUE
905*
906 80 CONTINUE
907*
908 90 CONTINUE
909*
910 100 CONTINUE
911*
912* Report result.
913*
914 IF( ERRMAX.LT.THRESH )THEN
915 WRITE( NOUT, FMT = 9999 )SNAME, NC
916 ELSE
917 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
918 END IF
919 GO TO 120
920*
921 110 CONTINUE
922 WRITE( NOUT, FMT = 9996 )SNAME
923 WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA,
924 $ LDB, BETA, LDC
925*
926 120 CONTINUE
927 RETURN
928*
929 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
930 $ 'S)' )
931 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
932 $ 'ANGED INCORRECTLY *******' )
933 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
934 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
935 $ ' - SUSPECT *******' )
936 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
937 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
938 $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
939 $ ' .' )
940 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
941 $ '******' )
942*
943* End of DCHK2.
944*
945 END
946 SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
947 $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS,
948 $ B, BB, BS, CT, G, C )
949*
950* Tests DTRMM and DTRSM.
951*
952* Auxiliary routine for test program for Level 3 Blas.
953*
954* -- Written on 8-February-1989.
955* Jack Dongarra, Argonne National Laboratory.
956* Iain Duff, AERE Harwell.
957* Jeremy Du Croz, Numerical Algorithms Group Ltd.
958* Sven Hammarling, Numerical Algorithms Group Ltd.
959*
960* .. Parameters ..
961 DOUBLE PRECISION ZERO, ONE
962 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
963* .. Scalar Arguments ..
964 DOUBLE PRECISION EPS, THRESH
965 INTEGER NALF, NIDIM, NMAX, NOUT, NTRA
966 LOGICAL FATAL, REWI, TRACE
967 CHARACTER*6 SNAME
968* .. Array Arguments ..
969 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
970 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
971 $ BB( NMAX*NMAX ), BS( NMAX*NMAX ),
972 $ C( NMAX, NMAX ), CT( NMAX ), G( NMAX )
973 INTEGER IDIM( NIDIM )
974* .. Local Scalars ..
975 DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX
976 INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
977 $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC,
978 $ NS
979 LOGICAL LEFT, NULL, RESET, SAME
980 CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
981 $ UPLOS
982 CHARACTER*2 ICHD, ICHS, ICHU
983 CHARACTER*3 ICHT
984* .. Local Arrays ..
985 LOGICAL ISAME( 13 )
986* .. External Functions ..
987 LOGICAL LDE, LDERES
988 EXTERNAL LDE, LDERES
989* .. External Subroutines ..
990 EXTERNAL DMAKE, DMMCH, DTRMM, DTRSM
991* .. Intrinsic Functions ..
992 INTRINSIC MAX
993* .. Scalars in Common ..
994 INTEGER INFOT, NOUTC
995 LOGICAL LERR, OK
996* .. Common blocks ..
997 COMMON /INFOC/INFOT, NOUTC, OK, LERR
998* .. Data statements ..
999 DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/
1000* .. Executable Statements ..
1001*
1002 NARGS = 11
1003 NC = 0
1004 RESET = .TRUE.
1005 ERRMAX = ZERO
1006* Set up zero matrix for DMMCH.
1007 DO 20 J = 1, NMAX
1008 DO 10 I = 1, NMAX
1009 C( I, J ) = ZERO
1010 10 CONTINUE
1011 20 CONTINUE
1012*
1013 DO 140 IM = 1, NIDIM
1014 M = IDIM( IM )
1015*
1016 DO 130 IN = 1, NIDIM
1017 N = IDIM( IN )
1018* Set LDB to 1 more than minimum value if room.
1019 LDB = M
1020 IF( LDB.LT.NMAX )
1021 $ LDB = LDB + 1
1022* Skip tests if not enough room.
1023 IF( LDB.GT.NMAX )
1024 $ GO TO 130
1025 LBB = LDB*N
1026 NULL = M.LE.0.OR.N.LE.0
1027*
1028 DO 120 ICS = 1, 2
1029 SIDE = ICHS( ICS: ICS )
1030 LEFT = SIDE.EQ.'L'
1031 IF( LEFT )THEN
1032 NA = M
1033 ELSE
1034 NA = N
1035 END IF
1036* Set LDA to 1 more than minimum value if room.
1037 LDA = NA
1038 IF( LDA.LT.NMAX )
1039 $ LDA = LDA + 1
1040* Skip tests if not enough room.
1041 IF( LDA.GT.NMAX )
1042 $ GO TO 130
1043 LAA = LDA*NA
1044*
1045 DO 110 ICU = 1, 2
1046 UPLO = ICHU( ICU: ICU )
1047*
1048 DO 100 ICT = 1, 3
1049 TRANSA = ICHT( ICT: ICT )
1050*
1051 DO 90 ICD = 1, 2
1052 DIAG = ICHD( ICD: ICD )
1053*
1054 DO 80 IA = 1, NALF
1055 ALPHA = ALF( IA )
1056*
1057* Generate the matrix A.
1058*
1059 CALL DMAKE( 'TR', UPLO, DIAG, NA, NA, A,
1060 $ NMAX, AA, LDA, RESET, ZERO )
1061*
1062* Generate the matrix B.
1063*
1064 CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX,
1065 $ BB, LDB, RESET, ZERO )
1066*
1067 NC = NC + 1
1068*
1069* Save every datum before calling the
1070* subroutine.
1071*
1072 SIDES = SIDE
1073 UPLOS = UPLO
1074 TRANAS = TRANSA
1075 DIAGS = DIAG
1076 MS = M
1077 NS = N
1078 ALS = ALPHA
1079 DO 30 I = 1, LAA
1080 AS( I ) = AA( I )
1081 30 CONTINUE
1082 LDAS = LDA
1083 DO 40 I = 1, LBB
1084 BS( I ) = BB( I )
1085 40 CONTINUE
1086 LDBS = LDB
1087*
1088* Call the subroutine.
1089*
1090 IF( SNAME( 4: 5 ).EQ.'MM' )THEN
1091 IF( TRACE )
1092 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1093 $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
1094 $ LDA, LDB
1095 IF( REWI )
1096 $ REWIND NTRA
1097 CALL DTRMM( SIDE, UPLO, TRANSA, DIAG, M,
1098 $ N, ALPHA, AA, LDA, BB, LDB )
1099 ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
1100 IF( TRACE )
1101 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1102 $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
1103 $ LDA, LDB
1104 IF( REWI )
1105 $ REWIND NTRA
1106 CALL DTRSM( SIDE, UPLO, TRANSA, DIAG, M,
1107 $ N, ALPHA, AA, LDA, BB, LDB )
1108 END IF
1109*
1110* Check if error-exit was taken incorrectly.
1111*
1112 IF( .NOT.OK )THEN
1113 WRITE( NOUT, FMT = 9994 )
1114 FATAL = .TRUE.
1115 GO TO 150
1116 END IF
1117*
1118* See what data changed inside subroutines.
1119*
1120 ISAME( 1 ) = SIDES.EQ.SIDE
1121 ISAME( 2 ) = UPLOS.EQ.UPLO
1122 ISAME( 3 ) = TRANAS.EQ.TRANSA
1123 ISAME( 4 ) = DIAGS.EQ.DIAG
1124 ISAME( 5 ) = MS.EQ.M
1125 ISAME( 6 ) = NS.EQ.N
1126 ISAME( 7 ) = ALS.EQ.ALPHA
1127 ISAME( 8 ) = LDE( AS, AA, LAA )
1128 ISAME( 9 ) = LDAS.EQ.LDA
1129 IF( NULL )THEN
1130 ISAME( 10 ) = LDE( BS, BB, LBB )
1131 ELSE
1132 ISAME( 10 ) = LDERES( 'GE', ' ', M, N, BS,
1133 $ BB, LDB )
1134 END IF
1135 ISAME( 11 ) = LDBS.EQ.LDB
1136*
1137* If data was incorrectly changed, report and
1138* return.
1139*
1140 SAME = .TRUE.
1141 DO 50 I = 1, NARGS
1142 SAME = SAME.AND.ISAME( I )
1143 IF( .NOT.ISAME( I ) )
1144 $ WRITE( NOUT, FMT = 9998 )I
1145 50 CONTINUE
1146 IF( .NOT.SAME )THEN
1147 FATAL = .TRUE.
1148 GO TO 150
1149 END IF
1150*
1151 IF( .NOT.NULL )THEN
1152 IF( SNAME( 4: 5 ).EQ.'MM' )THEN
1153*
1154* Check the result.
1155*
1156 IF( LEFT )THEN
1157 CALL DMMCH( TRANSA, 'N', M, N, M,
1158 $ ALPHA, A, NMAX, B, NMAX,
1159 $ ZERO, C, NMAX, CT, G,
1160 $ BB, LDB, EPS, ERR,
1161 $ FATAL, NOUT, .TRUE. )
1162 ELSE
1163 CALL DMMCH( 'N', TRANSA, M, N, N,
1164 $ ALPHA, B, NMAX, A, NMAX,
1165 $ ZERO, C, NMAX, CT, G,
1166 $ BB, LDB, EPS, ERR,
1167 $ FATAL, NOUT, .TRUE. )
1168 END IF
1169 ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
1170*
1171* Compute approximation to original
1172* matrix.
1173*
1174 DO 70 J = 1, N
1175 DO 60 I = 1, M
1176 C( I, J ) = BB( I + ( J - 1 )*
1177 $ LDB )
1178 BB( I + ( J - 1 )*LDB ) = ALPHA*
1179 $ B( I, J )
1180 60 CONTINUE
1181 70 CONTINUE
1182*
1183 IF( LEFT )THEN
1184 CALL DMMCH( TRANSA, 'N', M, N, M,
1185 $ ONE, A, NMAX, C, NMAX,
1186 $ ZERO, B, NMAX, CT, G,
1187 $ BB, LDB, EPS, ERR,
1188 $ FATAL, NOUT, .FALSE. )
1189 ELSE
1190 CALL DMMCH( 'N', TRANSA, M, N, N,
1191 $ ONE, C, NMAX, A, NMAX,
1192 $ ZERO, B, NMAX, CT, G,
1193 $ BB, LDB, EPS, ERR,
1194 $ FATAL, NOUT, .FALSE. )
1195 END IF
1196 END IF
1197 ERRMAX = MAX( ERRMAX, ERR )
1198* If got really bad answer, report and
1199* return.
1200 IF( FATAL )
1201 $ GO TO 150
1202 END IF
1203*
1204 80 CONTINUE
1205*
1206 90 CONTINUE
1207*
1208 100 CONTINUE
1209*
1210 110 CONTINUE
1211*
1212 120 CONTINUE
1213*
1214 130 CONTINUE
1215*
1216 140 CONTINUE
1217*
1218* Report result.
1219*
1220 IF( ERRMAX.LT.THRESH )THEN
1221 WRITE( NOUT, FMT = 9999 )SNAME, NC
1222 ELSE
1223 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1224 END IF
1225 GO TO 160
1226*
1227 150 CONTINUE
1228 WRITE( NOUT, FMT = 9996 )SNAME
1229 WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M,
1230 $ N, ALPHA, LDA, LDB
1231*
1232 160 CONTINUE
1233 RETURN
1234*
1235 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1236 $ 'S)' )
1237 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1238 $ 'ANGED INCORRECTLY *******' )
1239 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1240 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1241 $ ' - SUSPECT *******' )
1242 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1243 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ),
1244 $ F4.1, ', A,', I3, ', B,', I3, ') .' )
1245 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1246 $ '******' )
1247*
1248* End of DCHK3.
1249*
1250 END
1251 SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1252 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1253 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
1254*
1255* Tests DSYRK.
1256*
1257* Auxiliary routine for test program for Level 3 Blas.
1258*
1259* -- Written on 8-February-1989.
1260* Jack Dongarra, Argonne National Laboratory.
1261* Iain Duff, AERE Harwell.
1262* Jeremy Du Croz, Numerical Algorithms Group Ltd.
1263* Sven Hammarling, Numerical Algorithms Group Ltd.
1264*
1265* .. Parameters ..
1266 DOUBLE PRECISION ZERO
1267 PARAMETER ( ZERO = 0.0D0 )
1268* .. Scalar Arguments ..
1269 DOUBLE PRECISION EPS, THRESH
1270 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1271 LOGICAL FATAL, REWI, TRACE
1272 CHARACTER*6 SNAME
1273* .. Array Arguments ..
1274 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1275 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
1276 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
1277 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
1278 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
1279 INTEGER IDIM( NIDIM )
1280* .. Local Scalars ..
1281 DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1282 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
1283 $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
1284 $ NARGS, NC, NS
1285 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1286 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1287 CHARACTER*2 ICHU
1288 CHARACTER*3 ICHT
1289* .. Local Arrays ..
1290 LOGICAL ISAME( 13 )
1291* .. External Functions ..
1292 LOGICAL LDE, LDERES
1293 EXTERNAL LDE, LDERES
1294* .. External Subroutines ..
1295 EXTERNAL DMAKE, DMMCH, DSYRK
1296* .. Intrinsic Functions ..
1297 INTRINSIC MAX
1298* .. Scalars in Common ..
1299 INTEGER INFOT, NOUTC
1300 LOGICAL LERR, OK
1301* .. Common blocks ..
1302 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1303* .. Data statements ..
1304 DATA ICHT/'NTC'/, ICHU/'UL'/
1305* .. Executable Statements ..
1306*
1307 NARGS = 10
1308 NC = 0
1309 RESET = .TRUE.
1310 ERRMAX = ZERO
1311*
1312 DO 100 IN = 1, NIDIM
1313 N = IDIM( IN )
1314* Set LDC to 1 more than minimum value if room.
1315 LDC = N
1316 IF( LDC.LT.NMAX )
1317 $ LDC = LDC + 1
1318* Skip tests if not enough room.
1319 IF( LDC.GT.NMAX )
1320 $ GO TO 100
1321 LCC = LDC*N
1322 NULL = N.LE.0
1323*
1324 DO 90 IK = 1, NIDIM
1325 K = IDIM( IK )
1326*
1327 DO 80 ICT = 1, 3
1328 TRANS = ICHT( ICT: ICT )
1329 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
1330 IF( TRAN )THEN
1331 MA = K
1332 NA = N
1333 ELSE
1334 MA = N
1335 NA = K
1336 END IF
1337* Set LDA to 1 more than minimum value if room.
1338 LDA = MA
1339 IF( LDA.LT.NMAX )
1340 $ LDA = LDA + 1
1341* Skip tests if not enough room.
1342 IF( LDA.GT.NMAX )
1343 $ GO TO 80
1344 LAA = LDA*NA
1345*
1346* Generate the matrix A.
1347*
1348 CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
1349 $ RESET, ZERO )
1350*
1351 DO 70 ICU = 1, 2
1352 UPLO = ICHU( ICU: ICU )
1353 UPPER = UPLO.EQ.'U'
1354*
1355 DO 60 IA = 1, NALF
1356 ALPHA = ALF( IA )
1357*
1358 DO 50 IB = 1, NBET
1359 BETA = BET( IB )
1360*
1361* Generate the matrix C.
1362*
1363 CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
1364 $ LDC, RESET, ZERO )
1365*
1366 NC = NC + 1
1367*
1368* Save every datum before calling the subroutine.
1369*
1370 UPLOS = UPLO
1371 TRANSS = TRANS
1372 NS = N
1373 KS = K
1374 ALS = ALPHA
1375 DO 10 I = 1, LAA
1376 AS( I ) = AA( I )
1377 10 CONTINUE
1378 LDAS = LDA
1379 BETS = BETA
1380 DO 20 I = 1, LCC
1381 CS( I ) = CC( I )
1382 20 CONTINUE
1383 LDCS = LDC
1384*
1385* Call the subroutine.
1386*
1387 IF( TRACE )
1388 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
1389 $ TRANS, N, K, ALPHA, LDA, BETA, LDC
1390 IF( REWI )
1391 $ REWIND NTRA
1392 CALL DSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA,
1393 $ BETA, CC, LDC )
1394*
1395* Check if error-exit was taken incorrectly.
1396*
1397 IF( .NOT.OK )THEN
1398 WRITE( NOUT, FMT = 9993 )
1399 FATAL = .TRUE.
1400 GO TO 120
1401 END IF
1402*
1403* See what data changed inside subroutines.
1404*
1405 ISAME( 1 ) = UPLOS.EQ.UPLO
1406 ISAME( 2 ) = TRANSS.EQ.TRANS
1407 ISAME( 3 ) = NS.EQ.N
1408 ISAME( 4 ) = KS.EQ.K
1409 ISAME( 5 ) = ALS.EQ.ALPHA
1410 ISAME( 6 ) = LDE( AS, AA, LAA )
1411 ISAME( 7 ) = LDAS.EQ.LDA
1412 ISAME( 8 ) = BETS.EQ.BETA
1413 IF( NULL )THEN
1414 ISAME( 9 ) = LDE( CS, CC, LCC )
1415 ELSE
1416 ISAME( 9 ) = LDERES( 'SY', UPLO, N, N, CS,
1417 $ CC, LDC )
1418 END IF
1419 ISAME( 10 ) = LDCS.EQ.LDC
1420*
1421* If data was incorrectly changed, report and
1422* return.
1423*
1424 SAME = .TRUE.
1425 DO 30 I = 1, NARGS
1426 SAME = SAME.AND.ISAME( I )
1427 IF( .NOT.ISAME( I ) )
1428 $ WRITE( NOUT, FMT = 9998 )I
1429 30 CONTINUE
1430 IF( .NOT.SAME )THEN
1431 FATAL = .TRUE.
1432 GO TO 120
1433 END IF
1434*
1435 IF( .NOT.NULL )THEN
1436*
1437* Check the result column by column.
1438*
1439 JC = 1
1440 DO 40 J = 1, N
1441 IF( UPPER )THEN
1442 JJ = 1
1443 LJ = J
1444 ELSE
1445 JJ = J
1446 LJ = N - J + 1
1447 END IF
1448 IF( TRAN )THEN
1449 CALL DMMCH( 'T', 'N', LJ, 1, K, ALPHA,
1450 $ A( 1, JJ ), NMAX,
1451 $ A( 1, J ), NMAX, BETA,
1452 $ C( JJ, J ), NMAX, CT, G,
1453 $ CC( JC ), LDC, EPS, ERR,
1454 $ FATAL, NOUT, .TRUE. )
1455 ELSE
1456 CALL DMMCH( 'N', 'T', LJ, 1, K, ALPHA,
1457 $ A( JJ, 1 ), NMAX,
1458 $ A( J, 1 ), NMAX, BETA,
1459 $ C( JJ, J ), NMAX, CT, G,
1460 $ CC( JC ), LDC, EPS, ERR,
1461 $ FATAL, NOUT, .TRUE. )
1462 END IF
1463 IF( UPPER )THEN
1464 JC = JC + LDC
1465 ELSE
1466 JC = JC + LDC + 1
1467 END IF
1468 ERRMAX = MAX( ERRMAX, ERR )
1469* If got really bad answer, report and
1470* return.
1471 IF( FATAL )
1472 $ GO TO 110
1473 40 CONTINUE
1474 END IF
1475*
1476 50 CONTINUE
1477*
1478 60 CONTINUE
1479*
1480 70 CONTINUE
1481*
1482 80 CONTINUE
1483*
1484 90 CONTINUE
1485*
1486 100 CONTINUE
1487*
1488* Report result.
1489*
1490 IF( ERRMAX.LT.THRESH )THEN
1491 WRITE( NOUT, FMT = 9999 )SNAME, NC
1492 ELSE
1493 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1494 END IF
1495 GO TO 130
1496*
1497 110 CONTINUE
1498 IF( N.GT.1 )
1499 $ WRITE( NOUT, FMT = 9995 )J
1500*
1501 120 CONTINUE
1502 WRITE( NOUT, FMT = 9996 )SNAME
1503 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
1504 $ LDA, BETA, LDC
1505*
1506 130 CONTINUE
1507 RETURN
1508*
1509 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1510 $ 'S)' )
1511 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1512 $ 'ANGED INCORRECTLY *******' )
1513 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1514 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1515 $ ' - SUSPECT *******' )
1516 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1517 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
1518 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1519 $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' )
1520 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1521 $ '******' )
1522*
1523* End of DCHK4.
1524*
1525 END
1526 SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1527 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1528 $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
1529*
1530* Tests DSYR2K.
1531*
1532* Auxiliary routine for test program for Level 3 Blas.
1533*
1534* -- Written on 8-February-1989.
1535* Jack Dongarra, Argonne National Laboratory.
1536* Iain Duff, AERE Harwell.
1537* Jeremy Du Croz, Numerical Algorithms Group Ltd.
1538* Sven Hammarling, Numerical Algorithms Group Ltd.
1539*
1540* .. Parameters ..
1541 DOUBLE PRECISION ZERO
1542 PARAMETER ( ZERO = 0.0D0 )
1543* .. Scalar Arguments ..
1544 DOUBLE PRECISION EPS, THRESH
1545 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1546 LOGICAL FATAL, REWI, TRACE
1547 CHARACTER*6 SNAME
1548* .. Array Arguments ..
1549 DOUBLE PRECISION AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
1550 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
1551 $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
1552 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
1553 $ G( NMAX ), W( 2*NMAX )
1554 INTEGER IDIM( NIDIM )
1555* .. Local Scalars ..
1556 DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1557 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1558 $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
1559 $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
1560 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1561 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1562 CHARACTER*2 ICHU
1563 CHARACTER*3 ICHT
1564* .. Local Arrays ..
1565 LOGICAL ISAME( 13 )
1566* .. External Functions ..
1567 LOGICAL LDE, LDERES
1568 EXTERNAL LDE, LDERES
1569* .. External Subroutines ..
1570 EXTERNAL DMAKE, DMMCH, DSYR2K
1571* .. Intrinsic Functions ..
1572 INTRINSIC MAX
1573* .. Scalars in Common ..
1574 INTEGER INFOT, NOUTC
1575 LOGICAL LERR, OK
1576* .. Common blocks ..
1577 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1578* .. Data statements ..
1579 DATA ICHT/'NTC'/, ICHU/'UL'/
1580* .. Executable Statements ..
1581*
1582 NARGS = 12
1583 NC = 0
1584 RESET = .TRUE.
1585 ERRMAX = ZERO
1586*
1587 DO 130 IN = 1, NIDIM
1588 N = IDIM( IN )
1589* Set LDC to 1 more than minimum value if room.
1590 LDC = N
1591 IF( LDC.LT.NMAX )
1592 $ LDC = LDC + 1
1593* Skip tests if not enough room.
1594 IF( LDC.GT.NMAX )
1595 $ GO TO 130
1596 LCC = LDC*N
1597 NULL = N.LE.0
1598*
1599 DO 120 IK = 1, NIDIM
1600 K = IDIM( IK )
1601*
1602 DO 110 ICT = 1, 3
1603 TRANS = ICHT( ICT: ICT )
1604 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
1605 IF( TRAN )THEN
1606 MA = K
1607 NA = N
1608 ELSE
1609 MA = N
1610 NA = K
1611 END IF
1612* Set LDA to 1 more than minimum value if room.
1613 LDA = MA
1614 IF( LDA.LT.NMAX )
1615 $ LDA = LDA + 1
1616* Skip tests if not enough room.
1617 IF( LDA.GT.NMAX )
1618 $ GO TO 110
1619 LAA = LDA*NA
1620*
1621* Generate the matrix A.
1622*
1623 IF( TRAN )THEN
1624 CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA,
1625 $ LDA, RESET, ZERO )
1626 ELSE
1627 CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA,
1628 $ RESET, ZERO )
1629 END IF
1630*
1631* Generate the matrix B.
1632*
1633 LDB = LDA
1634 LBB = LAA
1635 IF( TRAN )THEN
1636 CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ),
1637 $ 2*NMAX, BB, LDB, RESET, ZERO )
1638 ELSE
1639 CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ),
1640 $ NMAX, BB, LDB, RESET, ZERO )
1641 END IF
1642*
1643 DO 100 ICU = 1, 2
1644 UPLO = ICHU( ICU: ICU )
1645 UPPER = UPLO.EQ.'U'
1646*
1647 DO 90 IA = 1, NALF
1648 ALPHA = ALF( IA )
1649*
1650 DO 80 IB = 1, NBET
1651 BETA = BET( IB )
1652*
1653* Generate the matrix C.
1654*
1655 CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
1656 $ LDC, RESET, ZERO )
1657*
1658 NC = NC + 1
1659*
1660* Save every datum before calling the subroutine.
1661*
1662 UPLOS = UPLO
1663 TRANSS = TRANS
1664 NS = N
1665 KS = K
1666 ALS = ALPHA
1667 DO 10 I = 1, LAA
1668 AS( I ) = AA( I )
1669 10 CONTINUE
1670 LDAS = LDA
1671 DO 20 I = 1, LBB
1672 BS( I ) = BB( I )
1673 20 CONTINUE
1674 LDBS = LDB
1675 BETS = BETA
1676 DO 30 I = 1, LCC
1677 CS( I ) = CC( I )
1678 30 CONTINUE
1679 LDCS = LDC
1680*
1681* Call the subroutine.
1682*
1683 IF( TRACE )
1684 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
1685 $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC
1686 IF( REWI )
1687 $ REWIND NTRA
1688 CALL DSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA,
1689 $ BB, LDB, BETA, CC, LDC )
1690*
1691* Check if error-exit was taken incorrectly.
1692*
1693 IF( .NOT.OK )THEN
1694 WRITE( NOUT, FMT = 9993 )
1695 FATAL = .TRUE.
1696 GO TO 150
1697 END IF
1698*
1699* See what data changed inside subroutines.
1700*
1701 ISAME( 1 ) = UPLOS.EQ.UPLO
1702 ISAME( 2 ) = TRANSS.EQ.TRANS
1703 ISAME( 3 ) = NS.EQ.N
1704 ISAME( 4 ) = KS.EQ.K
1705 ISAME( 5 ) = ALS.EQ.ALPHA
1706 ISAME( 6 ) = LDE( AS, AA, LAA )
1707 ISAME( 7 ) = LDAS.EQ.LDA
1708 ISAME( 8 ) = LDE( BS, BB, LBB )
1709 ISAME( 9 ) = LDBS.EQ.LDB
1710 ISAME( 10 ) = BETS.EQ.BETA
1711 IF( NULL )THEN
1712 ISAME( 11 ) = LDE( CS, CC, LCC )
1713 ELSE
1714 ISAME( 11 ) = LDERES( 'SY', UPLO, N, N, CS,
1715 $ CC, LDC )
1716 END IF
1717 ISAME( 12 ) = LDCS.EQ.LDC
1718*
1719* If data was incorrectly changed, report and
1720* return.
1721*
1722 SAME = .TRUE.
1723 DO 40 I = 1, NARGS
1724 SAME = SAME.AND.ISAME( I )
1725 IF( .NOT.ISAME( I ) )
1726 $ WRITE( NOUT, FMT = 9998 )I
1727 40 CONTINUE
1728 IF( .NOT.SAME )THEN
1729 FATAL = .TRUE.
1730 GO TO 150
1731 END IF
1732*
1733 IF( .NOT.NULL )THEN
1734*
1735* Check the result column by column.
1736*
1737 JJAB = 1
1738 JC = 1
1739 DO 70 J = 1, N
1740 IF( UPPER )THEN
1741 JJ = 1
1742 LJ = J
1743 ELSE
1744 JJ = J
1745 LJ = N - J + 1
1746 END IF
1747 IF( TRAN )THEN
1748 DO 50 I = 1, K
1749 W( I ) = AB( ( J - 1 )*2*NMAX + K +
1750 $ I )
1751 W( K + I ) = AB( ( J - 1 )*2*NMAX +
1752 $ I )
1753 50 CONTINUE
1754 CALL DMMCH( 'T', 'N', LJ, 1, 2*K,
1755 $ ALPHA, AB( JJAB ), 2*NMAX,
1756 $ W, 2*NMAX, BETA,
1757 $ C( JJ, J ), NMAX, CT, G,
1758 $ CC( JC ), LDC, EPS, ERR,
1759 $ FATAL, NOUT, .TRUE. )
1760 ELSE
1761 DO 60 I = 1, K
1762 W( I ) = AB( ( K + I - 1 )*NMAX +
1763 $ J )
1764 W( K + I ) = AB( ( I - 1 )*NMAX +
1765 $ J )
1766 60 CONTINUE
1767 CALL DMMCH( 'N', 'N', LJ, 1, 2*K,
1768 $ ALPHA, AB( JJ ), NMAX, W,
1769 $ 2*NMAX, BETA, C( JJ, J ),
1770 $ NMAX, CT, G, CC( JC ), LDC,
1771 $ EPS, ERR, FATAL, NOUT,
1772 $ .TRUE. )
1773 END IF
1774 IF( UPPER )THEN
1775 JC = JC + LDC
1776 ELSE
1777 JC = JC + LDC + 1
1778 IF( TRAN )
1779 $ JJAB = JJAB + 2*NMAX
1780 END IF
1781 ERRMAX = MAX( ERRMAX, ERR )
1782* If got really bad answer, report and
1783* return.
1784 IF( FATAL )
1785 $ GO TO 140
1786 70 CONTINUE
1787 END IF
1788*
1789 80 CONTINUE
1790*
1791 90 CONTINUE
1792*
1793 100 CONTINUE
1794*
1795 110 CONTINUE
1796*
1797 120 CONTINUE
1798*
1799 130 CONTINUE
1800*
1801* Report result.
1802*
1803 IF( ERRMAX.LT.THRESH )THEN
1804 WRITE( NOUT, FMT = 9999 )SNAME, NC
1805 ELSE
1806 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1807 END IF
1808 GO TO 160
1809*
1810 140 CONTINUE
1811 IF( N.GT.1 )
1812 $ WRITE( NOUT, FMT = 9995 )J
1813*
1814 150 CONTINUE
1815 WRITE( NOUT, FMT = 9996 )SNAME
1816 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
1817 $ LDA, LDB, BETA, LDC
1818*
1819 160 CONTINUE
1820 RETURN
1821*
1822 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1823 $ 'S)' )
1824 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1825 $ 'ANGED INCORRECTLY *******' )
1826 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1827 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1828 $ ' - SUSPECT *******' )
1829 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1830 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
1831 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1832 $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
1833 $ ' .' )
1834 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1835 $ '******' )
1836*
1837* End of DCHK5.
1838*
1839 END
1840 SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT )
1841*
1842* Tests the error exits from the Level 3 Blas.
1843* Requires a special version of the error-handling routine XERBLA.
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]1844* A, B and C should not need to be defined.
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]1845*
1846* Auxiliary routine for test program for Level 3 Blas.
1847*
1848* -- Written on 8-February-1989.
1849* Jack Dongarra, Argonne National Laboratory.
1850* Iain Duff, AERE Harwell.
1851* Jeremy Du Croz, Numerical Algorithms Group Ltd.
1852* Sven Hammarling, Numerical Algorithms Group Ltd.
1853*
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]1854* 3-19-92: Initialize ALPHA and BETA (eca)
1855* 3-19-92: Fix argument 12 in calls to SSYMM with INFOT = 9 (eca)
1856*
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]1857* .. Scalar Arguments ..
1858 INTEGER ISNUM, NOUT
1859 CHARACTER*6 SRNAMT
1860* .. Scalars in Common ..
1861 INTEGER INFOT, NOUTC
1862 LOGICAL LERR, OK
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]1863* .. Parameters ..
1864 DOUBLE PRECISION ONE, TWO
1865 PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 )
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]1866* .. Local Scalars ..
1867 DOUBLE PRECISION ALPHA, BETA
1868* .. Local Arrays ..
1869 DOUBLE PRECISION A( 2, 1 ), B( 2, 1 ), C( 2, 1 )
1870* .. External Subroutines ..
1871 EXTERNAL CHKXER, DGEMM, DSYMM, DSYR2K, DSYRK, DTRMM,
1872 $ DTRSM
1873* .. Common blocks ..
1874 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1875* .. Executable Statements ..
1876* OK is set to .FALSE. by the special version of XERBLA or by CHKXER
1877* if anything is wrong.
1878 OK = .TRUE.
1879* LERR is set to .TRUE. by the special version of XERBLA each time
1880* it is called, and is then tested and re-set by CHKXER.
1881 LERR = .FALSE.
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]1882*
1883* Initialize ALPHA and BETA.
1884*
1885 ALPHA = ONE
1886 BETA = TWO
1887*
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]1888 GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM
1889 10 INFOT = 1
1890 CALL DGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1891 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1892 INFOT = 1
1893 CALL DGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1894 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1895 INFOT = 2
1896 CALL DGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1897 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1898 INFOT = 2
1899 CALL DGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1900 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1901 INFOT = 3
1902 CALL DGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1903 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1904 INFOT = 3
1905 CALL DGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1906 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1907 INFOT = 3
1908 CALL DGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1909 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1910 INFOT = 3
1911 CALL DGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1912 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1913 INFOT = 4
1914 CALL DGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1915 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1916 INFOT = 4
1917 CALL DGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1918 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1919 INFOT = 4
1920 CALL DGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1921 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1922 INFOT = 4
1923 CALL DGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1924 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1925 INFOT = 5
1926 CALL DGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
1927 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1928 INFOT = 5
1929 CALL DGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
1930 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1931 INFOT = 5
1932 CALL DGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
1933 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1934 INFOT = 5
1935 CALL DGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
1936 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1937 INFOT = 8
1938 CALL DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
1939 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1940 INFOT = 8
1941 CALL DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
1942 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1943 INFOT = 8
1944 CALL DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 )
1945 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1946 INFOT = 8
1947 CALL DGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
1948 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1949 INFOT = 10
1950 CALL DGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
1951 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1952 INFOT = 10
1953 CALL DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
1954 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1955 INFOT = 10
1956 CALL DGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1957 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1958 INFOT = 10
1959 CALL DGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1960 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1961 INFOT = 13
1962 CALL DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
1963 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1964 INFOT = 13
1965 CALL DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
1966 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1967 INFOT = 13
1968 CALL DGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1969 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1970 INFOT = 13
1971 CALL DGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1972 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1973 GO TO 70
1974 20 INFOT = 1
1975 CALL DSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1976 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1977 INFOT = 2
1978 CALL DSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1979 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1980 INFOT = 3
1981 CALL DSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1982 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1983 INFOT = 3
1984 CALL DSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1985 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1986 INFOT = 3
1987 CALL DSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1988 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1989 INFOT = 3
1990 CALL DSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1991 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1992 INFOT = 4
1993 CALL DSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
1994 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1995 INFOT = 4
1996 CALL DSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
1997 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1998 INFOT = 4
1999 CALL DSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2000 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2001 INFOT = 4
2002 CALL DSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2003 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2004 INFOT = 7
2005 CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
2006 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2007 INFOT = 7
2008 CALL DSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2009 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2010 INFOT = 7
2011 CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
2012 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2013 INFOT = 7
2014 CALL DSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2015 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2016 INFOT = 9
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]2017 CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]2018 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2019 INFOT = 9
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]2020 CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]2021 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2022 INFOT = 9
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]2023 CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]2024 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2025 INFOT = 9
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]2026 CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]2027 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2028 INFOT = 12
2029 CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2030 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2031 INFOT = 12
2032 CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
2033 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2034 INFOT = 12
2035 CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2036 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2037 INFOT = 12
2038 CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
2039 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2040 GO TO 70
2041 30 INFOT = 1
2042 CALL DTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2043 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2044 INFOT = 2
2045 CALL DTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2046 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2047 INFOT = 3
2048 CALL DTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2049 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2050 INFOT = 4
2051 CALL DTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
2052 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2053 INFOT = 5
2054 CALL DTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2055 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2056 INFOT = 5
2057 CALL DTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2058 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2059 INFOT = 5
2060 CALL DTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2061 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2062 INFOT = 5
2063 CALL DTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2064 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2065 INFOT = 5
2066 CALL DTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2067 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2068 INFOT = 5
2069 CALL DTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2070 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2071 INFOT = 5
2072 CALL DTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2073 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2074 INFOT = 5
2075 CALL DTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2076 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2077 INFOT = 6
2078 CALL DTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2079 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2080 INFOT = 6
2081 CALL DTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2082 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2083 INFOT = 6
2084 CALL DTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2085 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2086 INFOT = 6
2087 CALL DTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2088 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2089 INFOT = 6
2090 CALL DTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2091 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2092 INFOT = 6
2093 CALL DTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2094 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2095 INFOT = 6
2096 CALL DTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2097 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2098 INFOT = 6
2099 CALL DTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2100 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2101 INFOT = 9
2102 CALL DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2103 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2104 INFOT = 9
2105 CALL DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2106 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2107 INFOT = 9
2108 CALL DTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2109 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2110 INFOT = 9
2111 CALL DTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2112 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2113 INFOT = 9
2114 CALL DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2115 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2116 INFOT = 9
2117 CALL DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2118 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2119 INFOT = 9
2120 CALL DTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2121 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2122 INFOT = 9
2123 CALL DTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2124 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2125 INFOT = 11
2126 CALL DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2127 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2128 INFOT = 11
2129 CALL DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2130 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2131 INFOT = 11
2132 CALL DTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2133 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2134 INFOT = 11
2135 CALL DTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2136 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2137 INFOT = 11
2138 CALL DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2139 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2140 INFOT = 11
2141 CALL DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2142 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2143 INFOT = 11
2144 CALL DTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2145 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2146 INFOT = 11
2147 CALL DTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2148 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2149 GO TO 70
2150 40 INFOT = 1
2151 CALL DTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2152 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2153 INFOT = 2
2154 CALL DTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2155 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2156 INFOT = 3
2157 CALL DTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2158 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2159 INFOT = 4
2160 CALL DTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
2161 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2162 INFOT = 5
2163 CALL DTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2164 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2165 INFOT = 5
2166 CALL DTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2167 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2168 INFOT = 5
2169 CALL DTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2170 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2171 INFOT = 5
2172 CALL DTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2173 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2174 INFOT = 5
2175 CALL DTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2176 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2177 INFOT = 5
2178 CALL DTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2179 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2180 INFOT = 5
2181 CALL DTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2182 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2183 INFOT = 5
2184 CALL DTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2185 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2186 INFOT = 6
2187 CALL DTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2188 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2189 INFOT = 6
2190 CALL DTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2191 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2192 INFOT = 6
2193 CALL DTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2194 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2195 INFOT = 6
2196 CALL DTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2197 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2198 INFOT = 6
2199 CALL DTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2200 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2201 INFOT = 6
2202 CALL DTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2203 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2204 INFOT = 6
2205 CALL DTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2206 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2207 INFOT = 6
2208 CALL DTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2209 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2210 INFOT = 9
2211 CALL DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2212 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2213 INFOT = 9
2214 CALL DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2215 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2216 INFOT = 9
2217 CALL DTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2218 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2219 INFOT = 9
2220 CALL DTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2221 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2222 INFOT = 9
2223 CALL DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2224 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2225 INFOT = 9
2226 CALL DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2227 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2228 INFOT = 9
2229 CALL DTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2230 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2231 INFOT = 9
2232 CALL DTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2233 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2234 INFOT = 11
2235 CALL DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2236 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2237 INFOT = 11
2238 CALL DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2239 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2240 INFOT = 11
2241 CALL DTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2242 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2243 INFOT = 11
2244 CALL DTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2245 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2246 INFOT = 11
2247 CALL DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2248 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2249 INFOT = 11
2250 CALL DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2251 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2252 INFOT = 11
2253 CALL DTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2254 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2255 INFOT = 11
2256 CALL DTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2257 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2258 GO TO 70
2259 50 INFOT = 1
2260 CALL DSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 )
2261 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2262 INFOT = 2
2263 CALL DSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 )
2264 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2265 INFOT = 3
2266 CALL DSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2267 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2268 INFOT = 3
2269 CALL DSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2270 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2271 INFOT = 3
2272 CALL DSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2273 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2274 INFOT = 3
2275 CALL DSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2276 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2277 INFOT = 4
2278 CALL DSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2279 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2280 INFOT = 4
2281 CALL DSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2282 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2283 INFOT = 4
2284 CALL DSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2285 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2286 INFOT = 4
2287 CALL DSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2288 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2289 INFOT = 7
2290 CALL DSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
2291 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2292 INFOT = 7
2293 CALL DSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
2294 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2295 INFOT = 7
2296 CALL DSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
2297 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2298 INFOT = 7
2299 CALL DSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
2300 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2301 INFOT = 10
2302 CALL DSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
2303 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2304 INFOT = 10
2305 CALL DSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
2306 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2307 INFOT = 10
2308 CALL DSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
2309 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2310 INFOT = 10
2311 CALL DSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
2312 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2313 GO TO 70
2314 60 INFOT = 1
2315 CALL DSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2316 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2317 INFOT = 2
2318 CALL DSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2319 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2320 INFOT = 3
2321 CALL DSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2322 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2323 INFOT = 3
2324 CALL DSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2325 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2326 INFOT = 3
2327 CALL DSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2328 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2329 INFOT = 3
2330 CALL DSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2331 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2332 INFOT = 4
2333 CALL DSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2334 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2335 INFOT = 4
2336 CALL DSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2337 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2338 INFOT = 4
2339 CALL DSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2340 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2341 INFOT = 4
2342 CALL DSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2343 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2344 INFOT = 7
2345 CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
2346 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2347 INFOT = 7
2348 CALL DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2349 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2350 INFOT = 7
2351 CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
2352 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2353 INFOT = 7
2354 CALL DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2355 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2356 INFOT = 9
2357 CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
2358 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2359 INFOT = 9
2360 CALL DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
2361 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2362 INFOT = 9
2363 CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
2364 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2365 INFOT = 9
2366 CALL DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
2367 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2368 INFOT = 12
2369 CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2370 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2371 INFOT = 12
2372 CALL DSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2373 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2374 INFOT = 12
2375 CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2376 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2377 INFOT = 12
2378 CALL DSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2379 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2380*
2381 70 IF( OK )THEN
2382 WRITE( NOUT, FMT = 9999 )SRNAMT
2383 ELSE
2384 WRITE( NOUT, FMT = 9998 )SRNAMT
2385 END IF
2386 RETURN
2387*
2388 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
2389 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
2390 $ '**' )
2391*
2392* End of DCHKE.
2393*
2394 END
2395 SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
2396 $ TRANSL )
2397*
2398* Generates values for an M by N matrix A.
2399* Stores the values in the array AA in the data structure required
2400* by the routine, with unwanted elements set to rogue value.
2401*
2402* TYPE is 'GE', 'SY' or 'TR'.
2403*
2404* Auxiliary routine for test program for Level 3 Blas.
2405*
2406* -- Written on 8-February-1989.
2407* Jack Dongarra, Argonne National Laboratory.
2408* Iain Duff, AERE Harwell.
2409* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2410* Sven Hammarling, Numerical Algorithms Group Ltd.
2411*
2412* .. Parameters ..
2413 DOUBLE PRECISION ZERO, ONE
2414 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
2415 DOUBLE PRECISION ROGUE
2416 PARAMETER ( ROGUE = -1.0D10 )
2417* .. Scalar Arguments ..
2418 DOUBLE PRECISION TRANSL
2419 INTEGER LDA, M, N, NMAX
2420 LOGICAL RESET
2421 CHARACTER*1 DIAG, UPLO
2422 CHARACTER*2 TYPE
2423* .. Array Arguments ..
2424 DOUBLE PRECISION A( NMAX, * ), AA( * )
2425* .. Local Scalars ..
2426 INTEGER I, IBEG, IEND, J
2427 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2428* .. External Functions ..
2429 DOUBLE PRECISION DBEG
2430 EXTERNAL DBEG
2431* .. Executable Statements ..
2432 GEN = TYPE.EQ.'GE'
2433 SYM = TYPE.EQ.'SY'
2434 TRI = TYPE.EQ.'TR'
2435 UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
2436 LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
2437 UNIT = TRI.AND.DIAG.EQ.'U'
2438*
2439* Generate data in array A.
2440*
2441 DO 20 J = 1, N
2442 DO 10 I = 1, M
2443 IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
2444 $ THEN
2445 A( I, J ) = DBEG( RESET ) + TRANSL
2446 IF( I.NE.J )THEN
2447* Set some elements to zero
2448 IF( N.GT.3.AND.J.EQ.N/2 )
2449 $ A( I, J ) = ZERO
2450 IF( SYM )THEN
2451 A( J, I ) = A( I, J )
2452 ELSE IF( TRI )THEN
2453 A( J, I ) = ZERO
2454 END IF
2455 END IF
2456 END IF
2457 10 CONTINUE
2458 IF( TRI )
2459 $ A( J, J ) = A( J, J ) + ONE
2460 IF( UNIT )
2461 $ A( J, J ) = ONE
2462 20 CONTINUE
2463*
2464* Store elements in array AS in data structure required by routine.
2465*
2466 IF( TYPE.EQ.'GE' )THEN
2467 DO 50 J = 1, N
2468 DO 30 I = 1, M
2469 AA( I + ( J - 1 )*LDA ) = A( I, J )
2470 30 CONTINUE
2471 DO 40 I = M + 1, LDA
2472 AA( I + ( J - 1 )*LDA ) = ROGUE
2473 40 CONTINUE
2474 50 CONTINUE
2475 ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
2476 DO 90 J = 1, N
2477 IF( UPPER )THEN
2478 IBEG = 1
2479 IF( UNIT )THEN
2480 IEND = J - 1
2481 ELSE
2482 IEND = J
2483 END IF
2484 ELSE
2485 IF( UNIT )THEN
2486 IBEG = J + 1
2487 ELSE
2488 IBEG = J
2489 END IF
2490 IEND = N
2491 END IF
2492 DO 60 I = 1, IBEG - 1
2493 AA( I + ( J - 1 )*LDA ) = ROGUE
2494 60 CONTINUE
2495 DO 70 I = IBEG, IEND
2496 AA( I + ( J - 1 )*LDA ) = A( I, J )
2497 70 CONTINUE
2498 DO 80 I = IEND + 1, LDA
2499 AA( I + ( J - 1 )*LDA ) = ROGUE
2500 80 CONTINUE
2501 90 CONTINUE
2502 END IF
2503 RETURN
2504*
2505* End of DMAKE.
2506*
2507 END
2508 SUBROUTINE DMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
2509 $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
2510 $ NOUT, MV )
2511*
2512* Checks the results of the computational tests.
2513*
2514* Auxiliary routine for test program for Level 3 Blas.
2515*
2516* -- Written on 8-February-1989.
2517* Jack Dongarra, Argonne National Laboratory.
2518* Iain Duff, AERE Harwell.
2519* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2520* Sven Hammarling, Numerical Algorithms Group Ltd.
2521*
2522* .. Parameters ..
2523 DOUBLE PRECISION ZERO, ONE
2524 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
2525* .. Scalar Arguments ..
2526 DOUBLE PRECISION ALPHA, BETA, EPS, ERR
2527 INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
2528 LOGICAL FATAL, MV
2529 CHARACTER*1 TRANSA, TRANSB
2530* .. Array Arguments ..
2531 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
2532 $ CC( LDCC, * ), CT( * ), G( * )
2533* .. Local Scalars ..
2534 DOUBLE PRECISION ERRI
2535 INTEGER I, J, K
2536 LOGICAL TRANA, TRANB
2537* .. Intrinsic Functions ..
2538 INTRINSIC ABS, MAX, SQRT
2539* .. Executable Statements ..
2540 TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
2541 TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
2542*
2543* Compute expected result, one column at a time, in CT using data
2544* in A, B and C.
2545* Compute gauges in G.
2546*
2547 DO 120 J = 1, N
2548*
2549 DO 10 I = 1, M
2550 CT( I ) = ZERO
2551 G( I ) = ZERO
2552 10 CONTINUE
2553 IF( .NOT.TRANA.AND..NOT.TRANB )THEN
2554 DO 30 K = 1, KK
2555 DO 20 I = 1, M
2556 CT( I ) = CT( I ) + A( I, K )*B( K, J )
2557 G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) )
2558 20 CONTINUE
2559 30 CONTINUE
2560 ELSE IF( TRANA.AND..NOT.TRANB )THEN
2561 DO 50 K = 1, KK
2562 DO 40 I = 1, M
2563 CT( I ) = CT( I ) + A( K, I )*B( K, J )
2564 G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) )
2565 40 CONTINUE
2566 50 CONTINUE
2567 ELSE IF( .NOT.TRANA.AND.TRANB )THEN
2568 DO 70 K = 1, KK
2569 DO 60 I = 1, M
2570 CT( I ) = CT( I ) + A( I, K )*B( J, K )
2571 G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) )
2572 60 CONTINUE
2573 70 CONTINUE
2574 ELSE IF( TRANA.AND.TRANB )THEN
2575 DO 90 K = 1, KK
2576 DO 80 I = 1, M
2577 CT( I ) = CT( I ) + A( K, I )*B( J, K )
2578 G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) )
2579 80 CONTINUE
2580 90 CONTINUE
2581 END IF
2582 DO 100 I = 1, M
2583 CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
2584 G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) )
2585 100 CONTINUE
2586*
2587* Compute the error ratio for this result.
2588*
2589 ERR = ZERO
2590 DO 110 I = 1, M
2591 ERRI = ABS( CT( I ) - CC( I, J ) )/EPS
2592 IF( G( I ).NE.ZERO )
2593 $ ERRI = ERRI/G( I )
2594 ERR = MAX( ERR, ERRI )
2595 IF( ERR*SQRT( EPS ).GE.ONE )
2596 $ GO TO 130
2597 110 CONTINUE
2598*
2599 120 CONTINUE
2600*
2601* If the loop completes, all results are at least half accurate.
2602 GO TO 150
2603*
2604* Report fatal error.
2605*
2606 130 FATAL = .TRUE.
2607 WRITE( NOUT, FMT = 9999 )
2608 DO 140 I = 1, M
2609 IF( MV )THEN
2610 WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
2611 ELSE
2612 WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
2613 END IF
2614 140 CONTINUE
2615 IF( N.GT.1 )
2616 $ WRITE( NOUT, FMT = 9997 )J
2617*
2618 150 CONTINUE
2619 RETURN
2620*
2621 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2622 $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
2623 $ 'TED RESULT' )
2624 9998 FORMAT( 1X, I7, 2G18.6 )
2625 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
2626*
2627* End of DMMCH.
2628*
2629 END
2630 LOGICAL FUNCTION LDE( RI, RJ, LR )
2631*
2632* Tests if two arrays are identical.
2633*
2634* Auxiliary routine for test program for Level 3 Blas.
2635*
2636* -- Written on 8-February-1989.
2637* Jack Dongarra, Argonne National Laboratory.
2638* Iain Duff, AERE Harwell.
2639* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2640* Sven Hammarling, Numerical Algorithms Group Ltd.
2641*
2642* .. Scalar Arguments ..
2643 INTEGER LR
2644* .. Array Arguments ..
2645 DOUBLE PRECISION RI( * ), RJ( * )
2646* .. Local Scalars ..
2647 INTEGER I
2648* .. Executable Statements ..
2649 DO 10 I = 1, LR
2650 IF( RI( I ).NE.RJ( I ) )
2651 $ GO TO 20
2652 10 CONTINUE
2653 LDE = .TRUE.
2654 GO TO 30
2655 20 CONTINUE
2656 LDE = .FALSE.
2657 30 RETURN
2658*
2659* End of LDE.
2660*
2661 END
2662 LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA )
2663*
2664* Tests if selected elements in two arrays are equal.
2665*
2666* TYPE is 'GE' or 'SY'.
2667*
2668* Auxiliary routine for test program for Level 3 Blas.
2669*
2670* -- Written on 8-February-1989.
2671* Jack Dongarra, Argonne National Laboratory.
2672* Iain Duff, AERE Harwell.
2673* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2674* Sven Hammarling, Numerical Algorithms Group Ltd.
2675*
2676* .. Scalar Arguments ..
2677 INTEGER LDA, M, N
2678 CHARACTER*1 UPLO
2679 CHARACTER*2 TYPE
2680* .. Array Arguments ..
2681 DOUBLE PRECISION AA( LDA, * ), AS( LDA, * )
2682* .. Local Scalars ..
2683 INTEGER I, IBEG, IEND, J
2684 LOGICAL UPPER
2685* .. Executable Statements ..
2686 UPPER = UPLO.EQ.'U'
2687 IF( TYPE.EQ.'GE' )THEN
2688 DO 20 J = 1, N
2689 DO 10 I = M + 1, LDA
2690 IF( AA( I, J ).NE.AS( I, J ) )
2691 $ GO TO 70
2692 10 CONTINUE
2693 20 CONTINUE
2694 ELSE IF( TYPE.EQ.'SY' )THEN
2695 DO 50 J = 1, N
2696 IF( UPPER )THEN
2697 IBEG = 1
2698 IEND = J
2699 ELSE
2700 IBEG = J
2701 IEND = N
2702 END IF
2703 DO 30 I = 1, IBEG - 1
2704 IF( AA( I, J ).NE.AS( I, J ) )
2705 $ GO TO 70
2706 30 CONTINUE
2707 DO 40 I = IEND + 1, LDA
2708 IF( AA( I, J ).NE.AS( I, J ) )
2709 $ GO TO 70
2710 40 CONTINUE
2711 50 CONTINUE
2712 END IF
2713*
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]2714 LDERES = .TRUE.
2715 GO TO 80
2716 70 CONTINUE
2717 LDERES = .FALSE.
2718 80 RETURN
2719*
2720* End of LDERES.
2721*
2722 END
2723 DOUBLE PRECISION FUNCTION DBEG( RESET )
2724*
2725* Generates random numbers uniformly distributed between -0.5 and 0.5.
2726*
2727* Auxiliary routine for test program for Level 3 Blas.
2728*
2729* -- Written on 8-February-1989.
2730* Jack Dongarra, Argonne National Laboratory.
2731* Iain Duff, AERE Harwell.
2732* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2733* Sven Hammarling, Numerical Algorithms Group Ltd.
2734*
2735* .. Scalar Arguments ..
2736 LOGICAL RESET
2737* .. Local Scalars ..
2738 INTEGER I, IC, MI
2739* .. Save statement ..
2740 SAVE I, IC, MI
2741* .. Executable Statements ..
2742 IF( RESET )THEN
2743* Initialize local variables.
2744 MI = 891
2745 I = 7
2746 IC = 0
2747 RESET = .FALSE.
2748 END IF
2749*
2750* The sequence of values of I is bounded between 1 and 999.
2751* If initial I = 1,2,3,6,7 or 9, the period will be 50.
2752* If initial I = 4 or 8, the period will be 25.
2753* If initial I = 5, the period will be 10.
2754* IC is used to break up the period by skipping 1 value of I in 6.
2755*
2756 IC = IC + 1
2757 10 I = I*MI
2758 I = I - 1000*( I/1000 )
2759 IF( IC.GE.5 )THEN
2760 IC = 0
2761 GO TO 10
2762 END IF
2763 DBEG = ( I - 500 )/1001.0D0
2764 RETURN
2765*
2766* End of DBEG.
2767*
2768 END
2769 DOUBLE PRECISION FUNCTION DDIFF( X, Y )
2770*
2771* Auxiliary routine for test program for Level 3 Blas.
2772*
2773* -- Written on 8-February-1989.
2774* Jack Dongarra, Argonne National Laboratory.
2775* Iain Duff, AERE Harwell.
2776* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2777* Sven Hammarling, Numerical Algorithms Group Ltd.
2778*
2779* .. Scalar Arguments ..
2780 DOUBLE PRECISION X, Y
2781* .. Executable Statements ..
2782 DDIFF = X - Y
2783 RETURN
2784*
2785* End of DDIFF.
2786*
2787 END
2788 SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2789*
2790* Tests whether XERBLA has detected an error when it should.
2791*
2792* Auxiliary routine for test program for Level 3 Blas.
2793*
2794* -- Written on 8-February-1989.
2795* Jack Dongarra, Argonne National Laboratory.
2796* Iain Duff, AERE Harwell.
2797* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2798* Sven Hammarling, Numerical Algorithms Group Ltd.
2799*
2800* .. Scalar Arguments ..
2801 INTEGER INFOT, NOUT
2802 LOGICAL LERR, OK
2803 CHARACTER*6 SRNAMT
2804* .. Executable Statements ..
2805 IF( .NOT.LERR )THEN
2806 WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
2807 OK = .FALSE.
2808 END IF
2809 LERR = .FALSE.
2810 RETURN
2811*
2812 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
2813 $ 'ETECTED BY ', A6, ' *****' )
2814*
2815* End of CHKXER.
2816*
2817 END
2818 SUBROUTINE XERBLA( SRNAME, INFO )
2819*
2820* This is a special version of XERBLA to be used only as part of
2821* the test program for testing error exits from the Level 3 BLAS
2822* routines.
2823*
2824* XERBLA is an error handler for the Level 3 BLAS routines.
2825*
2826* It is called by the Level 3 BLAS routines if an input parameter is
2827* invalid.
2828*
2829* Auxiliary routine for test program for Level 3 Blas.
2830*
2831* -- Written on 8-February-1989.
2832* Jack Dongarra, Argonne National Laboratory.
2833* Iain Duff, AERE Harwell.
2834* Jeremy Du Croz, Numerical Algorithms Group Ltd.
2835* Sven Hammarling, Numerical Algorithms Group Ltd.
2836*
2837* .. Scalar Arguments ..
2838 INTEGER INFO
2839 CHARACTER*6 SRNAME
2840* .. Scalars in Common ..
2841 INTEGER INFOT, NOUT
2842 LOGICAL LERR, OK
2843 CHARACTER*6 SRNAMT
2844* .. Common blocks ..
2845 COMMON /INFOC/INFOT, NOUT, OK, LERR
2846 COMMON /SRNAMC/SRNAMT
2847* .. Executable Statements ..
2848 LERR = .TRUE.
2849 IF( INFO.NE.INFOT )THEN
2850 IF( INFOT.NE.0 )THEN
2851 WRITE( NOUT, FMT = 9999 )INFO, INFOT
2852 ELSE
2853 WRITE( NOUT, FMT = 9997 )INFO
2854 END IF
2855 OK = .FALSE.
2856 END IF
2857 IF( SRNAME.NE.SRNAMT )THEN
2858 WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
2859 OK = .FALSE.
2860 END IF
2861 RETURN
2862*
2863 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
2864 $ ' OF ', I2, ' *******' )
2865 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
2866 $ 'AD OF ', A6, ' *******' )
2867 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,
2868 $ ' *******' )
2869*
2870* End of XERBLA
2871*
2872 END
2873