115 parameter ( nin = 5 )
117 parameter ( nsubs = 17 )
119 parameter ( zero = ( 0.0, 0.0 ), one = ( 1.0, 0.0 ) )
121 parameter ( rzero = 0.0 )
123 parameter ( nmax = 65, incmax = 2 )
124 INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
125 parameter ( ninmax = 7, nidmax = 9, nkbmax = 7,
126 $ nalmax = 7, nbemax = 7 )
128 REAL EPS, ERR, THRESH
129 INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB,
131 LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
135 CHARACTER*32 SNAPS, SUMMRY
137 COMPLEX A( nmax, nmax ), AA( nmax*nmax ),
138 $ alf( nalmax ), as( nmax*nmax ), bet( nbemax ),
139 $ x( nmax ), xs( nmax*incmax ),
140 $ xx( nmax*incmax ), y( nmax ),
141 $ ys( nmax*incmax ), yt( nmax ),
142 $ yy( nmax*incmax ), z( 2*nmax )
144 INTEGER IDIM( nidmax ), INC( ninmax ), KB( nkbmax )
145 LOGICAL LTEST( nsubs )
146 CHARACTER*6 SNAMES( nsubs )
155 INTRINSIC abs, max, min
161 COMMON /infoc/infot, noutc, ok, lerr
162 COMMON /srnamc/srnamt
164 DATA snames/
'CGEMV ',
'CGBMV ',
'CHEMV ',
'CHBMV ',
165 $
'CHPMV ',
'CTRMV ',
'CTBMV ',
'CTPMV ',
166 $
'CTRSV ',
'CTBSV ',
'CTPSV ',
'CGERC ',
167 $
'CGERU ',
'CHER ',
'CHPR ',
'CHER2 ',
173 READ( nin, fmt = * )summry
174 READ( nin, fmt = * )nout
175 OPEN( nout, file = summry, status =
'UNKNOWN' )
180 READ( nin, fmt = * )snaps
181 READ( nin, fmt = * )ntra
184 OPEN( ntra, file = snaps, status =
'UNKNOWN' )
187 READ( nin, fmt = * )rewi
188 rewi = rewi.AND.trace
190 READ( nin, fmt = * )sfatal
192 READ( nin, fmt = * )tsterr
194 READ( nin, fmt = * )thresh
199 READ( nin, fmt = * )nidim
200 IF( nidim.LT.1.OR.nidim.GT.nidmax )
THEN
201 WRITE( nout, fmt = 9997 )
'N', nidmax
204 READ( nin, fmt = * )( idim( i ), i = 1, nidim )
206 IF( idim( i ).LT.0.OR.idim( i ).GT.nmax )
THEN
207 WRITE( nout, fmt = 9996 )nmax
212 READ( nin, fmt = * )nkb
213 IF( nkb.LT.1.OR.nkb.GT.nkbmax )
THEN
214 WRITE( nout, fmt = 9997 )
'K', nkbmax
217 READ( nin, fmt = * )( kb( i ), i = 1, nkb )
219 IF( kb( i ).LT.0 )
THEN
220 WRITE( nout, fmt = 9995 )
225 READ( nin, fmt = * )ninc
226 IF( ninc.LT.1.OR.ninc.GT.ninmax )
THEN
227 WRITE( nout, fmt = 9997 )
'INCX AND INCY', ninmax
230 READ( nin, fmt = * )( inc( i ), i = 1, ninc )
232 IF( inc( i ).EQ.0.OR.abs( inc( i ) ).GT.incmax )
THEN
233 WRITE( nout, fmt = 9994 )incmax
238 READ( nin, fmt = * )nalf
239 IF( nalf.LT.1.OR.nalf.GT.nalmax )
THEN
240 WRITE( nout, fmt = 9997 )
'ALPHA', nalmax
243 READ( nin, fmt = * )( alf( i ), i = 1, nalf )
245 READ( nin, fmt = * )nbet
246 IF( nbet.LT.1.OR.nbet.GT.nbemax )
THEN
247 WRITE( nout, fmt = 9997 )
'BETA', nbemax
250 READ( nin, fmt = * )( bet( i ), i = 1, nbet )
254 WRITE( nout, fmt = 9993 )
255 WRITE( nout, fmt = 9992 )( idim( i ), i = 1, nidim )
256 WRITE( nout, fmt = 9991 )( kb( i ), i = 1, nkb )
257 WRITE( nout, fmt = 9990 )( inc( i ), i = 1, ninc )
258 WRITE( nout, fmt = 9989 )( alf( i ), i = 1, nalf )
259 WRITE( nout, fmt = 9988 )( bet( i ), i = 1, nbet )
260 IF( .NOT.tsterr )
THEN
261 WRITE( nout, fmt = * )
262 WRITE( nout, fmt = 9980 )
264 WRITE( nout, fmt = * )
265 WRITE( nout, fmt = 9999 )thresh
266 WRITE( nout, fmt = * )
274 50
READ( nin, fmt = 9984, end = 80 )snamet, ltestt
276 IF( snamet.EQ.snames( i ) )
279 WRITE( nout, fmt = 9986 )snamet
281 70 ltest( i ) = ltestt
290 WRITE( nout, fmt = 9998 )eps
297 a( i, j ) = max( i - j + 1, 0 )
303 yy( j ) = j*( ( j + 1 )*j )/2 - ( ( j + 1 )*j*( j - 1 ) )/3
308 CALL cmvch( trans, n, n, one, a, nmax, x, 1, zero, y, 1, yt, g,
309 $ yy, eps, err, fatal, nout, .true. )
310 same = lce( yy, yt, n )
311 IF( .NOT.same.OR.err.NE.rzero )
THEN
312 WRITE( nout, fmt = 9985 )trans, same, err
316 CALL cmvch( trans, n, n, one, a, nmax, x, -1, zero, y, -1, yt, g,
317 $ yy, eps, err, fatal, nout, .true. )
318 same = lce( yy, yt, n )
319 IF( .NOT.same.OR.err.NE.rzero )
THEN
320 WRITE( nout, fmt = 9985 )trans, same, err
326 DO 210 isnum = 1, nsubs
327 WRITE( nout, fmt = * )
328 IF( .NOT.ltest( isnum ) )
THEN
330 WRITE( nout, fmt = 9983 )snames( isnum )
332 srnamt = snames( isnum )
335 CALL cchke( isnum, snames( isnum ), nout )
336 WRITE( nout, fmt = * )
342 GO TO ( 140, 140, 150, 150, 150, 160, 160,
343 $ 160, 160, 160, 160, 170, 170, 180,
344 $ 180, 190, 190 )isnum
346 140
CALL cchk1( snames( isnum ), eps, thresh, nout, ntra, trace,
347 $ rewi, fatal, nidim, idim, nkb, kb, nalf, alf,
348 $ nbet, bet, ninc, inc, nmax, incmax, a, aa, as,
349 $ x, xx, xs, y, yy, ys, yt, g )
352 150
CALL cchk2( snames( isnum ), eps, thresh, nout, ntra, trace,
353 $ rewi, fatal, nidim, idim, nkb, kb, nalf, alf,
354 $ nbet, bet, ninc, inc, nmax, incmax, a, aa, as,
355 $ x, xx, xs, y, yy, ys, yt, g )
359 160
CALL cchk3( snames( isnum ), eps, thresh, nout, ntra, trace,
360 $ rewi, fatal, nidim, idim, nkb, kb, ninc, inc,
361 $ nmax, incmax, a, aa, as, y, yy, ys, yt, g, z )
364 170
CALL cchk4( snames( isnum ), eps, thresh, nout, ntra, trace,
365 $ rewi, fatal, nidim, idim, nalf, alf, ninc, inc,
366 $ nmax, incmax, a, aa, as, x, xx, xs, y, yy, ys,
370 180
CALL cchk5( snames( isnum ), eps, thresh, nout, ntra, trace,
371 $ rewi, fatal, nidim, idim, nalf, alf, ninc, inc,
372 $ nmax, incmax, a, aa, as, x, xx, xs, y, yy, ys,
376 190
CALL cchk6( snames( isnum ), eps, thresh, nout, ntra, trace,
377 $ rewi, fatal, nidim, idim, nalf, alf, ninc, inc,
378 $ nmax, incmax, a, aa, as, x, xx, xs, y, yy, ys,
381 200
IF( fatal.AND.sfatal )
385 WRITE( nout, fmt = 9982 )
389 WRITE( nout, fmt = 9981 )
393 WRITE( nout, fmt = 9987 )
401 9999
FORMAT(
' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
403 9998
FORMAT(
' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1p, e9.1 )
404 9997
FORMAT(
' NUMBER OF VALUES OF ', a,
' IS LESS THAN 1 OR GREATER ',
406 9996
FORMAT(
' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', i2 )
407 9995
FORMAT(
' VALUE OF K IS LESS THAN 0' )
408 9994
FORMAT(
' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',
410 9993
FORMAT(
' TESTS OF THE COMPLEX LEVEL 2 BLAS', //
' THE F',
411 $
'OLLOWING PARAMETER VALUES WILL BE USED:' )
412 9992
FORMAT(
' FOR N ', 9i6 )
413 9991
FORMAT(
' FOR K ', 7i6 )
414 9990
FORMAT(
' FOR INCX AND INCY ', 7i6 )
415 9989
FORMAT(
' FOR ALPHA ',
416 $ 7(
'(', f4.1,
',', f4.1,
') ', : ) )
417 9988
FORMAT(
' FOR BETA ',
418 $ 7(
'(', f4.1,
',', f4.1,
') ', : ) )
419 9987
FORMAT(
' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
420 $ /
' ******* TESTS ABANDONED *******' )
421 9986
FORMAT(
' SUBPROGRAM NAME ', a6,
' NOT RECOGNIZED', /
' ******* T',
422 $
'ESTS ABANDONED *******' )
423 9985
FORMAT(
' ERROR IN CMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
424 $
'ATED WRONGLY.', /
' CMVCH WAS CALLED WITH TRANS = ', a1,
425 $
' AND RETURNED SAME = ', l1,
' AND ERR = ', f12.3,
'.', /
426 $
' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.'
427 $ , /
' ******* TESTS ABANDONED *******' )
428 9984
FORMAT( a6, l2 )
429 9983
FORMAT( 1x, a6,
' WAS NOT TESTED' )
430 9982
FORMAT( /
' END OF TESTS' )
431 9981
FORMAT( /
' ******* FATAL ERROR - TESTS ABANDONED *******' )
432 9980
FORMAT(
' ERROR-EXITS WILL NOT BE TESTED' )
437 SUBROUTINE cchk1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
438 $ fatal, nidim, idim, nkb, kb, nalf, alf, nbet,
439 $ bet, ninc, inc, nmax, incmax, a, aa, as, x, xx,
440 $ xs, y, yy, ys, yt, g )
452 parameter ( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ) )
454 parameter ( rzero = 0.0 )
457 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
459 LOGICAL FATAL, REWI, TRACE
462 COMPLEX A( nmax, nmax ), AA( nmax*nmax ), ALF( nalf ),
463 $ as( nmax*nmax ), bet( nbet ), x( nmax ),
464 $ xs( nmax*incmax ), xx( nmax*incmax ),
465 $ y( nmax ), ys( nmax*incmax ), yt( nmax ),
468 INTEGER IDIM( nidim ), INC( ninc ), KB( nkb )
470 COMPLEX ALPHA, ALS, BETA, BLS, TRANSL
472 INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
473 $ incys, ix, iy, kl, kls, ku, kus, laa, lda,
474 $ ldas, lx, ly, m, ml, ms, n, nargs, nc, nd, nk,
476 LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN
477 CHARACTER*1 TRANS, TRANSS
487 INTRINSIC abs, max, min
492 COMMON /infoc/infot, noutc, ok, lerr
496 full = sname( 3: 3 ).EQ.
'E'
497 banded = sname( 3: 3 ).EQ.
'B'
501 ELSE IF( banded )
THEN
515 $ m = max( n - nd, 0 )
517 $ m = min( n + nd, nmax )
527 kl = max( ku - 1, 0 )
544 null = n.LE.0.OR.m.LE.0
549 CALL cmake( sname( 2: 3 ),
' ',
' ', m, n, a, nmax, aa,
550 $ lda, kl, ku, reset, transl )
553 trans = ich( ic: ic )
554 tran = trans.EQ.
'T'.OR.trans.EQ.
'C'
571 CALL cmake(
'GE',
' ',
' ', 1, nl, x, 1, xx,
572 $ abs( incx ), 0, nl - 1, reset, transl )
575 xx( 1 + abs( incx )*( nl/2 - 1 ) ) = zero
591 CALL cmake(
'GE',
' ',
' ', 1, ml, y, 1,
592 $ yy, abs( incy ), 0, ml - 1,
624 $
WRITE( ntra, fmt = 9994 )nc, sname,
625 $ trans, m, n, alpha, lda, incx, beta,
629 CALL cgemv( trans, m, n, alpha, aa,
630 $ lda, xx, incx, beta, yy,
632 ELSE IF( banded )
THEN
634 $
WRITE( ntra, fmt = 9995 )nc, sname,
635 $ trans, m, n, kl, ku, alpha, lda,
639 CALL cgbmv( trans, m, n, kl, ku, alpha,
640 $ aa, lda, xx, incx, beta,
647 WRITE( nout, fmt = 9993 )
654 isame( 1 ) = trans.EQ.transs
658 isame( 4 ) = als.EQ.alpha
659 isame( 5 ) = lce( as, aa, laa )
660 isame( 6 ) = ldas.EQ.lda
661 isame( 7 ) = lce( xs, xx, lx )
662 isame( 8 ) = incxs.EQ.incx
663 isame( 9 ) = bls.EQ.beta
665 isame( 10 ) = lce( ys, yy, ly )
667 isame( 10 ) = lceres(
'GE',
' ', 1,
671 isame( 11 ) = incys.EQ.incy
672 ELSE IF( banded )
THEN
673 isame( 4 ) = kls.EQ.kl
674 isame( 5 ) = kus.EQ.ku
675 isame( 6 ) = als.EQ.alpha
676 isame( 7 ) = lce( as, aa, laa )
677 isame( 8 ) = ldas.EQ.lda
678 isame( 9 ) = lce( xs, xx, lx )
679 isame( 10 ) = incxs.EQ.incx
680 isame( 11 ) = bls.EQ.beta
682 isame( 12 ) = lce( ys, yy, ly )
684 isame( 12 ) = lceres(
'GE',
' ', 1,
688 isame( 13 ) = incys.EQ.incy
696 same = same.AND.isame( i )
697 IF( .NOT.isame( i ) )
698 $
WRITE( nout, fmt = 9998 )i
709 CALL cmvch( trans, m, n, alpha, a,
710 $ nmax, x, incx, beta, y,
711 $ incy, yt, g, yy, eps, err,
712 $ fatal, nout, .true. )
713 errmax = max( errmax, err )
742 IF( errmax.LT.thresh )
THEN
743 WRITE( nout, fmt = 9999 )sname, nc
745 WRITE( nout, fmt = 9997 )sname, nc, errmax
750 WRITE( nout, fmt = 9996 )sname
752 WRITE( nout, fmt = 9994 )nc, sname, trans, m, n, alpha, lda,
754 ELSE IF( banded )
THEN
755 WRITE( nout, fmt = 9995 )nc, sname, trans, m, n, kl, ku,
756 $ alpha, lda, incx, beta, incy
762 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
764 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
765 $
'ANGED INCORRECTLY *******' )
766 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
767 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
768 $
' - SUSPECT *******' )
769 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
770 9995
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', 4( i3,
',' ),
'(',
771 $ f4.1,
',', f4.1,
'), A,', i3,
', X,', i2,
',(', f4.1,
',',
772 $ f4.1,
'), Y,', i2,
') .' )
773 9994
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', 2( i3,
',' ),
'(',
774 $ f4.1,
',', f4.1,
'), A,', i3,
', X,', i2,
',(', f4.1,
',',
775 $ f4.1,
'), Y,', i2,
') .' )
776 9993
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
782 SUBROUTINE cchk2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
783 $ fatal, nidim, idim, nkb, kb, nalf, alf, nbet,
784 $ bet, ninc, inc, nmax, incmax, a, aa, as, x, xx,
785 $ xs, y, yy, ys, yt, g )
797 parameter ( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ) )
799 parameter ( rzero = 0.0 )
802 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
804 LOGICAL FATAL, REWI, TRACE
807 COMPLEX A( nmax, nmax ), AA( nmax*nmax ), ALF( nalf ),
808 $ as( nmax*nmax ), bet( nbet ), x( nmax ),
809 $ xs( nmax*incmax ), xx( nmax*incmax ),
810 $ y( nmax ), ys( nmax*incmax ), yt( nmax ),
813 INTEGER IDIM( nidim ), INC( ninc ), KB( nkb )
815 COMPLEX ALPHA, ALS, BETA, BLS, TRANSL
817 INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
818 $ incys, ix, iy, k, ks, laa, lda, ldas, lx, ly,
819 $ n, nargs, nc, nk, ns
820 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
821 CHARACTER*1 UPLO, UPLOS
836 COMMON /infoc/infot, noutc, ok, lerr
840 full = sname( 3: 3 ).EQ.
'E'
841 banded = sname( 3: 3 ).EQ.
'B'
842 packed = sname( 3: 3 ).EQ.
'P'
846 ELSE IF( banded )
THEN
848 ELSE IF( packed )
THEN
882 laa = ( n*( n + 1 ) )/2
894 CALL cmake( sname( 2: 3 ), uplo,
' ', n, n, a, nmax, aa,
895 $ lda, k, k, reset, transl )
904 CALL cmake(
'GE',
' ',
' ', 1, n, x, 1, xx,
905 $ abs( incx ), 0, n - 1, reset, transl )
908 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
924 CALL cmake(
'GE',
' ',
' ', 1, n, y, 1, yy,
925 $ abs( incy ), 0, n - 1, reset,
955 $
WRITE( ntra, fmt = 9993 )nc, sname,
956 $ uplo, n, alpha, lda, incx, beta, incy
959 CALL chemv( uplo, n, alpha, aa, lda, xx,
960 $ incx, beta, yy, incy )
961 ELSE IF( banded )
THEN
963 $
WRITE( ntra, fmt = 9994 )nc, sname,
964 $ uplo, n, k, alpha, lda, incx, beta,
968 CALL chbmv( uplo, n, k, alpha, aa, lda,
969 $ xx, incx, beta, yy, incy )
970 ELSE IF( packed )
THEN
972 $
WRITE( ntra, fmt = 9995 )nc, sname,
973 $ uplo, n, alpha, incx, beta, incy
976 CALL chpmv( uplo, n, alpha, aa, xx, incx,
983 WRITE( nout, fmt = 9992 )
990 isame( 1 ) = uplo.EQ.uplos
993 isame( 3 ) = als.EQ.alpha
994 isame( 4 ) = lce( as, aa, laa )
995 isame( 5 ) = ldas.EQ.lda
996 isame( 6 ) = lce( xs, xx, lx )
997 isame( 7 ) = incxs.EQ.incx
998 isame( 8 ) = bls.EQ.beta
1000 isame( 9 ) = lce( ys, yy, ly )
1002 isame( 9 ) = lceres(
'GE',
' ', 1, n,
1003 $ ys, yy, abs( incy ) )
1005 isame( 10 ) = incys.EQ.incy
1006 ELSE IF( banded )
THEN
1007 isame( 3 ) = ks.EQ.k
1008 isame( 4 ) = als.EQ.alpha
1009 isame( 5 ) = lce( as, aa, laa )
1010 isame( 6 ) = ldas.EQ.lda
1011 isame( 7 ) = lce( xs, xx, lx )
1012 isame( 8 ) = incxs.EQ.incx
1013 isame( 9 ) = bls.EQ.beta
1015 isame( 10 ) = lce( ys, yy, ly )
1017 isame( 10 ) = lceres(
'GE',
' ', 1, n,
1018 $ ys, yy, abs( incy ) )
1020 isame( 11 ) = incys.EQ.incy
1021 ELSE IF( packed )
THEN
1022 isame( 3 ) = als.EQ.alpha
1023 isame( 4 ) = lce( as, aa, laa )
1024 isame( 5 ) = lce( xs, xx, lx )
1025 isame( 6 ) = incxs.EQ.incx
1026 isame( 7 ) = bls.EQ.beta
1028 isame( 8 ) = lce( ys, yy, ly )
1030 isame( 8 ) = lceres(
'GE',
' ', 1, n,
1031 $ ys, yy, abs( incy ) )
1033 isame( 9 ) = incys.EQ.incy
1041 same = same.AND.isame( i )
1042 IF( .NOT.isame( i ) )
1043 $
WRITE( nout, fmt = 9998 )i
1054 CALL cmvch(
'N', n, n, alpha, a, nmax, x,
1055 $ incx, beta, y, incy, yt, g,
1056 $ yy, eps, err, fatal, nout,
1058 errmax = max( errmax, err )
1084 IF( errmax.LT.thresh )
THEN
1085 WRITE( nout, fmt = 9999 )sname, nc
1087 WRITE( nout, fmt = 9997 )sname, nc, errmax
1092 WRITE( nout, fmt = 9996 )sname
1094 WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, lda, incx,
1096 ELSE IF( banded )
THEN
1097 WRITE( nout, fmt = 9994 )nc, sname, uplo, n, k, alpha, lda,
1099 ELSE IF( packed )
THEN
1100 WRITE( nout, fmt = 9995 )nc, sname, uplo, n, alpha, incx,
1107 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
1109 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
1110 $
'ANGED INCORRECTLY *******' )
1111 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
1112 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1113 $
' - SUSPECT *******' )
1114 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
1115 9995
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', i3,
',(', f4.1,
',',
1116 $ f4.1,
'), AP, X,', i2,
',(', f4.1,
',', f4.1,
'), Y,', i2,
1118 9994
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', 2( i3,
',' ),
'(',
1119 $ f4.1,
',', f4.1,
'), A,', i3,
', X,', i2,
',(', f4.1,
',',
1120 $ f4.1,
'), Y,', i2,
') .' )
1121 9993
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', i3,
',(', f4.1,
',',
1122 $ f4.1,
'), A,', i3,
', X,', i2,
',(', f4.1,
',', f4.1,
'), ',
1124 9992
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1130 SUBROUTINE cchk3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1131 $ fatal, nidim, idim, nkb, kb, ninc, inc, nmax,
1132 $ incmax, a, aa, as, x, xx, xs, xt, g, z )
1143 COMPLEX ZERO, HALF, ONE
1144 parameter ( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
1145 $ one = ( 1.0, 0.0 ) )
1147 parameter ( rzero = 0.0 )
1150 INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA
1151 LOGICAL FATAL, REWI, TRACE
1154 COMPLEX A( nmax, nmax ), AA( nmax*nmax ),
1155 $ as( nmax*nmax ), x( nmax ), xs( nmax*incmax ),
1156 $ xt( nmax ), xx( nmax*incmax ), z( nmax )
1158 INTEGER IDIM( nidim ), INC( ninc ), KB( nkb )
1162 INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
1163 $ ks, laa, lda, ldas, lx, n, nargs, nc, nk, ns
1164 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
1165 CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
1166 CHARACTER*2 ICHD, ICHU
1172 EXTERNAL lce, lceres
1179 INTEGER INFOT, NOUTC
1182 COMMON /infoc/infot, noutc, ok, lerr
1184 DATA ichu/
'UL'/, icht/
'NTC'/, ichd/
'UN'/
1186 full = sname( 3: 3 ).EQ.
'R'
1187 banded = sname( 3: 3 ).EQ.
'B'
1188 packed = sname( 3: 3 ).EQ.
'P'
1192 ELSE IF( banded )
THEN
1194 ELSE IF( packed )
THEN
1206 DO 110 in = 1, nidim
1232 laa = ( n*( n + 1 ) )/2
1239 uplo = ichu( icu: icu )
1242 trans = icht( ict: ict )
1245 diag = ichd( icd: icd )
1250 CALL cmake( sname( 2: 3 ), uplo, diag, n, n, a,
1251 $ nmax, aa, lda, k, k, reset, transl )
1260 CALL cmake(
'GE',
' ',
' ', 1, n, x, 1, xx,
1261 $ abs( incx ), 0, n - 1, reset,
1265 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1288 IF( sname( 4: 5 ).EQ.
'MV' )
THEN
1291 $
WRITE( ntra, fmt = 9993 )nc, sname,
1292 $ uplo, trans, diag, n, lda, incx
1295 CALL ctrmv( uplo, trans, diag, n, aa, lda,
1297 ELSE IF( banded )
THEN
1299 $
WRITE( ntra, fmt = 9994 )nc, sname,
1300 $ uplo, trans, diag, n, k, lda, incx
1303 CALL ctbmv( uplo, trans, diag, n, k, aa,
1305 ELSE IF( packed )
THEN
1307 $
WRITE( ntra, fmt = 9995 )nc, sname,
1308 $ uplo, trans, diag, n, incx
1311 CALL ctpmv( uplo, trans, diag, n, aa, xx,
1314 ELSE IF( sname( 4: 5 ).EQ.
'SV' )
THEN
1317 $
WRITE( ntra, fmt = 9993 )nc, sname,
1318 $ uplo, trans, diag, n, lda, incx
1321 CALL ctrsv( uplo, trans, diag, n, aa, lda,
1323 ELSE IF( banded )
THEN
1325 $
WRITE( ntra, fmt = 9994 )nc, sname,
1326 $ uplo, trans, diag, n, k, lda, incx
1329 CALL ctbsv( uplo, trans, diag, n, k, aa,
1331 ELSE IF( packed )
THEN
1333 $
WRITE( ntra, fmt = 9995 )nc, sname,
1334 $ uplo, trans, diag, n, incx
1337 CALL ctpsv( uplo, trans, diag, n, aa, xx,
1345 WRITE( nout, fmt = 9992 )
1352 isame( 1 ) = uplo.EQ.uplos
1353 isame( 2 ) = trans.EQ.transs
1354 isame( 3 ) = diag.EQ.diags
1355 isame( 4 ) = ns.EQ.n
1357 isame( 5 ) = lce( as, aa, laa )
1358 isame( 6 ) = ldas.EQ.lda
1360 isame( 7 ) = lce( xs, xx, lx )
1362 isame( 7 ) = lceres(
'GE',
' ', 1, n, xs,
1365 isame( 8 ) = incxs.EQ.incx
1366 ELSE IF( banded )
THEN
1367 isame( 5 ) = ks.EQ.k
1368 isame( 6 ) = lce( as, aa, laa )
1369 isame( 7 ) = ldas.EQ.lda
1371 isame( 8 ) = lce( xs, xx, lx )
1373 isame( 8 ) = lceres(
'GE',
' ', 1, n, xs,
1376 isame( 9 ) = incxs.EQ.incx
1377 ELSE IF( packed )
THEN
1378 isame( 5 ) = lce( as, aa, laa )
1380 isame( 6 ) = lce( xs, xx, lx )
1382 isame( 6 ) = lceres(
'GE',
' ', 1, n, xs,
1385 isame( 7 ) = incxs.EQ.incx
1393 same = same.AND.isame( i )
1394 IF( .NOT.isame( i ) )
1395 $
WRITE( nout, fmt = 9998 )i
1403 IF( sname( 4: 5 ).EQ.
'MV' )
THEN
1407 CALL cmvch( trans, n, n, one, a, nmax, x,
1408 $ incx, zero, z, incx, xt, g,
1409 $ xx, eps, err, fatal, nout,
1411 ELSE IF( sname( 4: 5 ).EQ.
'SV' )
THEN
1416 z( i ) = xx( 1 + ( i - 1 )*
1418 xx( 1 + ( i - 1 )*abs( incx ) )
1421 CALL cmvch( trans, n, n, one, a, nmax, z,
1422 $ incx, zero, x, incx, xt, g,
1423 $ xx, eps, err, fatal, nout,
1426 errmax = max( errmax, err )
1449 IF( errmax.LT.thresh )
THEN
1450 WRITE( nout, fmt = 9999 )sname, nc
1452 WRITE( nout, fmt = 9997 )sname, nc, errmax
1457 WRITE( nout, fmt = 9996 )sname
1459 WRITE( nout, fmt = 9993 )nc, sname, uplo, trans, diag, n, lda,
1461 ELSE IF( banded )
THEN
1462 WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, diag, n, k,
1464 ELSE IF( packed )
THEN
1465 WRITE( nout, fmt = 9995 )nc, sname, uplo, trans, diag, n, incx
1471 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
1473 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
1474 $
'ANGED INCORRECTLY *******' )
1475 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
1476 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1477 $
' - SUSPECT *******' )
1478 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
1479 9995
FORMAT( 1x, i6,
': ', a6,
'(', 3(
'''', a1,
''',' ), i3,
', AP, ',
1481 9994
FORMAT( 1x, i6,
': ', a6,
'(', 3(
'''', a1,
''',' ), 2( i3,
',' ),
1482 $
' A,', i3,
', X,', i2,
') .' )
1483 9993
FORMAT( 1x, i6,
': ', a6,
'(', 3(
'''', a1,
''',' ), i3,
', A,',
1484 $ i3,
', X,', i2,
') .' )
1485 9992
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1491 SUBROUTINE cchk4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1492 $ fatal, nidim, idim, nalf, alf, ninc, inc, nmax,
1493 $ incmax, a, aa, as, x, xx, xs, y, yy, ys, yt, g,
1505 COMPLEX ZERO, HALF, ONE
1506 parameter ( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
1507 $ one = ( 1.0, 0.0 ) )
1509 parameter ( rzero = 0.0 )
1512 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1513 LOGICAL FATAL, REWI, TRACE
1516 COMPLEX A( nmax, nmax ), AA( nmax*nmax ), ALF( nalf ),
1517 $ as( nmax*nmax ), x( nmax ), xs( nmax*incmax ),
1518 $ xx( nmax*incmax ), y( nmax ),
1519 $ ys( nmax*incmax ), yt( nmax ),
1520 $ yy( nmax*incmax ), z( nmax )
1522 INTEGER IDIM( nidim ), INC( ninc )
1524 COMPLEX ALPHA, ALS, TRANSL
1526 INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
1527 $ iy, j, laa, lda, ldas, lx, ly, m, ms, n, nargs,
1529 LOGICAL CONJ, NULL, RESET, SAME
1535 EXTERNAL lce, lceres
1539 INTRINSIC abs, conjg, max, min
1541 INTEGER INFOT, NOUTC
1544 COMMON /infoc/infot, noutc, ok, lerr
1546 conj = sname( 5: 5 ).EQ.
'C'
1554 DO 120 in = 1, nidim
1560 $ m = max( n - nd, 0 )
1562 $ m = min( n + nd, nmax )
1572 null = n.LE.0.OR.m.LE.0
1581 CALL cmake(
'GE',
' ',
' ', 1, m, x, 1, xx, abs( incx ),
1582 $ 0, m - 1, reset, transl )
1585 xx( 1 + abs( incx )*( m/2 - 1 ) ) = zero
1595 CALL cmake(
'GE',
' ',
' ', 1, n, y, 1, yy,
1596 $ abs( incy ), 0, n - 1, reset, transl )
1599 yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
1608 CALL cmake( sname( 2: 3 ),
' ',
' ', m, n, a, nmax,
1609 $ aa, lda, m - 1, n - 1, reset, transl )
1634 $
WRITE( ntra, fmt = 9994 )nc, sname, m, n,
1635 $ alpha, incx, incy, lda
1639 CALL cgerc( m, n, alpha, xx, incx, yy, incy, aa,
1644 CALL cgeru( m, n, alpha, xx, incx, yy, incy, aa,
1651 WRITE( nout, fmt = 9993 )
1658 isame( 1 ) = ms.EQ.m
1659 isame( 2 ) = ns.EQ.n
1660 isame( 3 ) = als.EQ.alpha
1661 isame( 4 ) = lce( xs, xx, lx )
1662 isame( 5 ) = incxs.EQ.incx
1663 isame( 6 ) = lce( ys, yy, ly )
1664 isame( 7 ) = incys.EQ.incy
1666 isame( 8 ) = lce( as, aa, laa )
1668 isame( 8 ) = lceres(
'GE',
' ', m, n, as, aa,
1671 isame( 9 ) = ldas.EQ.lda
1677 same = same.AND.isame( i )
1678 IF( .NOT.isame( i ) )
1679 $
WRITE( nout, fmt = 9998 )i
1696 z( i ) = x( m - i + 1 )
1703 w( 1 ) = y( n - j + 1 )
1706 $ w( 1 ) = conjg( w( 1 ) )
1707 CALL cmvch(
'N', m, 1, alpha, z, nmax, w, 1,
1708 $ one, a( 1, j ), 1, yt, g,
1709 $ aa( 1 + ( j - 1 )*lda ), eps,
1710 $ err, fatal, nout, .true. )
1711 errmax = max( errmax, err )
1733 IF( errmax.LT.thresh )
THEN
1734 WRITE( nout, fmt = 9999 )sname, nc
1736 WRITE( nout, fmt = 9997 )sname, nc, errmax
1741 WRITE( nout, fmt = 9995 )j
1744 WRITE( nout, fmt = 9996 )sname
1745 WRITE( nout, fmt = 9994 )nc, sname, m, n, alpha, incx, incy, lda
1750 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
1752 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
1753 $
'ANGED INCORRECTLY *******' )
1754 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
1755 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1756 $
' - SUSPECT *******' )
1757 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
1758 9995
FORMAT(
' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1759 9994
FORMAT( 1x, i6,
': ', a6,
'(', 2( i3,
',' ),
'(', f4.1,
',', f4.1,
1760 $
'), X,', i2,
', Y,', i2,
', A,', i3,
') ',
1762 9993
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1768 SUBROUTINE cchk5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1769 $ fatal, nidim, idim, nalf, alf, ninc, inc, nmax,
1770 $ incmax, a, aa, as, x, xx, xs, y, yy, ys, yt, g,
1782 COMPLEX ZERO, HALF, ONE
1783 parameter ( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
1784 $ one = ( 1.0, 0.0 ) )
1786 parameter ( rzero = 0.0 )
1789 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1790 LOGICAL FATAL, REWI, TRACE
1793 COMPLEX A( nmax, nmax ), AA( nmax*nmax ), ALF( nalf ),
1794 $ as( nmax*nmax ), x( nmax ), xs( nmax*incmax ),
1795 $ xx( nmax*incmax ), y( nmax ),
1796 $ ys( nmax*incmax ), yt( nmax ),
1797 $ yy( nmax*incmax ), z( nmax )
1799 INTEGER IDIM( nidim ), INC( ninc )
1801 COMPLEX ALPHA, TRANSL
1802 REAL ERR, ERRMAX, RALPHA, RALS
1803 INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
1804 $ lda, ldas, lj, lx, n, nargs, nc, ns
1805 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
1806 CHARACTER*1 UPLO, UPLOS
1813 EXTERNAL lce, lceres
1817 INTRINSIC abs, cmplx, conjg, max, real
1819 INTEGER INFOT, NOUTC
1822 COMMON /infoc/infot, noutc, ok, lerr
1826 full = sname( 3: 3 ).EQ.
'E'
1827 packed = sname( 3: 3 ).EQ.
'P'
1831 ELSE IF( packed )
THEN
1839 DO 100 in = 1, nidim
1849 laa = ( n*( n + 1 ) )/2
1855 uplo = ich( ic: ic )
1865 CALL cmake(
'GE',
' ',
' ', 1, n, x, 1, xx, abs( incx ),
1866 $ 0, n - 1, reset, transl )
1869 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1873 ralpha =
REAL( ALF( IA ) )
1874 alpha = cmplx( ralpha, rzero )
1875 null = n.LE.0.OR.ralpha.EQ.rzero
1880 CALL cmake( sname( 2: 3 ), uplo,
' ', n, n, a, nmax,
1881 $ aa, lda, n - 1, n - 1, reset, transl )
1903 $
WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
1907 CALL cher( uplo, n, ralpha, xx, incx, aa, lda )
1908 ELSE IF( packed )
THEN
1910 $
WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
1914 CALL chpr( uplo, n, ralpha, xx, incx, aa )
1920 WRITE( nout, fmt = 9992 )
1927 isame( 1 ) = uplo.EQ.uplos
1928 isame( 2 ) = ns.EQ.n
1929 isame( 3 ) = rals.EQ.ralpha
1930 isame( 4 ) = lce( xs, xx, lx )
1931 isame( 5 ) = incxs.EQ.incx
1933 isame( 6 ) = lce( as, aa, laa )
1935 isame( 6 ) = lceres( sname( 2: 3 ), uplo, n, n, as,
1938 IF( .NOT.packed )
THEN
1939 isame( 7 ) = ldas.EQ.lda
1946 same = same.AND.isame( i )
1947 IF( .NOT.isame( i ) )
1948 $
WRITE( nout, fmt = 9998 )i
1965 z( i ) = x( n - i + 1 )
1970 w( 1 ) = conjg( z( j ) )
1978 CALL cmvch(
'N', lj, 1, alpha, z( jj ), lj, w,
1979 $ 1, one, a( jj, j ), 1, yt, g,
1980 $ aa( ja ), eps, err, fatal, nout,
1991 errmax = max( errmax, err )
2012 IF( errmax.LT.thresh )
THEN
2013 WRITE( nout, fmt = 9999 )sname, nc
2015 WRITE( nout, fmt = 9997 )sname, nc, errmax
2020 WRITE( nout, fmt = 9995 )j
2023 WRITE( nout, fmt = 9996 )sname
2025 WRITE( nout, fmt = 9993 )nc, sname, uplo, n, ralpha, incx, lda
2026 ELSE IF( packed )
THEN
2027 WRITE( nout, fmt = 9994 )nc, sname, uplo, n, ralpha, incx
2033 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
2035 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
2036 $
'ANGED INCORRECTLY *******' )
2037 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
2038 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2039 $
' - SUSPECT *******' )
2040 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
2041 9995
FORMAT(
' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2042 9994
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', i3,
',', f4.1,
', X,',
2044 9993
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', i3,
',', f4.1,
', X,',
2045 $ i2,
', A,', i3,
') .' )
2046 9992
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2052 SUBROUTINE cchk6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
2053 $ fatal, nidim, idim, nalf, alf, ninc, inc, nmax,
2054 $ incmax, a, aa, as, x, xx, xs, y, yy, ys, yt, g,
2066 COMPLEX ZERO, HALF, ONE
2067 parameter ( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
2068 $ one = ( 1.0, 0.0 ) )
2070 parameter ( rzero = 0.0 )
2073 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
2074 LOGICAL FATAL, REWI, TRACE
2077 COMPLEX A( nmax, nmax ), AA( nmax*nmax ), ALF( nalf ),
2078 $ as( nmax*nmax ), x( nmax ), xs( nmax*incmax ),
2079 $ xx( nmax*incmax ), y( nmax ),
2080 $ ys( nmax*incmax ), yt( nmax ),
2081 $ yy( nmax*incmax ), z( nmax, 2 )
2083 INTEGER IDIM( nidim ), INC( ninc )
2085 COMPLEX ALPHA, ALS, TRANSL
2087 INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
2088 $ iy, j, ja, jj, laa, lda, ldas, lj, lx, ly, n,
2090 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
2091 CHARACTER*1 UPLO, UPLOS
2098 EXTERNAL lce, lceres
2102 INTRINSIC abs, conjg, max
2104 INTEGER INFOT, NOUTC
2107 COMMON /infoc/infot, noutc, ok, lerr
2111 full = sname( 3: 3 ).EQ.
'E'
2112 packed = sname( 3: 3 ).EQ.
'P'
2116 ELSE IF( packed )
THEN
2124 DO 140 in = 1, nidim
2134 laa = ( n*( n + 1 ) )/2
2140 uplo = ich( ic: ic )
2150 CALL cmake(
'GE',
' ',
' ', 1, n, x, 1, xx, abs( incx ),
2151 $ 0, n - 1, reset, transl )
2154 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
2164 CALL cmake(
'GE',
' ',
' ', 1, n, y, 1, yy,
2165 $ abs( incy ), 0, n - 1, reset, transl )
2168 yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
2173 null = n.LE.0.OR.alpha.EQ.zero
2178 CALL cmake( sname( 2: 3 ), uplo,
' ', n, n, a,
2179 $ nmax, aa, lda, n - 1, n - 1, reset,
2206 $
WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
2207 $ alpha, incx, incy, lda
2210 CALL cher2( uplo, n, alpha, xx, incx, yy, incy,
2212 ELSE IF( packed )
THEN
2214 $
WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
2218 CALL chpr2( uplo, n, alpha, xx, incx, yy, incy,
2225 WRITE( nout, fmt = 9992 )
2232 isame( 1 ) = uplo.EQ.uplos
2233 isame( 2 ) = ns.EQ.n
2234 isame( 3 ) = als.EQ.alpha
2235 isame( 4 ) = lce( xs, xx, lx )
2236 isame( 5 ) = incxs.EQ.incx
2237 isame( 6 ) = lce( ys, yy, ly )
2238 isame( 7 ) = incys.EQ.incy
2240 isame( 8 ) = lce( as, aa, laa )
2242 isame( 8 ) = lceres( sname( 2: 3 ), uplo, n, n,
2245 IF( .NOT.packed )
THEN
2246 isame( 9 ) = ldas.EQ.lda
2253 same = same.AND.isame( i )
2254 IF( .NOT.isame( i ) )
2255 $
WRITE( nout, fmt = 9998 )i
2272 z( i, 1 ) = x( n - i + 1 )
2281 z( i, 2 ) = y( n - i + 1 )
2286 w( 1 ) = alpha*conjg( z( j, 2 ) )
2287 w( 2 ) = conjg( alpha )*conjg( z( j, 1 ) )
2295 CALL cmvch(
'N', lj, 2, one, z( jj, 1 ),
2296 $ nmax, w, 1, one, a( jj, j ), 1,
2297 $ yt, g, aa( ja ), eps, err, fatal,
2308 errmax = max( errmax, err )
2331 IF( errmax.LT.thresh )
THEN
2332 WRITE( nout, fmt = 9999 )sname, nc
2334 WRITE( nout, fmt = 9997 )sname, nc, errmax
2339 WRITE( nout, fmt = 9995 )j
2342 WRITE( nout, fmt = 9996 )sname
2344 WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, incx,
2346 ELSE IF( packed )
THEN
2347 WRITE( nout, fmt = 9994 )nc, sname, uplo, n, alpha, incx, incy
2353 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
2355 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
2356 $
'ANGED INCORRECTLY *******' )
2357 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
2358 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2359 $
' - SUSPECT *******' )
2360 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
2361 9995
FORMAT(
' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2362 9994
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', i3,
',(', f4.1,
',',
2363 $ f4.1,
'), X,', i2,
', Y,', i2,
', AP) ',
2365 9993
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', i3,
',(', f4.1,
',',
2366 $ f4.1,
'), X,', i2,
', Y,', i2,
', A,', i3,
') ',
2368 9992
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2374 SUBROUTINE cchke( ISNUM, SRNAMT, NOUT )
2390 INTEGER INFOT, NOUTC
2396 COMPLEX A( 1, 1 ), X( 1 ), Y( 1 )
2402 COMMON /infoc/infot, noutc, ok, lerr
2410 GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
2411 $ 90, 100, 110, 120, 130, 140, 150, 160,
2414 CALL cgemv(
'/', 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2415 CALL chkxer( srnamt, infot, nout, lerr, ok )
2417 CALL cgemv(
'N', -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2418 CALL chkxer( srnamt, infot, nout, lerr, ok )
2420 CALL cgemv(
'N', 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2421 CALL chkxer( srnamt, infot, nout, lerr, ok )
2423 CALL cgemv(
'N', 2, 0, alpha, a, 1, x, 1, beta, y, 1 )
2424 CALL chkxer( srnamt, infot, nout, lerr, ok )
2426 CALL cgemv(
'N', 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2427 CALL chkxer( srnamt, infot, nout, lerr, ok )
2429 CALL cgemv(
'N', 0, 0, alpha, a, 1, x, 1, beta, y, 0 )
2430 CALL chkxer( srnamt, infot, nout, lerr, ok )
2433 CALL cgbmv(
'/', 0, 0, 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2434 CALL chkxer( srnamt, infot, nout, lerr, ok )
2436 CALL cgbmv(
'N', -1, 0, 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2437 CALL chkxer( srnamt, infot, nout, lerr, ok )
2439 CALL cgbmv(
'N', 0, -1, 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2440 CALL chkxer( srnamt, infot, nout, lerr, ok )
2442 CALL cgbmv(
'N', 0, 0, -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2443 CALL chkxer( srnamt, infot, nout, lerr, ok )
2445 CALL cgbmv(
'N', 2, 0, 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2446 CALL chkxer( srnamt, infot, nout, lerr, ok )
2448 CALL cgbmv(
'N', 0, 0, 1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2449 CALL chkxer( srnamt, infot, nout, lerr, ok )
2451 CALL cgbmv(
'N', 0, 0, 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2452 CALL chkxer( srnamt, infot, nout, lerr, ok )
2454 CALL cgbmv(
'N', 0, 0, 0, 0, alpha, a, 1, x, 1, beta, y, 0 )
2455 CALL chkxer( srnamt, infot, nout, lerr, ok )
2458 CALL chemv(
'/', 0, alpha, a, 1, x, 1, beta, y, 1 )
2459 CALL chkxer( srnamt, infot, nout, lerr, ok )
2461 CALL chemv(
'U', -1, alpha, a, 1, x, 1, beta, y, 1 )
2462 CALL chkxer( srnamt, infot, nout, lerr, ok )
2464 CALL chemv(
'U', 2, alpha, a, 1, x, 1, beta, y, 1 )
2465 CALL chkxer( srnamt, infot, nout, lerr, ok )
2467 CALL chemv(
'U', 0, alpha, a, 1, x, 0, beta, y, 1 )
2468 CALL chkxer( srnamt, infot, nout, lerr, ok )
2470 CALL chemv(
'U', 0, alpha, a, 1, x, 1, beta, y, 0 )
2471 CALL chkxer( srnamt, infot, nout, lerr, ok )
2474 CALL chbmv(
'/', 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2475 CALL chkxer( srnamt, infot, nout, lerr, ok )
2477 CALL chbmv(
'U', -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2478 CALL chkxer( srnamt, infot, nout, lerr, ok )
2480 CALL chbmv(
'U', 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2481 CALL chkxer( srnamt, infot, nout, lerr, ok )
2483 CALL chbmv(
'U', 0, 1, alpha, a, 1, x, 1, beta, y, 1 )
2484 CALL chkxer( srnamt, infot, nout, lerr, ok )
2486 CALL chbmv(
'U', 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2487 CALL chkxer( srnamt, infot, nout, lerr, ok )
2489 CALL chbmv(
'U', 0, 0, alpha, a, 1, x, 1, beta, y, 0 )
2490 CALL chkxer( srnamt, infot, nout, lerr, ok )
2493 CALL chpmv(
'/', 0, alpha, a, x, 1, beta, y, 1 )
2494 CALL chkxer( srnamt, infot, nout, lerr, ok )
2496 CALL chpmv(
'U', -1, alpha, a, x, 1, beta, y, 1 )
2497 CALL chkxer( srnamt, infot, nout, lerr, ok )
2499 CALL chpmv(
'U', 0, alpha, a, x, 0, beta, y, 1 )
2500 CALL chkxer( srnamt, infot, nout, lerr, ok )
2502 CALL chpmv(
'U', 0, alpha, a, x, 1, beta, y, 0 )
2503 CALL chkxer( srnamt, infot, nout, lerr, ok )
2506 CALL ctrmv(
'/',
'N',
'N', 0, a, 1, x, 1 )
2507 CALL chkxer( srnamt, infot, nout, lerr, ok )
2509 CALL ctrmv(
'U',
'/',
'N', 0, a, 1, x, 1 )
2510 CALL chkxer( srnamt, infot, nout, lerr, ok )
2512 CALL ctrmv(
'U',
'N',
'/', 0, a, 1, x, 1 )
2513 CALL chkxer( srnamt, infot, nout, lerr, ok )
2515 CALL ctrmv(
'U',
'N',
'N', -1, a, 1, x, 1 )
2516 CALL chkxer( srnamt, infot, nout, lerr, ok )
2518 CALL ctrmv(
'U',
'N',
'N', 2, a, 1, x, 1 )
2519 CALL chkxer( srnamt, infot, nout, lerr, ok )
2521 CALL ctrmv(
'U',
'N',
'N', 0, a, 1, x, 0 )
2522 CALL chkxer( srnamt, infot, nout, lerr, ok )
2525 CALL ctbmv(
'/',
'N',
'N', 0, 0, a, 1, x, 1 )
2526 CALL chkxer( srnamt, infot, nout, lerr, ok )
2528 CALL ctbmv(
'U',
'/',
'N', 0, 0, a, 1, x, 1 )
2529 CALL chkxer( srnamt, infot, nout, lerr, ok )
2531 CALL ctbmv(
'U',
'N',
'/', 0, 0, a, 1, x, 1 )
2532 CALL chkxer( srnamt, infot, nout, lerr, ok )
2534 CALL ctbmv(
'U',
'N',
'N', -1, 0, a, 1, x, 1 )
2535 CALL chkxer( srnamt, infot, nout, lerr, ok )
2537 CALL ctbmv(
'U',
'N',
'N', 0, -1, a, 1, x, 1 )
2538 CALL chkxer( srnamt, infot, nout, lerr, ok )
2540 CALL ctbmv(
'U',
'N',
'N', 0, 1, a, 1, x, 1 )
2541 CALL chkxer( srnamt, infot, nout, lerr, ok )
2543 CALL ctbmv(
'U',
'N',
'N', 0, 0, a, 1, x, 0 )
2544 CALL chkxer( srnamt, infot, nout, lerr, ok )
2547 CALL ctpmv(
'/',
'N',
'N', 0, a, x, 1 )
2548 CALL chkxer( srnamt, infot, nout, lerr, ok )
2550 CALL ctpmv(
'U',
'/',
'N', 0, a, x, 1 )
2551 CALL chkxer( srnamt, infot, nout, lerr, ok )
2553 CALL ctpmv(
'U',
'N',
'/', 0, a, x, 1 )
2554 CALL chkxer( srnamt, infot, nout, lerr, ok )
2556 CALL ctpmv(
'U',
'N',
'N', -1, a, x, 1 )
2557 CALL chkxer( srnamt, infot, nout, lerr, ok )
2559 CALL ctpmv(
'U',
'N',
'N', 0, a, x, 0 )
2560 CALL chkxer( srnamt, infot, nout, lerr, ok )
2563 CALL ctrsv(
'/',
'N',
'N', 0, a, 1, x, 1 )
2564 CALL chkxer( srnamt, infot, nout, lerr, ok )
2566 CALL ctrsv(
'U',
'/',
'N', 0, a, 1, x, 1 )
2567 CALL chkxer( srnamt, infot, nout, lerr, ok )
2569 CALL ctrsv(
'U',
'N',
'/', 0, a, 1, x, 1 )
2570 CALL chkxer( srnamt, infot, nout, lerr, ok )
2572 CALL ctrsv(
'U',
'N',
'N', -1, a, 1, x, 1 )
2573 CALL chkxer( srnamt, infot, nout, lerr, ok )
2575 CALL ctrsv(
'U',
'N',
'N', 2, a, 1, x, 1 )
2576 CALL chkxer( srnamt, infot, nout, lerr, ok )
2578 CALL ctrsv(
'U',
'N',
'N', 0, a, 1, x, 0 )
2579 CALL chkxer( srnamt, infot, nout, lerr, ok )
2582 CALL ctbsv(
'/',
'N',
'N', 0, 0, a, 1, x, 1 )
2583 CALL chkxer( srnamt, infot, nout, lerr, ok )
2585 CALL ctbsv(
'U',
'/',
'N', 0, 0, a, 1, x, 1 )
2586 CALL chkxer( srnamt, infot, nout, lerr, ok )
2588 CALL ctbsv(
'U',
'N',
'/', 0, 0, a, 1, x, 1 )
2589 CALL chkxer( srnamt, infot, nout, lerr, ok )
2591 CALL ctbsv(
'U',
'N',
'N', -1, 0, a, 1, x, 1 )
2592 CALL chkxer( srnamt, infot, nout, lerr, ok )
2594 CALL ctbsv(
'U',
'N',
'N', 0, -1, a, 1, x, 1 )
2595 CALL chkxer( srnamt, infot, nout, lerr, ok )
2597 CALL ctbsv(
'U',
'N',
'N', 0, 1, a, 1, x, 1 )
2598 CALL chkxer( srnamt, infot, nout, lerr, ok )
2600 CALL ctbsv(
'U',
'N',
'N', 0, 0, a, 1, x, 0 )
2601 CALL chkxer( srnamt, infot, nout, lerr, ok )
2604 CALL ctpsv(
'/',
'N',
'N', 0, a, x, 1 )
2605 CALL chkxer( srnamt, infot, nout, lerr, ok )
2607 CALL ctpsv(
'U',
'/',
'N', 0, a, x, 1 )
2608 CALL chkxer( srnamt, infot, nout, lerr, ok )
2610 CALL ctpsv(
'U',
'N',
'/', 0, a, x, 1 )
2611 CALL chkxer( srnamt, infot, nout, lerr, ok )
2613 CALL ctpsv(
'U',
'N',
'N', -1, a, x, 1 )
2614 CALL chkxer( srnamt, infot, nout, lerr, ok )
2616 CALL ctpsv(
'U',
'N',
'N', 0, a, x, 0 )
2617 CALL chkxer( srnamt, infot, nout, lerr, ok )
2620 CALL cgerc( -1, 0, alpha, x, 1, y, 1, a, 1 )
2621 CALL chkxer( srnamt, infot, nout, lerr, ok )
2623 CALL cgerc( 0, -1, alpha, x, 1, y, 1, a, 1 )
2624 CALL chkxer( srnamt, infot, nout, lerr, ok )
2626 CALL cgerc( 0, 0, alpha, x, 0, y, 1, a, 1 )
2627 CALL chkxer( srnamt, infot, nout, lerr, ok )
2629 CALL cgerc( 0, 0, alpha, x, 1, y, 0, a, 1 )
2630 CALL chkxer( srnamt, infot, nout, lerr, ok )
2632 CALL cgerc( 2, 0, alpha, x, 1, y, 1, a, 1 )
2633 CALL chkxer( srnamt, infot, nout, lerr, ok )
2636 CALL cgeru( -1, 0, alpha, x, 1, y, 1, a, 1 )
2637 CALL chkxer( srnamt, infot, nout, lerr, ok )
2639 CALL cgeru( 0, -1, alpha, x, 1, y, 1, a, 1 )
2640 CALL chkxer( srnamt, infot, nout, lerr, ok )
2642 CALL cgeru( 0, 0, alpha, x, 0, y, 1, a, 1 )
2643 CALL chkxer( srnamt, infot, nout, lerr, ok )
2645 CALL cgeru( 0, 0, alpha, x, 1, y, 0, a, 1 )
2646 CALL chkxer( srnamt, infot, nout, lerr, ok )
2648 CALL cgeru( 2, 0, alpha, x, 1, y, 1, a, 1 )
2649 CALL chkxer( srnamt, infot, nout, lerr, ok )
2652 CALL cher(
'/', 0, ralpha, x, 1, a, 1 )
2653 CALL chkxer( srnamt, infot, nout, lerr, ok )
2655 CALL cher(
'U', -1, ralpha, x, 1, a, 1 )
2656 CALL chkxer( srnamt, infot, nout, lerr, ok )
2658 CALL cher(
'U', 0, ralpha, x, 0, a, 1 )
2659 CALL chkxer( srnamt, infot, nout, lerr, ok )
2661 CALL cher(
'U', 2, ralpha, x, 1, a, 1 )
2662 CALL chkxer( srnamt, infot, nout, lerr, ok )
2665 CALL chpr(
'/', 0, ralpha, x, 1, a )
2666 CALL chkxer( srnamt, infot, nout, lerr, ok )
2668 CALL chpr(
'U', -1, ralpha, x, 1, a )
2669 CALL chkxer( srnamt, infot, nout, lerr, ok )
2671 CALL chpr(
'U', 0, ralpha, x, 0, a )
2672 CALL chkxer( srnamt, infot, nout, lerr, ok )
2675 CALL cher2(
'/', 0, alpha, x, 1, y, 1, a, 1 )
2676 CALL chkxer( srnamt, infot, nout, lerr, ok )
2678 CALL cher2(
'U', -1, alpha, x, 1, y, 1, a, 1 )
2679 CALL chkxer( srnamt, infot, nout, lerr, ok )
2681 CALL cher2(
'U', 0, alpha, x, 0, y, 1, a, 1 )
2682 CALL chkxer( srnamt, infot, nout, lerr, ok )
2684 CALL cher2(
'U', 0, alpha, x, 1, y, 0, a, 1 )
2685 CALL chkxer( srnamt, infot, nout, lerr, ok )
2687 CALL cher2(
'U', 2, alpha, x, 1, y, 1, a, 1 )
2688 CALL chkxer( srnamt, infot, nout, lerr, ok )
2691 CALL chpr2(
'/', 0, alpha, x, 1, y, 1, a )
2692 CALL chkxer( srnamt, infot, nout, lerr, ok )
2694 CALL chpr2(
'U', -1, alpha, x, 1, y, 1, a )
2695 CALL chkxer( srnamt, infot, nout, lerr, ok )
2697 CALL chpr2(
'U', 0, alpha, x, 0, y, 1, a )
2698 CALL chkxer( srnamt, infot, nout, lerr, ok )
2700 CALL chpr2(
'U', 0, alpha, x, 1, y, 0, a )
2701 CALL chkxer( srnamt, infot, nout, lerr, ok )
2704 WRITE( nout, fmt = 9999 )srnamt
2706 WRITE( nout, fmt = 9998 )srnamt
2710 9999
FORMAT(
' ', a6,
' PASSED THE TESTS OF ERROR-EXITS' )
2711 9998
FORMAT(
' ******* ', a6,
' FAILED THE TESTS OF ERROR-EXITS *****',
2717 SUBROUTINE cmake( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
2718 $ ku, reset, transl )
2735 parameter ( zero = ( 0.0, 0.0 ), one = ( 1.0, 0.0 ) )
2737 parameter ( rogue = ( -1.0e10, 1.0e10 ) )
2739 parameter ( rzero = 0.0 )
2741 parameter ( rrogue = -1.0e10 )
2744 INTEGER KL, KU, LDA, M, N, NMAX
2746 CHARACTER*1 DIAG, UPLO
2749 COMPLEX A( nmax, * ), AA( * )
2751 INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK
2752 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2757 INTRINSIC cmplx, conjg, max, min, real
2759 gen =
TYPE( 1: 1 ).EQ.
'G'
2760 sym =
TYPE( 1: 1 ).EQ.
'H'
2761 tri =
TYPE( 1: 1 ).EQ.
'T'
2762 upper = ( sym.OR.tri ).AND.uplo.EQ.
'U'
2763 lower = ( sym.OR.tri ).AND.uplo.EQ.
'L'
2764 unit = tri.AND.diag.EQ.
'U'
2770 IF( gen.OR.( upper.AND.i.LE.j ).OR.( lower.AND.i.GE.j ) )
2772 IF( ( i.LE.j.AND.j - i.LE.ku ).OR.
2773 $ ( i.GE.j.AND.i - j.LE.kl ) )
THEN
2774 a( i, j ) = cbeg( reset ) + transl
2780 a( j, i ) = conjg( a( i, j ) )
2788 $ a( j, j ) = cmplx(
REAL( A( J, J ) ), RZERO )
2790 $ a( j, j ) = a( j, j ) + one
2797 IF( type.EQ.
'GE' )
THEN
2800 aa( i + ( j - 1 )*lda ) = a( i, j )
2802 DO 40 i = m + 1, lda
2803 aa( i + ( j - 1 )*lda ) = rogue
2806 ELSE IF( type.EQ.
'GB' )
THEN
2808 DO 60 i1 = 1, ku + 1 - j
2809 aa( i1 + ( j - 1 )*lda ) = rogue
2811 DO 70 i2 = i1, min( kl + ku + 1, ku + 1 + m - j )
2812 aa( i2 + ( j - 1 )*lda ) = a( i2 + j - ku - 1, j )
2815 aa( i3 + ( j - 1 )*lda ) = rogue
2818 ELSE IF( type.EQ.
'HE'.OR.type.EQ.
'TR' )
THEN
2835 DO 100 i = 1, ibeg - 1
2836 aa( i + ( j - 1 )*lda ) = rogue
2838 DO 110 i = ibeg, iend
2839 aa( i + ( j - 1 )*lda ) = a( i, j )
2841 DO 120 i = iend + 1, lda
2842 aa( i + ( j - 1 )*lda ) = rogue
2845 jj = j + ( j - 1 )*lda
2846 aa( jj ) = cmplx(
REAL( AA( JJ ) ), RROGUE )
2849 ELSE IF( type.EQ.
'HB'.OR.type.EQ.
'TB' )
THEN
2853 ibeg = max( 1, kl + 2 - j )
2866 iend = min( kl + 1, 1 + m - j )
2868 DO 140 i = 1, ibeg - 1
2869 aa( i + ( j - 1 )*lda ) = rogue
2871 DO 150 i = ibeg, iend
2872 aa( i + ( j - 1 )*lda ) = a( i + j - kk, j )
2874 DO 160 i = iend + 1, lda
2875 aa( i + ( j - 1 )*lda ) = rogue
2878 jj = kk + ( j - 1 )*lda
2879 aa( jj ) = cmplx(
REAL( AA( JJ ) ), RROGUE )
2882 ELSE IF( type.EQ.
'HP'.OR.type.EQ.
'TP' )
THEN
2892 DO 180 i = ibeg, iend
2894 aa( ioff ) = a( i, j )
2897 $ aa( ioff ) = rogue
2899 $ aa( ioff ) = cmplx(
REAL( AA( IOFF ) ), RROGUE )
2909 SUBROUTINE cmvch( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
2910 $ incy, yt, g, yy, eps, err, fatal, nout, mv )
2922 parameter ( zero = ( 0.0, 0.0 ) )
2924 parameter ( rzero = 0.0, rone = 1.0 )
2928 INTEGER INCX, INCY, M, N, NMAX, NOUT
2932 COMPLEX A( nmax, * ), X( * ), Y( * ), YT( * ), YY( * )
2937 INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
2940 INTRINSIC abs, aimag, conjg, max,
REAL, SQRT
2944 abs1( c ) = abs(
REAL( C ) ) + abs( AIMAG( c ) )
2947 ctran = trans.EQ.
'C'
2948 IF( tran.OR.ctran )
THEN
2980 yt( iy ) = yt( iy ) + a( j, i )*x( jx )
2981 g( iy ) = g( iy ) + abs1( a( j, i ) )*abs1( x( jx ) )
2984 ELSE IF( ctran )
THEN
2986 yt( iy ) = yt( iy ) + conjg( a( j, i ) )*x( jx )
2987 g( iy ) = g( iy ) + abs1( a( j, i ) )*abs1( x( jx ) )
2992 yt( iy ) = yt( iy ) + a( i, j )*x( jx )
2993 g( iy ) = g( iy ) + abs1( a( i, j ) )*abs1( x( jx ) )
2997 yt( iy ) = alpha*yt( iy ) + beta*y( iy )
2998 g( iy ) = abs1( alpha )*g( iy ) + abs1( beta )*abs1( y( iy ) )
3006 erri = abs( yt( i ) - yy( 1 + ( i - 1 )*abs( incy ) ) )/eps
3007 IF( g( i ).NE.rzero )
3008 $ erri = erri/g( i )
3009 err = max( err, erri )
3010 IF( err*sqrt( eps ).GE.rone )
3019 WRITE( nout, fmt = 9999 )
3022 WRITE( nout, fmt = 9998 )i, yt( i ),
3023 $ yy( 1 + ( i - 1 )*abs( incy ) )
3025 WRITE( nout, fmt = 9998 )i,
3026 $ yy( 1 + ( i - 1 )*abs( incy ) ), yt( i )
3033 9999
FORMAT(
' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
3034 $
'F ACCURATE *******', /
' EXPECTED RE',
3035 $
'SULT COMPUTED RESULT' )
3036 9998
FORMAT( 1x, i7, 2(
' (', g15.6,
',', g15.6,
')' ) )
3041 LOGICAL FUNCTION lce( RI, RJ, LR )
3054 COMPLEX RI( * ), RJ( * )
3059 IF( ri( i ).NE.rj( i ) )
3071 LOGICAL FUNCTION lceres( TYPE, UPLO, M, N, AA, AS, LDA )
3088 COMPLEX AA( lda, * ), AS( lda, * )
3090 INTEGER I, IBEG, IEND, J
3094 IF( type.EQ.
'GE' )
THEN
3096 DO 10 i = m + 1, lda
3097 IF( aa( i, j ).NE.as( i, j ) )
3101 ELSE IF( type.EQ.
'HE' )
THEN
3110 DO 30 i = 1, ibeg - 1
3111 IF( aa( i, j ).NE.as( i, j ) )
3114 DO 40 i = iend + 1, lda
3115 IF( aa( i, j ).NE.as( i, j ) )
3130 COMPLEX FUNCTION cbeg( RESET )
3144 INTEGER I, IC, J, MI, MJ
3146 SAVE i, ic, j, mi, mj
3170 i = i - 1000*( i/1000 )
3171 j = j - 1000*( j/1000 )
3176 cbeg = cmplx( ( i - 500 )/1001.0, ( j - 500 )/1001.0 )
3182 REAL FUNCTION sdiff( X, Y )
3198 SUBROUTINE chkxer( SRNAMT, INFOT, NOUT, LERR, OK )
3214 WRITE( nout, fmt = 9999 )infot, srnamt
3220 9999
FORMAT(
' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', i2,
' NOT D',
3221 $
'ETECTED BY ', a6,
' *****' )
3226 SUBROUTINE xerbla( SRNAME, INFO )
3251 COMMON /infoc/infot, nout, ok, lerr
3252 COMMON /srnamc/srnamt
3255 IF( info.NE.infot )
THEN
3256 IF( infot.NE.0 )
THEN
3257 WRITE( nout, fmt = 9999 )info, infot
3259 WRITE( nout, fmt = 9997 )info
3263 IF( srname.NE.srnamt )
THEN
3264 WRITE( nout, fmt = 9998 )srname, srnamt
3269 9999
FORMAT(
' ******* XERBLA WAS CALLED WITH INFO = ', i6,
' INSTEAD',
3270 $
' OF ', i2,
' *******' )
3271 9998
FORMAT(
' ******* XERBLA WAS CALLED WITH SRNAME = ', a6,
' INSTE',
3272 $
'AD OF ', a6,
' *******' )
3273 9997
FORMAT(
' ******* XERBLA WAS CALLED WITH INFO = ', i6,
subroutine ctpmv(UPLO, TRANS, DIAG, N, AP, X, INCX)
CTPMV
subroutine chbmv(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CHBMV
subroutine cchk6(SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, Z)
subroutine chpmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
CHPMV
subroutine cher(UPLO, N, ALPHA, X, INCX, A, LDA)
CHER
subroutine ctrsv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
CTRSV
subroutine cchk5(SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, Z)
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine chpr(UPLO, N, ALPHA, X, INCX, AP)
CHPR
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
subroutine cgbmv(TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGBMV
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
subroutine cchk3(SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, XT, G, Z)
subroutine cgerc(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERC
subroutine cmvch(TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV)
subroutine ctbmv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
CTBMV
subroutine cchk2(SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G)
logical function lce(RI, RJ, LR)
subroutine chpr2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP)
CHPR2
subroutine ctrmv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
CTRMV
real function sdiff(SA, SB)
subroutine chemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CHEMV
subroutine cmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
subroutine cher2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CHER2
logical function lceres(TYPE, UPLO, M, N, AA, AS, LDA)
subroutine ctpsv(UPLO, TRANS, DIAG, N, AP, X, INCX)
CTPSV
complex function cbeg(RESET)
subroutine cchke(ISNUM, SRNAMT, NOUT)
subroutine cchk4(SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, Z)
subroutine ctbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
CTBSV
subroutine cgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERU
subroutine cchk1(SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G)