3 * Test program for the DOUBLE PRECISION Level 3 Blas.
5 * The program must be driven by a short data file. The first 14 records
6 * of the file are read using list-directed input, the last 6 records
7 * are read using the format ( A6, L2 ). An annotated example of a data
8 * file can be obtained by deleting the first 3 characters from the
10 * 'DBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE
11 * 6 UNIT NUMBER OF SUMMARY FILE
12 * 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
13 * -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
14 * F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
15 * F LOGICAL FLAG, T TO STOP ON FAILURES.
16 * T LOGICAL FLAG, T TO TEST ERROR EXITS.
17 * 16.0 THRESHOLD VALUE OF TEST RATIO
18 * 6 NUMBER OF VALUES OF N
19 * 0 1 2 3 5 9 VALUES OF N
20 * 3 NUMBER OF VALUES OF ALPHA
21 * 0.0 1.0 0.7 VALUES OF ALPHA
22 * 3 NUMBER OF VALUES OF BETA
23 * 0.0 1.0 1.3 VALUES OF BETA
24 * DGEMM T PUT F FOR NO TEST. SAME COLUMNS.
25 * DSYMM T PUT F FOR NO TEST. SAME COLUMNS.
26 * DTRMM T PUT F FOR NO TEST. SAME COLUMNS.
27 * DTRSM T PUT F FOR NO TEST. SAME COLUMNS.
28 * DSYRK T PUT F FOR NO TEST. SAME COLUMNS.
29 * DSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
33 * Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
34 * A Set of Level 3 Basic Linear Algebra Subprograms.
36 * Technical Memorandum No.88 (Revision 1), Mathematics and
37 * Computer Science Division, Argonne National Laboratory, 9700
38 * South Cass Avenue, Argonne, Illinois 60439, US.
40 * -- Written on 8-February-1989.
41 * Jack Dongarra, Argonne National Laboratory.
42 * Iain Duff, AERE Harwell.
43 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
44 * Sven Hammarling, Numerical Algorithms Group Ltd.
50 PARAMETER ( NSUBS = 6 )
51 DOUBLE PRECISION ZERO, HALF, ONE
52 PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
54 PARAMETER ( NMAX = 65 )
55 INTEGER NIDMAX, NALMAX, NBEMAX
56 PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 )
58 DOUBLE PRECISION EPS, ERR, THRESH
59 INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA
60 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
62 CHARACTER*1 TRANSA, TRANSB
64 CHARACTER*32 SNAPS, SUMMRY
66 DOUBLE PRECISION AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ),
67 $ ALF( NALMAX ), AS( NMAX*NMAX ),
68 $ BB( NMAX*NMAX ), BET( NBEMAX ),
69 $ BS( NMAX*NMAX ), C( NMAX, NMAX ),
70 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
71 $ G( NMAX ), W( 2*NMAX )
72 INTEGER IDIM( NIDMAX )
73 LOGICAL LTEST( NSUBS )
74 CHARACTER*6 SNAMES( NSUBS )
75 * .. External Functions ..
76 DOUBLE PRECISION DDIFF
79 * .. External Subroutines ..
80 EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHKE, DMMCH
81 * .. Intrinsic Functions ..
83 * .. Scalars in Common ..
88 COMMON /INFOC/INFOT, NOUTC, OK, LERR
90 * .. Data statements ..
91 DATA SNAMES/'DGEMM ', 'DSYMM ', 'DTRMM ', 'DTRSM ',
93 * .. Executable Statements ..
95 * Read name and unit number for summary output file and open file.
97 READ( NIN, FMT = * )SUMMRY
98 READ( NIN, FMT = * )NOUT
99 OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
102 * Read name and unit number for snapshot output file and open file.
104 READ( NIN, FMT = * )SNAPS
105 READ( NIN, FMT = * )NTRA
108 OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
110 * Read the flag that directs rewinding of the snapshot file.
111 READ( NIN, FMT = * )REWI
112 REWI = REWI.AND.TRACE
113 * Read the flag that directs stopping on any failure.
114 READ( NIN, FMT = * )SFATAL
115 * Read the flag that indicates whether error exits are to be tested.
116 READ( NIN, FMT = * )TSTERR
117 * Read the threshold value of the test ratio
118 READ( NIN, FMT = * )THRESH
120 * Read and check the parameter values for the tests.
123 READ( NIN, FMT = * )NIDIM
124 IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
125 WRITE( NOUT, FMT = 9997 )'N', NIDMAX
128 READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
130 IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
131 WRITE( NOUT, FMT = 9996 )NMAX
136 READ( NIN, FMT = * )NALF
137 IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
138 WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
141 READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
143 READ( NIN, FMT = * )NBET
144 IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
145 WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
148 READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
150 * Report values of parameters.
152 WRITE( NOUT, FMT = 9995 )
153 WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM )
154 WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF )
155 WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET )
156 IF( .NOT.TSTERR )THEN
157 WRITE( NOUT, FMT = * )
158 WRITE( NOUT, FMT = 9984 )
160 WRITE( NOUT, FMT = * )
161 WRITE( NOUT, FMT = 9999 )THRESH
162 WRITE( NOUT, FMT = * )
164 * Read names of subroutines and flags which indicate
165 * whether they are to be tested.
170 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT
172 IF( SNAMET.EQ.SNAMES( I ) )
175 WRITE( NOUT, FMT = 9990 )SNAMET
177 50 LTEST( I ) = LTESTT
183 * Compute EPS (the machine precision).
187 IF( DDIFF( ONE + EPS, ONE ).EQ.ZERO )
193 WRITE( NOUT, FMT = 9998 )EPS
195 * Check the reliability of DMMCH using exact data.
200 AB( I, J ) = MAX( I - J + 1, 0 )
202 AB( J, NMAX + 1 ) = J
203 AB( 1, NMAX + J ) = J
207 CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
209 * CC holds the exact result. On exit from DMMCH CT holds
210 * the result computed by DMMCH.
213 CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
214 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
215 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
216 SAME = LDE( CC, CT, N )
217 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
218 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
222 CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
223 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
224 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
225 SAME = LDE( CC, CT, N )
226 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
227 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
231 AB( J, NMAX + 1 ) = N - J + 1
232 AB( 1, NMAX + J ) = N - J + 1
235 CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 -
236 $ ( ( J + 1 )*J*( J - 1 ) )/3
240 CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
241 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
242 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
243 SAME = LDE( CC, CT, N )
244 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
245 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
249 CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
250 $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
251 $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
252 SAME = LDE( CC, CT, N )
253 IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
254 WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
258 * Test each subroutine in turn.
260 DO 200 ISNUM = 1, NSUBS
261 WRITE( NOUT, FMT = * )
262 IF( .NOT.LTEST( ISNUM ) )THEN
263 * Subprogram is not to be tested.
264 WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM )
266 SRNAMT = SNAMES( ISNUM )
269 CALL DCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
270 WRITE( NOUT, FMT = * )
276 GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM
278 140 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
279 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
280 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
284 150 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
285 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
286 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
289 * Test DTRMM, 03, DTRSM, 04.
290 160 CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
291 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
292 $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C )
295 170 CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
296 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
297 $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
301 180 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
302 $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
303 $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
306 190 IF( FATAL.AND.SFATAL )
310 WRITE( NOUT, FMT = 9986 )
314 WRITE( NOUT, FMT = 9985 )
318 WRITE( NOUT, FMT = 9991 )
326 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
328 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 )
329 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
331 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
332 9995 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 3 BLAS', //' THE F',
333 $ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
334 9994 FORMAT( ' FOR N ', 9I6 )
335 9993 FORMAT( ' FOR ALPHA ', 7F6.1 )
336 9992 FORMAT( ' FOR BETA ', 7F6.1 )
337 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
338 $ /' ******* TESTS ABANDONED *******' )
339 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
340 $ 'ESTS ABANDONED *******' )
341 9989 FORMAT( ' ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
342 $ 'ATED WRONGLY.', /' DMMCH WAS CALLED WITH TRANSA = ', A1,
343 $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ',
344 $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
345 $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
347 9988 FORMAT( A6, L2 )
348 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' )
349 9986 FORMAT( /' END OF TESTS' )
350 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
351 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
356 SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
357 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
358 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
362 * Auxiliary routine for test program for Level 3 Blas.
364 * -- Written on 8-February-1989.
365 * Jack Dongarra, Argonne National Laboratory.
366 * Iain Duff, AERE Harwell.
367 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
368 * Sven Hammarling, Numerical Algorithms Group Ltd.
371 DOUBLE PRECISION ZERO
372 PARAMETER ( ZERO = 0.0D0 )
373 * .. Scalar Arguments ..
374 DOUBLE PRECISION EPS, THRESH
375 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
376 LOGICAL FATAL, REWI, TRACE
378 * .. Array Arguments ..
379 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
380 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
381 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
382 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
383 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
384 INTEGER IDIM( NIDIM )
385 * .. Local Scalars ..
386 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX
387 INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
388 $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
389 $ MA, MB, MS, N, NA, NARGS, NB, NC, NS
390 LOGICAL NULL, RESET, SAME, TRANA, TRANB
391 CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB
395 * .. External Functions ..
398 * .. External Subroutines ..
399 EXTERNAL DGEMM, DMAKE, DMMCH
400 * .. Intrinsic Functions ..
402 * .. Scalars in Common ..
405 * .. Common blocks ..
406 COMMON /INFOC/INFOT, NOUTC, OK, LERR
407 * .. Data statements ..
409 * .. Executable Statements ..
421 * Set LDC to 1 more than minimum value if room.
425 * Skip tests if not enough room.
429 NULL = N.LE.0.OR.M.LE.0
435 TRANSA = ICH( ICA: ICA )
436 TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
445 * Set LDA to 1 more than minimum value if room.
449 * Skip tests if not enough room.
454 * Generate the matrix A.
456 CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
460 TRANSB = ICH( ICB: ICB )
461 TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
470 * Set LDB to 1 more than minimum value if room.
474 * Skip tests if not enough room.
479 * Generate the matrix B.
481 CALL DMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB,
490 * Generate the matrix C.
492 CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX,
493 $ CC, LDC, RESET, ZERO )
497 * Save every datum before calling the
520 * Call the subroutine.
523 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
524 $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB,
528 CALL DGEMM( TRANSA, TRANSB, M, N, K, ALPHA,
529 $ AA, LDA, BB, LDB, BETA, CC, LDC )
531 * Check if error-exit was taken incorrectly.
534 WRITE( NOUT, FMT = 9994 )
539 * See what data changed inside subroutines.
541 ISAME( 1 ) = TRANSA.EQ.TRANAS
542 ISAME( 2 ) = TRANSB.EQ.TRANBS
546 ISAME( 6 ) = ALS.EQ.ALPHA
547 ISAME( 7 ) = LDE( AS, AA, LAA )
548 ISAME( 8 ) = LDAS.EQ.LDA
549 ISAME( 9 ) = LDE( BS, BB, LBB )
550 ISAME( 10 ) = LDBS.EQ.LDB
551 ISAME( 11 ) = BLS.EQ.BETA
553 ISAME( 12 ) = LDE( CS, CC, LCC )
555 ISAME( 12 ) = LDERES( 'GE', ' ', M, N, CS,
558 ISAME( 13 ) = LDCS.EQ.LDC
560 * If data was incorrectly changed, report
565 SAME = SAME.AND.ISAME( I )
566 IF( .NOT.ISAME( I ) )
567 $ WRITE( NOUT, FMT = 9998 )I
578 CALL DMMCH( TRANSA, TRANSB, M, N, K,
579 $ ALPHA, A, NMAX, B, NMAX, BETA,
580 $ C, NMAX, CT, G, CC, LDC, EPS,
581 $ ERR, FATAL, NOUT, .TRUE. )
582 ERRMAX = MAX( ERRMAX, ERR )
583 * If got really bad answer, report and
605 IF( ERRMAX.LT.THRESH )THEN
606 WRITE( NOUT, FMT = 9999 )SNAME, NC
608 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
613 WRITE( NOUT, FMT = 9996 )SNAME
614 WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K,
615 $ ALPHA, LDA, LDB, BETA, LDC
620 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
622 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
623 $ 'ANGED INCORRECTLY *******' )
624 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
625 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
626 $ ' - SUSPECT *******' )
627 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
628 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',',
629 $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ',
631 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
637 SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
638 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
639 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
643 * Auxiliary routine for test program for Level 3 Blas.
645 * -- Written on 8-February-1989.
646 * Jack Dongarra, Argonne National Laboratory.
647 * Iain Duff, AERE Harwell.
648 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
649 * Sven Hammarling, Numerical Algorithms Group Ltd.
652 DOUBLE PRECISION ZERO
653 PARAMETER ( ZERO = 0.0D0 )
654 * .. Scalar Arguments ..
655 DOUBLE PRECISION EPS, THRESH
656 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
657 LOGICAL FATAL, REWI, TRACE
659 * .. Array Arguments ..
660 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
661 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
662 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
663 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
664 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
665 INTEGER IDIM( NIDIM )
666 * .. Local Scalars ..
667 DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX
668 INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
669 $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
671 LOGICAL LEFT, NULL, RESET, SAME
672 CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
673 CHARACTER*2 ICHS, ICHU
676 * .. External Functions ..
679 * .. External Subroutines ..
680 EXTERNAL DMAKE, DMMCH, DSYMM
681 * .. Intrinsic Functions ..
683 * .. Scalars in Common ..
686 * .. Common blocks ..
687 COMMON /INFOC/INFOT, NOUTC, OK, LERR
688 * .. Data statements ..
689 DATA ICHS/'LR'/, ICHU/'UL'/
690 * .. Executable Statements ..
702 * Set LDC to 1 more than minimum value if room.
706 * Skip tests if not enough room.
710 NULL = N.LE.0.OR.M.LE.0
712 * Set LDB to 1 more than minimum value if room.
716 * Skip tests if not enough room.
721 * Generate the matrix B.
723 CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET,
727 SIDE = ICHS( ICS: ICS )
735 * Set LDA to 1 more than minimum value if room.
739 * Skip tests if not enough room.
745 UPLO = ICHU( ICU: ICU )
747 * Generate the symmetric matrix A.
749 CALL DMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA,
758 * Generate the matrix C.
760 CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC,
765 * Save every datum before calling the
787 * Call the subroutine.
790 $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE,
791 $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC
794 CALL DSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA,
795 $ BB, LDB, BETA, CC, LDC )
797 * Check if error-exit was taken incorrectly.
800 WRITE( NOUT, FMT = 9994 )
805 * See what data changed inside subroutines.
807 ISAME( 1 ) = SIDES.EQ.SIDE
808 ISAME( 2 ) = UPLOS.EQ.UPLO
811 ISAME( 5 ) = ALS.EQ.ALPHA
812 ISAME( 6 ) = LDE( AS, AA, LAA )
813 ISAME( 7 ) = LDAS.EQ.LDA
814 ISAME( 8 ) = LDE( BS, BB, LBB )
815 ISAME( 9 ) = LDBS.EQ.LDB
816 ISAME( 10 ) = BLS.EQ.BETA
818 ISAME( 11 ) = LDE( CS, CC, LCC )
820 ISAME( 11 ) = LDERES( 'GE', ' ', M, N, CS,
823 ISAME( 12 ) = LDCS.EQ.LDC
825 * If data was incorrectly changed, report and
830 SAME = SAME.AND.ISAME( I )
831 IF( .NOT.ISAME( I ) )
832 $ WRITE( NOUT, FMT = 9998 )I
844 CALL DMMCH( 'N', 'N', M, N, M, ALPHA, A,
845 $ NMAX, B, NMAX, BETA, C, NMAX,
846 $ CT, G, CC, LDC, EPS, ERR,
847 $ FATAL, NOUT, .TRUE. )
849 CALL DMMCH( 'N', 'N', M, N, N, ALPHA, B,
850 $ NMAX, A, NMAX, BETA, C, NMAX,
851 $ CT, G, CC, LDC, EPS, ERR,
852 $ FATAL, NOUT, .TRUE. )
854 ERRMAX = MAX( ERRMAX, ERR )
855 * If got really bad answer, report and
875 IF( ERRMAX.LT.THRESH )THEN
876 WRITE( NOUT, FMT = 9999 )SNAME, NC
878 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
883 WRITE( NOUT, FMT = 9996 )SNAME
884 WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA,
890 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
892 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
893 $ 'ANGED INCORRECTLY *******' )
894 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
895 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
896 $ ' - SUSPECT *******' )
897 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
898 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
899 $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
901 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
907 SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
908 $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS,
909 $ B, BB, BS, CT, G, C )
911 * Tests DTRMM and DTRSM.
913 * Auxiliary routine for test program for Level 3 Blas.
915 * -- Written on 8-February-1989.
916 * Jack Dongarra, Argonne National Laboratory.
917 * Iain Duff, AERE Harwell.
918 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
919 * Sven Hammarling, Numerical Algorithms Group Ltd.
922 DOUBLE PRECISION ZERO, ONE
923 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
924 * .. Scalar Arguments ..
925 DOUBLE PRECISION EPS, THRESH
926 INTEGER NALF, NIDIM, NMAX, NOUT, NTRA
927 LOGICAL FATAL, REWI, TRACE
929 * .. Array Arguments ..
930 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
931 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
932 $ BB( NMAX*NMAX ), BS( NMAX*NMAX ),
933 $ C( NMAX, NMAX ), CT( NMAX ), G( NMAX )
934 INTEGER IDIM( NIDIM )
935 * .. Local Scalars ..
936 DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX
937 INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
938 $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC,
940 LOGICAL LEFT, NULL, RESET, SAME
941 CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
943 CHARACTER*2 ICHD, ICHS, ICHU
947 * .. External Functions ..
950 * .. External Subroutines ..
951 EXTERNAL DMAKE, DMMCH, DTRMM, DTRSM
952 * .. Intrinsic Functions ..
954 * .. Scalars in Common ..
957 * .. Common blocks ..
958 COMMON /INFOC/INFOT, NOUTC, OK, LERR
959 * .. Data statements ..
960 DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/
961 * .. Executable Statements ..
967 * Set up zero matrix for DMMCH.
979 * Set LDB to 1 more than minimum value if room.
983 * Skip tests if not enough room.
987 NULL = M.LE.0.OR.N.LE.0
990 SIDE = ICHS( ICS: ICS )
997 * Set LDA to 1 more than minimum value if room.
1001 * Skip tests if not enough room.
1007 UPLO = ICHU( ICU: ICU )
1010 TRANSA = ICHT( ICT: ICT )
1013 DIAG = ICHD( ICD: ICD )
1018 * Generate the matrix A.
1020 CALL DMAKE( 'TR', UPLO, DIAG, NA, NA, A,
1021 $ NMAX, AA, LDA, RESET, ZERO )
1023 * Generate the matrix B.
1025 CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX,
1026 $ BB, LDB, RESET, ZERO )
1030 * Save every datum before calling the
1049 * Call the subroutine.
1051 IF( SNAME( 4: 5 ).EQ.'MM' )THEN
1053 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1054 $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
1058 CALL DTRMM( SIDE, UPLO, TRANSA, DIAG, M,
1059 $ N, ALPHA, AA, LDA, BB, LDB )
1060 ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
1062 $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
1063 $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
1067 CALL DTRSM( SIDE, UPLO, TRANSA, DIAG, M,
1068 $ N, ALPHA, AA, LDA, BB, LDB )
1071 * Check if error-exit was taken incorrectly.
1074 WRITE( NOUT, FMT = 9994 )
1079 * See what data changed inside subroutines.
1081 ISAME( 1 ) = SIDES.EQ.SIDE
1082 ISAME( 2 ) = UPLOS.EQ.UPLO
1083 ISAME( 3 ) = TRANAS.EQ.TRANSA
1084 ISAME( 4 ) = DIAGS.EQ.DIAG
1085 ISAME( 5 ) = MS.EQ.M
1086 ISAME( 6 ) = NS.EQ.N
1087 ISAME( 7 ) = ALS.EQ.ALPHA
1088 ISAME( 8 ) = LDE( AS, AA, LAA )
1089 ISAME( 9 ) = LDAS.EQ.LDA
1091 ISAME( 10 ) = LDE( BS, BB, LBB )
1093 ISAME( 10 ) = LDERES( 'GE', ' ', M, N, BS,
1096 ISAME( 11 ) = LDBS.EQ.LDB
1098 * If data was incorrectly changed, report and
1103 SAME = SAME.AND.ISAME( I )
1104 IF( .NOT.ISAME( I ) )
1105 $ WRITE( NOUT, FMT = 9998 )I
1113 IF( SNAME( 4: 5 ).EQ.'MM' )THEN
1118 CALL DMMCH( TRANSA, 'N', M, N, M,
1119 $ ALPHA, A, NMAX, B, NMAX,
1120 $ ZERO, C, NMAX, CT, G,
1121 $ BB, LDB, EPS, ERR,
1122 $ FATAL, NOUT, .TRUE. )
1124 CALL DMMCH( 'N', TRANSA, M, N, N,
1125 $ ALPHA, B, NMAX, A, NMAX,
1126 $ ZERO, C, NMAX, CT, G,
1127 $ BB, LDB, EPS, ERR,
1128 $ FATAL, NOUT, .TRUE. )
1130 ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
1132 * Compute approximation to original
1137 C( I, J ) = BB( I + ( J - 1 )*
1139 BB( I + ( J - 1 )*LDB ) = ALPHA*
1145 CALL DMMCH( TRANSA, 'N', M, N, M,
1146 $ ONE, A, NMAX, C, NMAX,
1147 $ ZERO, B, NMAX, CT, G,
1148 $ BB, LDB, EPS, ERR,
1149 $ FATAL, NOUT, .FALSE. )
1151 CALL DMMCH( 'N', TRANSA, M, N, N,
1152 $ ONE, C, NMAX, A, NMAX,
1153 $ ZERO, B, NMAX, CT, G,
1154 $ BB, LDB, EPS, ERR,
1155 $ FATAL, NOUT, .FALSE. )
1158 ERRMAX = MAX( ERRMAX, ERR )
1159 * If got really bad answer, report and
1181 IF( ERRMAX.LT.THRESH )THEN
1182 WRITE( NOUT, FMT = 9999 )SNAME, NC
1184 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1189 WRITE( NOUT, FMT = 9996 )SNAME
1190 WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M,
1191 $ N, ALPHA, LDA, LDB
1196 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1198 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1199 $ 'ANGED INCORRECTLY *******' )
1200 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1201 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1202 $ ' - SUSPECT *******' )
1203 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1204 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ),
1205 $ F4.1, ', A,', I3, ', B,', I3, ') .' )
1206 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1212 SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1213 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1214 $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
1218 * Auxiliary routine for test program for Level 3 Blas.
1220 * -- Written on 8-February-1989.
1221 * Jack Dongarra, Argonne National Laboratory.
1222 * Iain Duff, AERE Harwell.
1223 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1224 * Sven Hammarling, Numerical Algorithms Group Ltd.
1227 DOUBLE PRECISION ZERO
1228 PARAMETER ( ZERO = 0.0D0 )
1229 * .. Scalar Arguments ..
1230 DOUBLE PRECISION EPS, THRESH
1231 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1232 LOGICAL FATAL, REWI, TRACE
1234 * .. Array Arguments ..
1235 DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1236 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
1237 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
1238 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
1239 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
1240 INTEGER IDIM( NIDIM )
1241 * .. Local Scalars ..
1242 DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1243 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
1244 $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
1246 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1247 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1250 * .. Local Arrays ..
1252 * .. External Functions ..
1254 EXTERNAL LDE, LDERES
1255 * .. External Subroutines ..
1256 EXTERNAL DMAKE, DMMCH, DSYRK
1257 * .. Intrinsic Functions ..
1259 * .. Scalars in Common ..
1260 INTEGER INFOT, NOUTC
1262 * .. Common blocks ..
1263 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1264 * .. Data statements ..
1265 DATA ICHT/'NTC'/, ICHU/'UL'/
1266 * .. Executable Statements ..
1273 DO 100 IN = 1, NIDIM
1275 * Set LDC to 1 more than minimum value if room.
1279 * Skip tests if not enough room.
1289 TRANS = ICHT( ICT: ICT )
1290 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
1298 * Set LDA to 1 more than minimum value if room.
1302 * Skip tests if not enough room.
1307 * Generate the matrix A.
1309 CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
1313 UPLO = ICHU( ICU: ICU )
1322 * Generate the matrix C.
1324 CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
1325 $ LDC, RESET, ZERO )
1329 * Save every datum before calling the subroutine.
1346 * Call the subroutine.
1349 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
1350 $ TRANS, N, K, ALPHA, LDA, BETA, LDC
1353 CALL DSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA,
1356 * Check if error-exit was taken incorrectly.
1359 WRITE( NOUT, FMT = 9993 )
1364 * See what data changed inside subroutines.
1366 ISAME( 1 ) = UPLOS.EQ.UPLO
1367 ISAME( 2 ) = TRANSS.EQ.TRANS
1368 ISAME( 3 ) = NS.EQ.N
1369 ISAME( 4 ) = KS.EQ.K
1370 ISAME( 5 ) = ALS.EQ.ALPHA
1371 ISAME( 6 ) = LDE( AS, AA, LAA )
1372 ISAME( 7 ) = LDAS.EQ.LDA
1373 ISAME( 8 ) = BETS.EQ.BETA
1375 ISAME( 9 ) = LDE( CS, CC, LCC )
1377 ISAME( 9 ) = LDERES( 'SY', UPLO, N, N, CS,
1380 ISAME( 10 ) = LDCS.EQ.LDC
1382 * If data was incorrectly changed, report and
1387 SAME = SAME.AND.ISAME( I )
1388 IF( .NOT.ISAME( I ) )
1389 $ WRITE( NOUT, FMT = 9998 )I
1398 * Check the result column by column.
1410 CALL DMMCH( 'T', 'N', LJ, 1, K, ALPHA,
1412 $ A( 1, J ), NMAX, BETA,
1413 $ C( JJ, J ), NMAX, CT, G,
1414 $ CC( JC ), LDC, EPS, ERR,
1415 $ FATAL, NOUT, .TRUE. )
1417 CALL DMMCH( 'N', 'T', LJ, 1, K, ALPHA,
1419 $ A( J, 1 ), NMAX, BETA,
1420 $ C( JJ, J ), NMAX, CT, G,
1421 $ CC( JC ), LDC, EPS, ERR,
1422 $ FATAL, NOUT, .TRUE. )
1429 ERRMAX = MAX( ERRMAX, ERR )
1430 * If got really bad answer, report and
1451 IF( ERRMAX.LT.THRESH )THEN
1452 WRITE( NOUT, FMT = 9999 )SNAME, NC
1454 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1460 $ WRITE( NOUT, FMT = 9995 )J
1463 WRITE( NOUT, FMT = 9996 )SNAME
1464 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
1470 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1472 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1473 $ 'ANGED INCORRECTLY *******' )
1474 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1475 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1476 $ ' - SUSPECT *******' )
1477 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1478 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
1479 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1480 $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' )
1481 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1487 SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1488 $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
1489 $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
1493 * Auxiliary routine for test program for Level 3 Blas.
1495 * -- Written on 8-February-1989.
1496 * Jack Dongarra, Argonne National Laboratory.
1497 * Iain Duff, AERE Harwell.
1498 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1499 * Sven Hammarling, Numerical Algorithms Group Ltd.
1502 DOUBLE PRECISION ZERO
1503 PARAMETER ( ZERO = 0.0D0 )
1504 * .. Scalar Arguments ..
1505 DOUBLE PRECISION EPS, THRESH
1506 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
1507 LOGICAL FATAL, REWI, TRACE
1509 * .. Array Arguments ..
1510 DOUBLE PRECISION AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
1511 $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
1512 $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
1513 $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
1514 $ G( NMAX ), W( 2*NMAX )
1515 INTEGER IDIM( NIDIM )
1516 * .. Local Scalars ..
1517 DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX
1518 INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
1519 $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
1520 $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
1521 LOGICAL NULL, RESET, SAME, TRAN, UPPER
1522 CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
1525 * .. Local Arrays ..
1527 * .. External Functions ..
1529 EXTERNAL LDE, LDERES
1530 * .. External Subroutines ..
1531 EXTERNAL DMAKE, DMMCH, DSYR2K
1532 * .. Intrinsic Functions ..
1534 * .. Scalars in Common ..
1535 INTEGER INFOT, NOUTC
1537 * .. Common blocks ..
1538 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1539 * .. Data statements ..
1540 DATA ICHT/'NTC'/, ICHU/'UL'/
1541 * .. Executable Statements ..
1548 DO 130 IN = 1, NIDIM
1550 * Set LDC to 1 more than minimum value if room.
1554 * Skip tests if not enough room.
1560 DO 120 IK = 1, NIDIM
1564 TRANS = ICHT( ICT: ICT )
1565 TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
1573 * Set LDA to 1 more than minimum value if room.
1577 * Skip tests if not enough room.
1582 * Generate the matrix A.
1585 CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA,
1586 $ LDA, RESET, ZERO )
1588 CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA,
1592 * Generate the matrix B.
1597 CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ),
1598 $ 2*NMAX, BB, LDB, RESET, ZERO )
1600 CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ),
1601 $ NMAX, BB, LDB, RESET, ZERO )
1605 UPLO = ICHU( ICU: ICU )
1614 * Generate the matrix C.
1616 CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
1617 $ LDC, RESET, ZERO )
1621 * Save every datum before calling the subroutine.
1642 * Call the subroutine.
1645 $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
1646 $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC
1649 CALL DSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA,
1650 $ BB, LDB, BETA, CC, LDC )
1652 * Check if error-exit was taken incorrectly.
1655 WRITE( NOUT, FMT = 9993 )
1660 * See what data changed inside subroutines.
1662 ISAME( 1 ) = UPLOS.EQ.UPLO
1663 ISAME( 2 ) = TRANSS.EQ.TRANS
1664 ISAME( 3 ) = NS.EQ.N
1665 ISAME( 4 ) = KS.EQ.K
1666 ISAME( 5 ) = ALS.EQ.ALPHA
1667 ISAME( 6 ) = LDE( AS, AA, LAA )
1668 ISAME( 7 ) = LDAS.EQ.LDA
1669 ISAME( 8 ) = LDE( BS, BB, LBB )
1670 ISAME( 9 ) = LDBS.EQ.LDB
1671 ISAME( 10 ) = BETS.EQ.BETA
1673 ISAME( 11 ) = LDE( CS, CC, LCC )
1675 ISAME( 11 ) = LDERES( 'SY', UPLO, N, N, CS,
1678 ISAME( 12 ) = LDCS.EQ.LDC
1680 * If data was incorrectly changed, report and
1685 SAME = SAME.AND.ISAME( I )
1686 IF( .NOT.ISAME( I ) )
1687 $ WRITE( NOUT, FMT = 9998 )I
1696 * Check the result column by column.
1710 W( I ) = AB( ( J - 1 )*2*NMAX + K +
1712 W( K + I ) = AB( ( J - 1 )*2*NMAX +
1715 CALL DMMCH( 'T', 'N', LJ, 1, 2*K,
1716 $ ALPHA, AB( JJAB ), 2*NMAX,
1718 $ C( JJ, J ), NMAX, CT, G,
1719 $ CC( JC ), LDC, EPS, ERR,
1720 $ FATAL, NOUT, .TRUE. )
1723 W( I ) = AB( ( K + I - 1 )*NMAX +
1725 W( K + I ) = AB( ( I - 1 )*NMAX +
1728 CALL DMMCH( 'N', 'N', LJ, 1, 2*K,
1729 $ ALPHA, AB( JJ ), NMAX, W,
1730 $ 2*NMAX, BETA, C( JJ, J ),
1731 $ NMAX, CT, G, CC( JC ), LDC,
1732 $ EPS, ERR, FATAL, NOUT,
1740 $ JJAB = JJAB + 2*NMAX
1742 ERRMAX = MAX( ERRMAX, ERR )
1743 * If got really bad answer, report and
1764 IF( ERRMAX.LT.THRESH )THEN
1765 WRITE( NOUT, FMT = 9999 )SNAME, NC
1767 WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
1773 $ WRITE( NOUT, FMT = 9995 )J
1776 WRITE( NOUT, FMT = 9996 )SNAME
1777 WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
1778 $ LDA, LDB, BETA, LDC
1783 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
1785 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
1786 $ 'ANGED INCORRECTLY *******' )
1787 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
1788 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
1789 $ ' - SUSPECT *******' )
1790 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
1791 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
1792 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
1793 $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
1795 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1801 SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT )
1803 * Tests the error exits from the Level 3 Blas.
1804 * Requires a special version of the error-handling routine XERBLA.
1805 * ALPHA, BETA, A, B and C should not need to be defined.
1807 * Auxiliary routine for test program for Level 3 Blas.
1809 * -- Written on 8-February-1989.
1810 * Jack Dongarra, Argonne National Laboratory.
1811 * Iain Duff, AERE Harwell.
1812 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
1813 * Sven Hammarling, Numerical Algorithms Group Ltd.
1815 * .. Scalar Arguments ..
1818 * .. Scalars in Common ..
1819 INTEGER INFOT, NOUTC
1821 * .. Local Scalars ..
1822 DOUBLE PRECISION ALPHA, BETA
1823 * .. Local Arrays ..
1824 DOUBLE PRECISION A( 2, 1 ), B( 2, 1 ), C( 2, 1 )
1825 * .. External Subroutines ..
1826 EXTERNAL CHKXER, DGEMM, DSYMM, DSYR2K, DSYRK, DTRMM,
1828 * .. Common blocks ..
1829 COMMON /INFOC/INFOT, NOUTC, OK, LERR
1830 * .. Executable Statements ..
1831 * OK is set to .FALSE. by the special version of XERBLA or by CHKXER
1832 * if anything is wrong.
1834 * LERR is set to .TRUE. by the special version of XERBLA each time
1835 * it is called, and is then tested and re-set by CHKXER.
1837 GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM
1839 CALL DGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1840 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1842 CALL DGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1843 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1845 CALL DGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1846 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1848 CALL DGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1849 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1851 CALL DGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1852 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1854 CALL DGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1855 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1857 CALL DGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1858 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1860 CALL DGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1861 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1863 CALL DGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1864 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1866 CALL DGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1867 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1869 CALL DGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1870 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1872 CALL DGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1873 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1875 CALL DGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
1876 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1878 CALL DGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
1879 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1881 CALL DGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
1882 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1884 CALL DGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
1885 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1887 CALL DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
1888 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1890 CALL DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
1891 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1893 CALL DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 )
1894 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1896 CALL DGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
1897 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1899 CALL DGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
1900 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1902 CALL DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
1903 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1905 CALL DGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1906 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1908 CALL DGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1909 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1911 CALL DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
1912 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1914 CALL DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
1915 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1917 CALL DGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1918 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1920 CALL DGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1921 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1924 CALL DSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1925 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1927 CALL DSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1928 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1930 CALL DSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1931 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1933 CALL DSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1934 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1936 CALL DSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1937 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1939 CALL DSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1940 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1942 CALL DSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
1943 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1945 CALL DSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
1946 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1948 CALL DSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
1949 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1951 CALL DSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
1952 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1954 CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
1955 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1957 CALL DSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
1958 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1960 CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
1961 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1963 CALL DSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
1964 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1966 CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
1967 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1969 CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1970 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1972 CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
1973 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1975 CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
1976 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1978 CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
1979 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1981 CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
1982 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1984 CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
1985 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1987 CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
1988 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1991 CALL DTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
1992 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1994 CALL DTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
1995 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
1997 CALL DTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
1998 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2000 CALL DTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
2001 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2003 CALL DTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2004 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2006 CALL DTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2007 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2009 CALL DTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2010 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2012 CALL DTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2013 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2015 CALL DTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2016 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2018 CALL DTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2019 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2021 CALL DTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2022 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2024 CALL DTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2025 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2027 CALL DTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2028 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2030 CALL DTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2031 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2033 CALL DTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2034 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2036 CALL DTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2037 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2039 CALL DTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2040 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2042 CALL DTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2043 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2045 CALL DTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2046 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2048 CALL DTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2049 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2051 CALL DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2052 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2054 CALL DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2055 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2057 CALL DTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2058 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2060 CALL DTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2061 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2063 CALL DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2064 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2066 CALL DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2067 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2069 CALL DTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2070 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2072 CALL DTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2073 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2075 CALL DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2076 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2078 CALL DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2079 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2081 CALL DTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2082 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2084 CALL DTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2085 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2087 CALL DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2088 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2090 CALL DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2091 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2093 CALL DTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2094 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2096 CALL DTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2097 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2100 CALL DTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2101 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2103 CALL DTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2104 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2106 CALL DTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
2107 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2109 CALL DTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
2110 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2112 CALL DTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2113 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2115 CALL DTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2116 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2118 CALL DTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2119 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2121 CALL DTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2122 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2124 CALL DTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2125 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2127 CALL DTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2128 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2130 CALL DTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2131 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2133 CALL DTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
2134 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2136 CALL DTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2137 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2139 CALL DTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2140 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2142 CALL DTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2143 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2145 CALL DTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2146 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2148 CALL DTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2149 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2151 CALL DTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2152 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2154 CALL DTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2155 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2157 CALL DTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
2158 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2160 CALL DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2161 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2163 CALL DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2164 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2166 CALL DTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2167 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2169 CALL DTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2170 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2172 CALL DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2173 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2175 CALL DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
2176 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2178 CALL DTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2179 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2181 CALL DTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
2182 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2184 CALL DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2185 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2187 CALL DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2188 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2190 CALL DTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2191 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2193 CALL DTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2194 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2196 CALL DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2197 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2199 CALL DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
2200 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2202 CALL DTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2203 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2205 CALL DTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
2206 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2209 CALL DSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 )
2210 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2212 CALL DSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 )
2213 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2215 CALL DSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2216 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2218 CALL DSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2219 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2221 CALL DSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2222 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2224 CALL DSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
2225 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2227 CALL DSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2228 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2230 CALL DSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2231 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2233 CALL DSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2234 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2236 CALL DSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
2237 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2239 CALL DSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
2240 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2242 CALL DSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
2243 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2245 CALL DSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
2246 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2248 CALL DSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
2249 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2251 CALL DSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
2252 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2254 CALL DSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
2255 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2257 CALL DSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
2258 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2260 CALL DSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
2261 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2264 CALL DSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2265 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2267 CALL DSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2268 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2270 CALL DSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2271 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2273 CALL DSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2274 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2276 CALL DSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2277 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2279 CALL DSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2280 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2282 CALL DSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2283 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2285 CALL DSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2286 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2288 CALL DSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2289 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2291 CALL DSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
2292 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2294 CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
2295 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2297 CALL DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2298 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2300 CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
2301 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2303 CALL DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
2304 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2306 CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
2307 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2309 CALL DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
2310 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2312 CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
2313 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2315 CALL DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
2316 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2318 CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2319 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2321 CALL DSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2322 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2324 CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
2325 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2327 CALL DSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
2328 CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2331 WRITE( NOUT, FMT = 9999 )SRNAMT
2333 WRITE( NOUT, FMT = 9998 )SRNAMT
2337 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
2338 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
2344 SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
2347 * Generates values for an M by N matrix A.
2348 * Stores the values in the array AA in the data structure required
2349 * by the routine, with unwanted elements set to rogue value.
2351 * TYPE is 'GE', 'SY' or 'TR'.
2353 * Auxiliary routine for test program for Level 3 Blas.
2355 * -- Written on 8-February-1989.
2356 * Jack Dongarra, Argonne National Laboratory.
2357 * Iain Duff, AERE Harwell.
2358 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2359 * Sven Hammarling, Numerical Algorithms Group Ltd.
2362 DOUBLE PRECISION ZERO, ONE
2363 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
2364 DOUBLE PRECISION ROGUE
2365 PARAMETER ( ROGUE = -1.0D10 )
2366 * .. Scalar Arguments ..
2367 DOUBLE PRECISION TRANSL
2368 INTEGER LDA, M, N, NMAX
2370 CHARACTER*1 DIAG, UPLO
2372 * .. Array Arguments ..
2373 DOUBLE PRECISION A( NMAX, * ), AA( * )
2374 * .. Local Scalars ..
2375 INTEGER I, IBEG, IEND, J
2376 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2377 * .. External Functions ..
2378 DOUBLE PRECISION DBEG
2380 * .. Executable Statements ..
2384 UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
2385 LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
2386 UNIT = TRI.AND.DIAG.EQ.'U'
2388 * Generate data in array A.
2392 IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
2394 A( I, J ) = DBEG( RESET ) + TRANSL
2396 * Set some elements to zero
2397 IF( N.GT.3.AND.J.EQ.N/2 )
2400 A( J, I ) = A( I, J )
2408 $ A( J, J ) = A( J, J ) + ONE
2413 * Store elements in array AS in data structure required by routine.
2415 IF( TYPE.EQ.'GE' )THEN
2418 AA( I + ( J - 1 )*LDA ) = A( I, J )
2420 DO 40 I = M + 1, LDA
2421 AA( I + ( J - 1 )*LDA ) = ROGUE
2424 ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
2441 DO 60 I = 1, IBEG - 1
2442 AA( I + ( J - 1 )*LDA ) = ROGUE
2444 DO 70 I = IBEG, IEND
2445 AA( I + ( J - 1 )*LDA ) = A( I, J )
2447 DO 80 I = IEND + 1, LDA
2448 AA( I + ( J - 1 )*LDA ) = ROGUE
2457 SUBROUTINE DMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
2458 $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
2461 * Checks the results of the computational tests.
2463 * Auxiliary routine for test program for Level 3 Blas.
2465 * -- Written on 8-February-1989.
2466 * Jack Dongarra, Argonne National Laboratory.
2467 * Iain Duff, AERE Harwell.
2468 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2469 * Sven Hammarling, Numerical Algorithms Group Ltd.
2472 DOUBLE PRECISION ZERO, ONE
2473 PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
2474 * .. Scalar Arguments ..
2475 DOUBLE PRECISION ALPHA, BETA, EPS, ERR
2476 INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
2478 CHARACTER*1 TRANSA, TRANSB
2479 * .. Array Arguments ..
2480 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
2481 $ CC( LDCC, * ), CT( * ), G( * )
2482 * .. Local Scalars ..
2483 DOUBLE PRECISION ERRI
2485 LOGICAL TRANA, TRANB
2486 * .. Intrinsic Functions ..
2487 INTRINSIC ABS, MAX, SQRT
2488 * .. Executable Statements ..
2489 TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
2490 TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
2492 * Compute expected result, one column at a time, in CT using data
2494 * Compute gauges in G.
2502 IF( .NOT.TRANA.AND..NOT.TRANB )THEN
2505 CT( I ) = CT( I ) + A( I, K )*B( K, J )
2506 G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) )
2509 ELSE IF( TRANA.AND..NOT.TRANB )THEN
2512 CT( I ) = CT( I ) + A( K, I )*B( K, J )
2513 G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) )
2516 ELSE IF( .NOT.TRANA.AND.TRANB )THEN
2519 CT( I ) = CT( I ) + A( I, K )*B( J, K )
2520 G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) )
2523 ELSE IF( TRANA.AND.TRANB )THEN
2526 CT( I ) = CT( I ) + A( K, I )*B( J, K )
2527 G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) )
2532 CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
2533 G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) )
2536 * Compute the error ratio for this result.
2540 ERRI = ABS( CT( I ) - CC( I, J ) )/EPS
2541 IF( G( I ).NE.ZERO )
2542 $ ERRI = ERRI/G( I )
2543 ERR = MAX( ERR, ERRI )
2544 IF( ERR*SQRT( EPS ).GE.ONE )
2550 * If the loop completes, all results are at least half accurate.
2553 * Report fatal error.
2556 WRITE( NOUT, FMT = 9999 )
2559 WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
2561 WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
2565 $ WRITE( NOUT, FMT = 9997 )J
2570 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
2571 $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
2573 9998 FORMAT( 1X, I7, 2G18.6 )
2574 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
2579 LOGICAL FUNCTION LDE( RI, RJ, LR )
2581 * Tests if two arrays are identical.
2583 * Auxiliary routine for test program for Level 3 Blas.
2585 * -- Written on 8-February-1989.
2586 * Jack Dongarra, Argonne National Laboratory.
2587 * Iain Duff, AERE Harwell.
2588 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2589 * Sven Hammarling, Numerical Algorithms Group Ltd.
2591 * .. Scalar Arguments ..
2593 * .. Array Arguments ..
2594 DOUBLE PRECISION RI( * ), RJ( * )
2595 * .. Local Scalars ..
2597 * .. Executable Statements ..
2599 IF( RI( I ).NE.RJ( I ) )
2611 LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA )
2613 * Tests if selected elements in two arrays are equal.
2615 * TYPE is 'GE' or 'SY'.
2617 * Auxiliary routine for test program for Level 3 Blas.
2619 * -- Written on 8-February-1989.
2620 * Jack Dongarra, Argonne National Laboratory.
2621 * Iain Duff, AERE Harwell.
2622 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2623 * Sven Hammarling, Numerical Algorithms Group Ltd.
2625 * .. Scalar Arguments ..
2629 * .. Array Arguments ..
2630 DOUBLE PRECISION AA( LDA, * ), AS( LDA, * )
2631 * .. Local Scalars ..
2632 INTEGER I, IBEG, IEND, J
2634 * .. Executable Statements ..
2636 IF( TYPE.EQ.'GE' )THEN
2638 DO 10 I = M + 1, LDA
2639 IF( AA( I, J ).NE.AS( I, J ) )
2643 ELSE IF( TYPE.EQ.'SY' )THEN
2652 DO 30 I = 1, IBEG - 1
2653 IF( AA( I, J ).NE.AS( I, J ) )
2656 DO 40 I = IEND + 1, LDA
2657 IF( AA( I, J ).NE.AS( I, J ) )
2673 DOUBLE PRECISION FUNCTION DBEG( RESET )
2675 * Generates random numbers uniformly distributed between -0.5 and 0.5.
2677 * Auxiliary routine for test program for Level 3 Blas.
2679 * -- Written on 8-February-1989.
2680 * Jack Dongarra, Argonne National Laboratory.
2681 * Iain Duff, AERE Harwell.
2682 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2683 * Sven Hammarling, Numerical Algorithms Group Ltd.
2685 * .. Scalar Arguments ..
2687 * .. Local Scalars ..
2689 * .. Save statement ..
2691 * .. Executable Statements ..
2693 * Initialize local variables.
2700 * The sequence of values of I is bounded between 1 and 999.
2701 * If initial I = 1,2,3,6,7 or 9, the period will be 50.
2702 * If initial I = 4 or 8, the period will be 25.
2703 * If initial I = 5, the period will be 10.
2704 * IC is used to break up the period by skipping 1 value of I in 6.
2708 I = I - 1000*( I/1000 )
2713 DBEG = ( I - 500 )/1001.0D0
2719 DOUBLE PRECISION FUNCTION DDIFF( X, Y )
2721 * Auxiliary routine for test program for Level 3 Blas.
2723 * -- Written on 8-February-1989.
2724 * Jack Dongarra, Argonne National Laboratory.
2725 * Iain Duff, AERE Harwell.
2726 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2727 * Sven Hammarling, Numerical Algorithms Group Ltd.
2729 * .. Scalar Arguments ..
2730 DOUBLE PRECISION X, Y
2731 * .. Executable Statements ..
2738 SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
2740 * Tests whether XERBLA has detected an error when it should.
2742 * Auxiliary routine for test program for Level 3 Blas.
2744 * -- Written on 8-February-1989.
2745 * Jack Dongarra, Argonne National Laboratory.
2746 * Iain Duff, AERE Harwell.
2747 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2748 * Sven Hammarling, Numerical Algorithms Group Ltd.
2750 * .. Scalar Arguments ..
2754 * .. Executable Statements ..
2756 WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
2762 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
2763 $ 'ETECTED BY ', A6, ' *****' )
2768 SUBROUTINE XERBLA( SRNAME, INFO )
2770 * This is a special version of XERBLA to be used only as part of
2771 * the test program for testing error exits from the Level 3 BLAS
2774 * XERBLA is an error handler for the Level 3 BLAS routines.
2776 * It is called by the Level 3 BLAS routines if an input parameter is
2779 * Auxiliary routine for test program for Level 3 Blas.
2781 * -- Written on 8-February-1989.
2782 * Jack Dongarra, Argonne National Laboratory.
2783 * Iain Duff, AERE Harwell.
2784 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
2785 * Sven Hammarling, Numerical Algorithms Group Ltd.
2787 * .. Scalar Arguments ..
2790 * .. Scalars in Common ..
2794 * .. Common blocks ..
2795 COMMON /INFOC/INFOT, NOUT, OK, LERR
2796 COMMON /SRNAMC/SRNAMT
2797 * .. Executable Statements ..
2799 IF( INFO.NE.INFOT )THEN
2800 IF( INFOT.NE.0 )THEN
2801 WRITE( NOUT, FMT = 9999 )INFO, INFOT
2803 WRITE( NOUT, FMT = 9997 )INFO
2807 IF( SRNAME.NE.SRNAMT )THEN
2808 WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
2813 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
2814 $ ' OF ', I2, ' *******' )
2815 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
2816 $ 'AD OF ', A6, ' *******' )
2817 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,