114 parameter( nsubs = 17 )
116 parameter( zero = ( 0.0, 0.0 ), one = ( 1.0, 0.0 ) )
118 parameter( rzero = 0.0 )
120 parameter( nmax = 65, incmax = 2 )
121 INTEGER ninmax, nidmax, nkbmax, nalmax, nbemax
122 parameter( ninmax = 7, nidmax = 9, nkbmax = 7,
123 $ nalmax = 7, nbemax = 7 )
125 REAL eps, err, thresh
126 INTEGER i, isnum, j, n, nalf, nbet, nidim, ninc, nkb,
128 LOGICAL fatal, ltestt, rewi, same, sfatal, trace,
132 CHARACTER*32 snaps, summry
134 COMPLEX a( nmax, nmax ), aa( nmax*nmax ),
135 $ alf( nalmax ), as( nmax*nmax ), bet( nbemax ),
136 $ x( nmax ), xs( nmax*incmax ),
137 $ xx( nmax*incmax ), y( nmax ),
138 $ ys( nmax*incmax ), yt( nmax ),
139 $ yy( nmax*incmax ), z( 2*nmax )
141 INTEGER idim( nidmax ), inc( ninmax ), kb( nkbmax )
142 LOGICAL ltest( nsubs )
143 CHARACTER*6 snames( nsubs )
152 INTRINSIC abs, max, min
158 COMMON /infoc/infot, noutc, ok, lerr
159 COMMON /srnamc/srnamt
161 DATA snames/
'CGEMV ',
'CGBMV ',
'CHEMV ',
'CHBMV ',
162 $
'CHPMV ',
'CTRMV ',
'CTBMV ',
'CTPMV ',
163 $
'CTRSV ',
'CTBSV ',
'CTPSV ',
'CGERC ',
164 $
'CGERU ',
'CHER ',
'CHPR ',
'CHER2 ',
170 READ( nin, fmt = * )summry
171 READ( nin, fmt = * )nout
172 OPEN( nout, file = summry, status =
'UNKNOWN' )
177 READ( nin, fmt = * )snaps
178 READ( nin, fmt = * )ntra
181 OPEN( ntra, file = snaps, status =
'UNKNOWN' )
184 READ( nin, fmt = * )rewi
185 rewi = rewi.AND.trace
187 READ( nin, fmt = * )sfatal
189 READ( nin, fmt = * )tsterr
191 READ( nin, fmt = * )thresh
196 READ( nin, fmt = * )nidim
197 IF( nidim.LT.1.OR.nidim.GT.nidmax )
THEN
198 WRITE( nout, fmt = 9997 )
'N', nidmax
201 READ( nin, fmt = * )( idim( i ), i = 1, nidim )
203 IF( idim( i ).LT.0.OR.idim( i ).GT.nmax )
THEN
204 WRITE( nout, fmt = 9996 )nmax
209 READ( nin, fmt = * )nkb
210 IF( nkb.LT.1.OR.nkb.GT.nkbmax )
THEN
211 WRITE( nout, fmt = 9997 )
'K', nkbmax
214 READ( nin, fmt = * )( kb( i ), i = 1, nkb )
216 IF( kb( i ).LT.0 )
THEN
217 WRITE( nout, fmt = 9995 )
222 READ( nin, fmt = * )ninc
223 IF( ninc.LT.1.OR.ninc.GT.ninmax )
THEN
224 WRITE( nout, fmt = 9997 )
'INCX AND INCY', ninmax
227 READ( nin, fmt = * )( inc( i ), i = 1, ninc )
229 IF( inc( i ).EQ.0.OR.abs( inc( i ) ).GT.incmax )
THEN
230 WRITE( nout, fmt = 9994 )incmax
235 READ( nin, fmt = * )nalf
236 IF( nalf.LT.1.OR.nalf.GT.nalmax )
THEN
237 WRITE( nout, fmt = 9997 )
'ALPHA', nalmax
240 READ( nin, fmt = * )( alf( i ), i = 1, nalf )
242 READ( nin, fmt = * )nbet
243 IF( nbet.LT.1.OR.nbet.GT.nbemax )
THEN
244 WRITE( nout, fmt = 9997 )
'BETA', nbemax
247 READ( nin, fmt = * )( bet( i ), i = 1, nbet )
251 WRITE( nout, fmt = 9993 )
252 WRITE( nout, fmt = 9992 )( idim( i ), i = 1, nidim )
253 WRITE( nout, fmt = 9991 )( kb( i ), i = 1, nkb )
254 WRITE( nout, fmt = 9990 )( inc( i ), i = 1, ninc )
255 WRITE( nout, fmt = 9989 )( alf( i ), i = 1, nalf )
256 WRITE( nout, fmt = 9988 )( bet( i ), i = 1, nbet )
257 IF( .NOT.tsterr )
THEN
258 WRITE( nout, fmt = * )
259 WRITE( nout, fmt = 9980 )
261 WRITE( nout, fmt = * )
262 WRITE( nout, fmt = 9999 )thresh
263 WRITE( nout, fmt = * )
271 50
READ( nin, fmt = 9984,
END = 80 )SNAMET, ltestt
273 IF( snamet.EQ.snames( i ) )
276 WRITE( nout, fmt = 9986 )snamet
278 70 ltest( i ) = ltestt
287 WRITE( nout, fmt = 9998 )eps
294 a( i, j ) = max( i - j + 1, 0 )
300 yy( j ) = j*( ( j + 1 )*j )/2 - ( ( j + 1 )*j*( j - 1 ) )/3
305 CALL cmvch( trans, n, n, one, a, nmax, x, 1, zero, y, 1, yt, g,
306 $ yy, eps, err, fatal, nout, .true. )
307 same =
lce( yy, yt, n )
308 IF( .NOT.same.OR.err.NE.rzero )
THEN
309 WRITE( nout, fmt = 9985 )trans, same, err
313 CALL cmvch( trans, n, n, one, a, nmax, x, -1, zero, y, -1, yt, g,
314 $ yy, eps, err, fatal, nout, .true. )
315 same =
lce( yy, yt, n )
316 IF( .NOT.same.OR.err.NE.rzero )
THEN
317 WRITE( nout, fmt = 9985 )trans, same, err
323 DO 210 isnum = 1, nsubs
324 WRITE( nout, fmt = * )
325 IF( .NOT.ltest( isnum ) )
THEN
327 WRITE( nout, fmt = 9983 )snames( isnum )
329 srnamt = snames( isnum )
332 CALL cchke( isnum, snames( isnum ), nout )
333 WRITE( nout, fmt = * )
339 GO TO ( 140, 140, 150, 150, 150, 160, 160,
340 $ 160, 160, 160, 160, 170, 170, 180,
341 $ 180, 190, 190 )isnum
343 140
CALL cchk1( snames( isnum ), eps, thresh, nout, ntra, trace,
344 $ rewi, fatal, nidim, idim, nkb, kb, nalf, alf,
345 $ nbet, bet, ninc, inc, nmax, incmax, a, aa, as,
346 $ x, xx, xs, y, yy, ys, yt, g )
349 150
CALL cchk2( snames( isnum ), eps, thresh, nout, ntra, trace,
350 $ rewi, fatal, nidim, idim, nkb, kb, nalf, alf,
351 $ nbet, bet, ninc, inc, nmax, incmax, a, aa, as,
352 $ x, xx, xs, y, yy, ys, yt, g )
356 160
CALL cchk3( snames( isnum ), eps, thresh, nout, ntra, trace,
357 $ rewi, fatal, nidim, idim, nkb, kb, ninc, inc,
358 $ nmax, incmax, a, aa, as, y, yy, ys, yt, g, z )
361 170
CALL cchk4( snames( isnum ), eps, thresh, nout, ntra, trace,
362 $ rewi, fatal, nidim, idim, nalf, alf, ninc, inc,
363 $ nmax, incmax, a, aa, as, x, xx, xs, y, yy, ys,
367 180
CALL cchk5( snames( isnum ), eps, thresh, nout, ntra, trace,
368 $ rewi, fatal, nidim, idim, nalf, alf, ninc, inc,
369 $ nmax, incmax, a, aa, as, x, xx, xs, y, yy, ys,
373 190
CALL cchk6( snames( isnum ), eps, thresh, nout, ntra, trace,
374 $ rewi, fatal, nidim, idim, nalf, alf, ninc, inc,
375 $ nmax, incmax, a, aa, as, x, xx, xs, y, yy, ys,
378 200
IF( fatal.AND.sfatal )
382 WRITE( nout, fmt = 9982 )
386 WRITE( nout, fmt = 9981 )
390 WRITE( nout, fmt = 9987 )
398 9999
FORMAT(
' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
400 9998
FORMAT(
' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1p, e9.1 )
401 9997
FORMAT(
' NUMBER OF VALUES OF ', a,
' IS LESS THAN 1 OR GREATER ',
403 9996
FORMAT(
' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', i2 )
404 9995
FORMAT(
' VALUE OF K IS LESS THAN 0' )
405 9994
FORMAT(
' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',
407 9993
FORMAT(
' TESTS OF THE COMPLEX LEVEL 2 BLAS', //
' THE F',
408 $
'OLLOWING PARAMETER VALUES WILL BE USED:' )
409 9992
FORMAT(
' FOR N ', 9i6 )
410 9991
FORMAT(
' FOR K ', 7i6 )
411 9990
FORMAT(
' FOR INCX AND INCY ', 7i6 )
412 9989
FORMAT(
' FOR ALPHA ',
413 $ 7(
'(', f4.1,
',', f4.1,
') ', : ) )
414 9988
FORMAT(
' FOR BETA ',
415 $ 7(
'(', f4.1,
',', f4.1,
') ', : ) )
416 9987
FORMAT(
' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
417 $ /
' ******* TESTS ABANDONED *******' )
418 9986
FORMAT(
' SUBPROGRAM NAME ', a6,
' NOT RECOGNIZED', /
' ******* T',
419 $
'ESTS ABANDONED *******' )
420 9985
FORMAT(
' ERROR IN CMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
421 $
'ATED WRONGLY.', /
' CMVCH WAS CALLED WITH TRANS = ', a1,
422 $
' AND RETURNED SAME = ', l1,
' AND ERR = ', f12.3,
'.', /
423 $
' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.'
424 $ , /
' ******* TESTS ABANDONED *******' )
425 9984
FORMAT( a6, l2 )
426 9983
FORMAT( 1x, a6,
' WAS NOT TESTED' )
427 9982
FORMAT( /
' END OF TESTS' )
428 9981
FORMAT( /
' ******* FATAL ERROR - TESTS ABANDONED *******' )
429 9980
FORMAT(
' ERROR-EXITS WILL NOT BE TESTED' )
434 SUBROUTINE cchk1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
435 $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
436 $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
437 $ XS, Y, YY, YS, YT, G )
449 PARAMETER ( ZERO = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ) )
451 parameter( rzero = 0.0 )
454 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
456 LOGICAL FATAL, REWI, TRACE
459 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
460 $ as( nmax*nmax ), bet( nbet ), x( nmax ),
461 $ xs( nmax*incmax ), xx( nmax*incmax ),
462 $ y( nmax ), ys( nmax*incmax ), yt( nmax ),
465 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
467 COMPLEX ALPHA, ALS, BETA, BLS, TRANSL
469 INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
470 $ incys, ix, iy, kl, kls, ku, kus, laa, lda,
471 $ ldas, lx, ly, m, ml, ms, n, nargs, nc, nd, nk,
473 LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN
474 CHARACTER*1 TRANS, TRANSS
484 INTRINSIC abs, max, min
489 COMMON /infoc/infot, noutc, ok, lerr
493 full = sname( 3: 3 ).EQ.
'E'
494 banded = sname( 3: 3 ).EQ.
'B'
498 ELSE IF( banded )
THEN
512 $ m = max( n - nd, 0 )
514 $ m = min( n + nd, nmax )
524 kl = max( ku - 1, 0 )
541 null = n.LE.0.OR.m.LE.0
546 CALL cmake( sname( 2: 3 ),
' ',
' ', m, n, a, nmax, aa,
547 $ lda, kl, ku, reset, transl )
550 trans = ich( ic: ic )
551 tran = trans.EQ.
'T'.OR.trans.EQ.
'C'
568 CALL cmake(
'GE',
' ',
' ', 1, nl, x, 1, xx,
569 $ abs( incx ), 0, nl - 1, reset, transl )
572 xx( 1 + abs( incx )*( nl/2 - 1 ) ) = zero
588 CALL cmake(
'GE',
' ',
' ', 1, ml, y, 1,
589 $ yy, abs( incy ), 0, ml - 1,
621 $
WRITE( ntra, fmt = 9994 )nc, sname,
622 $ trans, m, n, alpha, lda, incx, beta,
626 CALL cgemv( trans, m, n, alpha, aa,
627 $ lda, xx, incx, beta, yy,
629 ELSE IF( banded )
THEN
631 $
WRITE( ntra, fmt = 9995 )nc, sname,
632 $ trans, m, n, kl, ku, alpha, lda,
636 CALL cgbmv( trans, m, n, kl, ku, alpha,
637 $ aa, lda, xx, incx, beta,
644 WRITE( nout, fmt = 9993 )
651 isame( 1 ) = trans.EQ.transs
655 isame( 4 ) = als.EQ.alpha
656 isame( 5 ) = lce( as, aa, laa )
657 isame( 6 ) = ldas.EQ.lda
658 isame( 7 ) = lce( xs, xx, lx )
659 isame( 8 ) = incxs.EQ.incx
660 isame( 9 ) = bls.EQ.beta
662 isame( 10 ) = lce( ys, yy, ly )
664 isame( 10 ) = lceres(
'GE',
' ', 1,
668 isame( 11 ) = incys.EQ.incy
669 ELSE IF( banded )
THEN
670 isame( 4 ) = kls.EQ.kl
671 isame( 5 ) = kus.EQ.ku
672 isame( 6 ) = als.EQ.alpha
673 isame( 7 ) = lce( as, aa, laa )
674 isame( 8 ) = ldas.EQ.lda
675 isame( 9 ) = lce( xs, xx, lx )
676 isame( 10 ) = incxs.EQ.incx
677 isame( 11 ) = bls.EQ.beta
679 isame( 12 ) = lce( ys, yy, ly )
681 isame( 12 ) = lceres(
'GE',
' ', 1,
685 isame( 13 ) = incys.EQ.incy
693 same = same.AND.isame( i )
694 IF( .NOT.isame( i ) )
695 $
WRITE( nout, fmt = 9998 )i
706 CALL cmvch( trans, m, n, alpha, a,
707 $ nmax, x, incx, beta, y,
708 $ incy, yt, g, yy, eps, err,
709 $ fatal, nout, .true. )
710 errmax = max( errmax, err )
739 IF( errmax.LT.thresh )
THEN
740 WRITE( nout, fmt = 9999 )sname, nc
742 WRITE( nout, fmt = 9997 )sname, nc, errmax
747 WRITE( nout, fmt = 9996 )sname
749 WRITE( nout, fmt = 9994 )nc, sname, trans, m, n, alpha, lda,
751 ELSE IF( banded )
THEN
752 WRITE( nout, fmt = 9995 )nc, sname, trans, m, n, kl, ku,
753 $ alpha, lda, incx, beta, incy
759 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
761 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
762 $
'ANGED INCORRECTLY *******' )
763 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
764 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
765 $
' - SUSPECT *******' )
766 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
767 9995
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', 4( i3,
',' ),
'(',
768 $ f4.1,
',', f4.1,
'), A,', i3,
', X,', i2,
',(', f4.1,
',',
769 $ f4.1,
'), Y,', i2,
') .' )
770 9994
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', 2( i3,
',' ),
'(',
771 $ f4.1,
',', f4.1,
'), A,', i3,
', X,', i2,
',(', f4.1,
',',
772 $ f4.1,
'), Y,', i2,
') .' )
773 9993
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
779 SUBROUTINE cchk2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
780 $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
781 $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
782 $ XS, Y, YY, YS, YT, G )
794 PARAMETER ( ZERO = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ) )
796 PARAMETER ( RZERO = 0.0 )
799 INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
801 LOGICAL FATAL, REWI, TRACE
804 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
805 $ as( nmax*nmax ), bet( nbet ), x( nmax ),
806 $ xs( nmax*incmax ), xx( nmax*incmax ),
807 $ y( nmax ), ys( nmax*incmax ), yt( nmax ),
810 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
812 COMPLEX ALPHA, ALS, BETA, BLS, TRANSL
814 INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
815 $ incys, ix, iy, k, ks, laa, lda, ldas, lx, ly,
816 $ n, nargs, nc, nk, ns
817 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
818 CHARACTER*1 UPLO, UPLOS
833 COMMON /infoc/infot, noutc, ok, lerr
837 full = sname( 3: 3 ).EQ.
'E'
838 banded = sname( 3: 3 ).EQ.
'B'
839 packed = sname( 3: 3 ).EQ.
'P'
843 ELSE IF( banded )
THEN
845 ELSE IF( packed )
THEN
879 laa = ( n*( n + 1 ) )/2
891 CALL cmake( sname( 2: 3 ), uplo,
' ', n, n, a, nmax, aa,
892 $ lda, k, k, reset, transl )
901 CALL cmake(
'GE',
' ',
' ', 1, n, x, 1, xx,
902 $ abs( incx ), 0, n - 1, reset, transl )
905 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
921 CALL cmake(
'GE',
' ',
' ', 1, n, y, 1, yy,
922 $ abs( incy ), 0, n - 1, reset,
952 $
WRITE( ntra, fmt = 9993 )nc, sname,
953 $ uplo, n, alpha, lda, incx, beta, incy
956 CALL chemv( uplo, n, alpha, aa, lda, xx,
957 $ incx, beta, yy, incy )
958 ELSE IF( banded )
THEN
960 $
WRITE( ntra, fmt = 9994 )nc, sname,
961 $ uplo, n, k, alpha, lda, incx, beta,
965 CALL chbmv( uplo, n, k, alpha, aa, lda,
966 $ xx, incx, beta, yy, incy )
967 ELSE IF( packed )
THEN
969 $
WRITE( ntra, fmt = 9995 )nc, sname,
970 $ uplo, n, alpha, incx, beta, incy
973 CALL chpmv( uplo, n, alpha, aa, xx, incx,
980 WRITE( nout, fmt = 9992 )
987 isame( 1 ) = uplo.EQ.uplos
990 isame( 3 ) = als.EQ.alpha
991 isame( 4 ) = lce( as, aa, laa )
992 isame( 5 ) = ldas.EQ.lda
993 isame( 6 ) = lce( xs, xx, lx )
994 isame( 7 ) = incxs.EQ.incx
995 isame( 8 ) = bls.EQ.beta
997 isame( 9 ) = lce( ys, yy, ly )
999 isame( 9 ) = lceres(
'GE',
' ', 1, n,
1000 $ ys, yy, abs( incy ) )
1002 isame( 10 ) = incys.EQ.incy
1003 ELSE IF( banded )
THEN
1004 isame( 3 ) = ks.EQ.k
1005 isame( 4 ) = als.EQ.alpha
1006 isame( 5 ) = lce( as, aa, laa )
1007 isame( 6 ) = ldas.EQ.lda
1008 isame( 7 ) = lce( xs, xx, lx )
1009 isame( 8 ) = incxs.EQ.incx
1010 isame( 9 ) = bls.EQ.beta
1012 isame( 10 ) = lce( ys, yy, ly )
1014 isame( 10 ) = lceres(
'GE',
' ', 1, n,
1015 $ ys, yy, abs( incy ) )
1017 isame( 11 ) = incys.EQ.incy
1018 ELSE IF( packed )
THEN
1019 isame( 3 ) = als.EQ.alpha
1020 isame( 4 ) = lce( as, aa, laa )
1021 isame( 5 ) = lce( xs, xx, lx )
1022 isame( 6 ) = incxs.EQ.incx
1023 isame( 7 ) = bls.EQ.beta
1025 isame( 8 ) = lce( ys, yy, ly )
1027 isame( 8 ) = lceres(
'GE',
' ', 1, n,
1028 $ ys, yy, abs( incy ) )
1030 isame( 9 ) = incys.EQ.incy
1038 same = same.AND.isame( i )
1039 IF( .NOT.isame( i ) )
1040 $
WRITE( nout, fmt = 9998 )i
1051 CALL cmvch(
'N', n, n, alpha, a, nmax, x,
1052 $ incx, beta, y, incy, yt, g,
1053 $ yy, eps, err, fatal, nout,
1055 errmax = max( errmax, err )
1081 IF( errmax.LT.thresh )
THEN
1082 WRITE( nout, fmt = 9999 )sname, nc
1084 WRITE( nout, fmt = 9997 )sname, nc, errmax
1089 WRITE( nout, fmt = 9996 )sname
1091 WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, lda, incx,
1093 ELSE IF( banded )
THEN
1094 WRITE( nout, fmt = 9994 )nc, sname, uplo, n, k, alpha, lda,
1096 ELSE IF( packed )
THEN
1097 WRITE( nout, fmt = 9995 )nc, sname, uplo, n, alpha, incx,
1104 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
1106 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
1107 $
'ANGED INCORRECTLY *******' )
1108 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
1109 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1110 $
' - SUSPECT *******' )
1111 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
1112 9995
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', i3,
',(', f4.1,
',',
1113 $ f4.1,
'), AP, X,', i2,
',(', f4.1,
',', f4.1,
'), Y,', i2,
1115 9994
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', 2( i3,
',' ),
'(',
1116 $ f4.1,
',', f4.1,
'), A,', i3,
', X,', i2,
',(', f4.1,
',',
1117 $ f4.1,
'), Y,', i2,
') .' )
1118 9993
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', i3,
',(', f4.1,
',',
1119 $ f4.1,
'), A,', i3,
', X,', i2,
',(', f4.1,
',', f4.1,
'), ',
1121 9992
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1127 SUBROUTINE cchk3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1128 $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX,
1129 $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z )
1140 COMPLEX ZERO, HALF, ONE
1141 PARAMETER ( ZERO = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
1142 $ one = ( 1.0, 0.0 ) )
1144 PARAMETER ( RZERO = 0.0 )
1147 INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA
1148 LOGICAL FATAL, REWI, TRACE
1151 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ),
1152 $ as( nmax*nmax ), x( nmax ), xs( nmax*incmax ),
1153 $ xt( nmax ), xx( nmax*incmax ), z( nmax )
1155 INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
1159 INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
1160 $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
1161 LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
1162 CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
1163 CHARACTER*2 ICHD, ICHU
1169 EXTERNAL lce, lceres
1176 INTEGER INFOT, NOUTC
1179 COMMON /infoc/infot, noutc, ok, lerr
1181 DATA ichu/
'UL'/, icht/
'NTC'/, ichd/
'UN'/
1183 full = sname( 3: 3 ).EQ.
'R'
1184 banded = sname( 3: 3 ).EQ.
'B'
1185 packed = sname( 3: 3 ).EQ.
'P'
1189 ELSE IF( banded )
THEN
1191 ELSE IF( packed )
THEN
1203 DO 110 in = 1, nidim
1229 laa = ( n*( n + 1 ) )/2
1236 uplo = ichu( icu: icu )
1239 trans = icht( ict: ict )
1242 diag = ichd( icd: icd )
1247 CALL cmake( sname( 2: 3 ), uplo, diag, n, n, a,
1248 $ nmax, aa, lda, k, k, reset, transl )
1257 CALL cmake(
'GE',
' ',
' ', 1, n, x, 1, xx,
1258 $ abs( incx ), 0, n - 1, reset,
1262 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1285 IF( sname( 4: 5 ).EQ.
'MV' )
THEN
1288 $
WRITE( ntra, fmt = 9993 )nc, sname,
1289 $ uplo, trans, diag, n, lda, incx
1292 CALL ctrmv( uplo, trans, diag, n, aa, lda,
1294 ELSE IF( banded )
THEN
1296 $
WRITE( ntra, fmt = 9994 )nc, sname,
1297 $ uplo, trans, diag, n, k, lda, incx
1300 CALL ctbmv( uplo, trans, diag, n, k, aa,
1302 ELSE IF( packed )
THEN
1304 $
WRITE( ntra, fmt = 9995 )nc, sname,
1305 $ uplo, trans, diag, n, incx
1308 CALL ctpmv( uplo, trans, diag, n, aa, xx,
1311 ELSE IF( sname( 4: 5 ).EQ.
'SV' )
THEN
1314 $
WRITE( ntra, fmt = 9993 )nc, sname,
1315 $ uplo, trans, diag, n, lda, incx
1318 CALL ctrsv( uplo, trans, diag, n, aa, lda,
1320 ELSE IF( banded )
THEN
1322 $
WRITE( ntra, fmt = 9994 )nc, sname,
1323 $ uplo, trans, diag, n, k, lda, incx
1326 CALL ctbsv( uplo, trans, diag, n, k, aa,
1328 ELSE IF( packed )
THEN
1330 $
WRITE( ntra, fmt = 9995 )nc, sname,
1331 $ uplo, trans, diag, n, incx
1334 CALL ctpsv( uplo, trans, diag, n, aa, xx,
1342 WRITE( nout, fmt = 9992 )
1349 isame( 1 ) = uplo.EQ.uplos
1350 isame( 2 ) = trans.EQ.transs
1351 isame( 3 ) = diag.EQ.diags
1352 isame( 4 ) = ns.EQ.n
1354 isame( 5 ) = lce( as, aa, laa )
1355 isame( 6 ) = ldas.EQ.lda
1357 isame( 7 ) = lce( xs, xx, lx )
1359 isame( 7 ) = lceres(
'GE',
' ', 1, n, xs,
1362 isame( 8 ) = incxs.EQ.incx
1363 ELSE IF( banded )
THEN
1364 isame( 5 ) = ks.EQ.k
1365 isame( 6 ) = lce( as, aa, laa )
1366 isame( 7 ) = ldas.EQ.lda
1368 isame( 8 ) = lce( xs, xx, lx )
1370 isame( 8 ) = lceres(
'GE',
' ', 1, n, xs,
1373 isame( 9 ) = incxs.EQ.incx
1374 ELSE IF( packed )
THEN
1375 isame( 5 ) = lce( as, aa, laa )
1377 isame( 6 ) = lce( xs, xx, lx )
1379 isame( 6 ) = lceres(
'GE',
' ', 1, n, xs,
1382 isame( 7 ) = incxs.EQ.incx
1390 same = same.AND.isame( i )
1391 IF( .NOT.isame( i ) )
1392 $
WRITE( nout, fmt = 9998 )i
1400 IF( sname( 4: 5 ).EQ.
'MV' )
THEN
1404 CALL cmvch( trans, n, n, one, a, nmax, x,
1405 $ incx, zero, z, incx, xt, g,
1406 $ xx, eps, err, fatal, nout,
1408 ELSE IF( sname( 4: 5 ).EQ.
'SV' )
THEN
1413 z( i ) = xx( 1 + ( i - 1 )*
1415 xx( 1 + ( i - 1 )*abs( incx ) )
1418 CALL cmvch( trans, n, n, one, a, nmax, z,
1419 $ incx, zero, x, incx, xt, g,
1420 $ xx, eps, err, fatal, nout,
1423 errmax = max( errmax, err )
1446 IF( errmax.LT.thresh )
THEN
1447 WRITE( nout, fmt = 9999 )sname, nc
1449 WRITE( nout, fmt = 9997 )sname, nc, errmax
1454 WRITE( nout, fmt = 9996 )sname
1456 WRITE( nout, fmt = 9993 )nc, sname, uplo, trans, diag, n, lda,
1458 ELSE IF( banded )
THEN
1459 WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, diag, n, k,
1461 ELSE IF( packed )
THEN
1462 WRITE( nout, fmt = 9995 )nc, sname, uplo, trans, diag, n, incx
1468 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
1470 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
1471 $
'ANGED INCORRECTLY *******' )
1472 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
1473 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1474 $
' - SUSPECT *******' )
1475 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
1476 9995
FORMAT( 1x, i6,
': ', a6,
'(', 3(
'''', a1,
''',' ), i3,
', AP, ',
1478 9994
FORMAT( 1x, i6,
': ', a6,
'(', 3(
'''', a1,
''',' ), 2( i3,
',' ),
1479 $
' A,', i3,
', X,', i2,
') .' )
1480 9993
FORMAT( 1x, i6,
': ', a6,
'(', 3(
'''', a1,
''',' ), i3,
', A,',
1481 $ i3,
', X,', i2,
') .' )
1482 9992
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1488 SUBROUTINE cchk4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1489 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1490 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1502 COMPLEX ZERO, HALF, ONE
1503 PARAMETER ( ZERO = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
1504 $ one = ( 1.0, 0.0 ) )
1506 PARAMETER ( RZERO = 0.0 )
1509 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1510 LOGICAL FATAL, REWI, TRACE
1513 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1514 $ as( nmax*nmax ), x( nmax ), xs( nmax*incmax ),
1515 $ xx( nmax*incmax ), y( nmax ),
1516 $ ys( nmax*incmax ), yt( nmax ),
1517 $ yy( nmax*incmax ), z( nmax )
1519 INTEGER IDIM( NIDIM ), INC( NINC )
1521 COMPLEX ALPHA, ALS, TRANSL
1523 INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
1524 $ iy, j, laa, lda, ldas, lx, ly, m, ms, n, nargs,
1526 LOGICAL CONJ, NULL, RESET, SAME
1532 EXTERNAL lce, lceres
1536 INTRINSIC abs, conjg, max, min
1538 INTEGER INFOT, NOUTC
1541 COMMON /infoc/infot, noutc, ok, lerr
1543 conj = sname( 5: 5 ).EQ.
'C'
1551 DO 120 in = 1, nidim
1557 $ m = max( n - nd, 0 )
1559 $ m = min( n + nd, nmax )
1569 null = n.LE.0.OR.m.LE.0
1578 CALL cmake(
'GE',
' ',
' ', 1, m, x, 1, xx, abs( incx ),
1579 $ 0, m - 1, reset, transl )
1582 xx( 1 + abs( incx )*( m/2 - 1 ) ) = zero
1592 CALL cmake(
'GE',
' ',
' ', 1, n, y, 1, yy,
1593 $ abs( incy ), 0, n - 1, reset, transl )
1596 yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
1605 CALL cmake( sname( 2: 3 ),
' ',
' ', m, n, a, nmax,
1606 $ aa, lda, m - 1, n - 1, reset, transl )
1631 $
WRITE( ntra, fmt = 9994 )nc, sname, m, n,
1632 $ alpha, incx, incy, lda
1636 CALL cgerc( m, n, alpha, xx, incx, yy, incy, aa,
1641 CALL cgeru( m, n, alpha, xx, incx, yy, incy, aa,
1648 WRITE( nout, fmt = 9993 )
1655 isame( 1 ) = ms.EQ.m
1656 isame( 2 ) = ns.EQ.n
1657 isame( 3 ) = als.EQ.alpha
1658 isame( 4 ) = lce( xs, xx, lx )
1659 isame( 5 ) = incxs.EQ.incx
1660 isame( 6 ) = lce( ys, yy, ly )
1661 isame( 7 ) = incys.EQ.incy
1663 isame( 8 ) = lce( as, aa, laa )
1665 isame( 8 ) = lceres(
'GE',
' ', m, n, as, aa,
1668 isame( 9 ) = ldas.EQ.lda
1674 same = same.AND.isame( i )
1675 IF( .NOT.isame( i ) )
1676 $
WRITE( nout, fmt = 9998 )i
1693 z( i ) = x( m - i + 1 )
1700 w( 1 ) = y( n - j + 1 )
1703 $ w( 1 ) = conjg( w( 1 ) )
1704 CALL cmvch(
'N', m, 1, alpha, z, nmax, w, 1,
1705 $ one, a( 1, j ), 1, yt, g,
1706 $ aa( 1 + ( j - 1 )*lda ), eps,
1707 $ err, fatal, nout, .true. )
1708 errmax = max( errmax, err )
1730 IF( errmax.LT.thresh )
THEN
1731 WRITE( nout, fmt = 9999 )sname, nc
1733 WRITE( nout, fmt = 9997 )sname, nc, errmax
1738 WRITE( nout, fmt = 9995 )j
1741 WRITE( nout, fmt = 9996 )sname
1742 WRITE( nout, fmt = 9994 )nc, sname, m, n, alpha, incx, incy, lda
1747 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
1749 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
1750 $
'ANGED INCORRECTLY *******' )
1751 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
1752 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1753 $
' - SUSPECT *******' )
1754 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
1755 9995
FORMAT(
' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1756 9994
FORMAT( 1x, i6,
': ', a6,
'(', 2( i3,
',' ),
'(', f4.1,
',', f4.1,
1757 $
'), X,', i2,
', Y,', i2,
', A,', i3,
') ',
1759 9993
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1765 SUBROUTINE cchk5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1766 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
1767 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
1779 COMPLEX ZERO, HALF, ONE
1780 PARAMETER ( ZERO = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
1781 $ one = ( 1.0, 0.0 ) )
1783 PARAMETER ( RZERO = 0.0 )
1786 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
1787 LOGICAL FATAL, REWI, TRACE
1790 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
1791 $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
1792 $ XX( NMAX*INCMAX ), Y( NMAX ),
1793 $ ys( nmax*incmax ), yt( nmax ),
1794 $ yy( nmax*incmax ), z( nmax )
1796 INTEGER IDIM( NIDIM ), INC( NINC )
1798 COMPLEX ALPHA, TRANSL
1799 REAL ERR, ERRMAX, RALPHA, RALS
1800 INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
1801 $ lda, ldas, lj, lx, n, nargs, nc, ns
1802 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
1803 CHARACTER*1 UPLO, UPLOS
1810 EXTERNAL lce, lceres
1814 INTRINSIC abs, cmplx, conjg, max, real
1816 INTEGER INFOT, NOUTC
1819 COMMON /infoc/infot, noutc, ok, lerr
1823 full = sname( 3: 3 ).EQ.
'E'
1824 packed = sname( 3: 3 ).EQ.
'P'
1828 ELSE IF( packed )
THEN
1836 DO 100 in = 1, nidim
1846 laa = ( n*( n + 1 ) )/2
1852 uplo = ich( ic: ic )
1862 CALL cmake(
'GE',
' ',
' ', 1, n, x, 1, xx, abs( incx ),
1863 $ 0, n - 1, reset, transl )
1866 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1870 ralpha = real( alf( ia ) )
1871 alpha = cmplx( ralpha, rzero )
1872 null = n.LE.0.OR.ralpha.EQ.rzero
1877 CALL cmake( sname( 2: 3 ), uplo,
' ', n, n, a, nmax,
1878 $ aa, lda, n - 1, n - 1, reset, transl )
1900 $
WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
1904 CALL cher( uplo, n, ralpha, xx, incx, aa, lda )
1905 ELSE IF( packed )
THEN
1907 $
WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
1911 CALL chpr( uplo, n, ralpha, xx, incx, aa )
1917 WRITE( nout, fmt = 9992 )
1924 isame( 1 ) = uplo.EQ.uplos
1925 isame( 2 ) = ns.EQ.n
1926 isame( 3 ) = rals.EQ.ralpha
1927 isame( 4 ) = lce( xs, xx, lx )
1928 isame( 5 ) = incxs.EQ.incx
1930 isame( 6 ) = lce( as, aa, laa )
1932 isame( 6 ) = lceres( sname( 2: 3 ), uplo, n, n, as,
1935 IF( .NOT.packed )
THEN
1936 isame( 7 ) = ldas.EQ.lda
1943 same = same.AND.isame( i )
1944 IF( .NOT.isame( i ) )
1945 $
WRITE( nout, fmt = 9998 )i
1962 z( i ) = x( n - i + 1 )
1967 w( 1 ) = conjg( z( j ) )
1975 CALL cmvch(
'N', lj, 1, alpha, z( jj ), lj, w,
1976 $ 1, one, a( jj, j ), 1, yt, g,
1977 $ aa( ja ), eps, err, fatal, nout,
1988 errmax = max( errmax, err )
2009 IF( errmax.LT.thresh )
THEN
2010 WRITE( nout, fmt = 9999 )sname, nc
2012 WRITE( nout, fmt = 9997 )sname, nc, errmax
2017 WRITE( nout, fmt = 9995 )j
2020 WRITE( nout, fmt = 9996 )sname
2022 WRITE( nout, fmt = 9993 )nc, sname, uplo, n, ralpha, incx, lda
2023 ELSE IF( packed )
THEN
2024 WRITE( nout, fmt = 9994 )nc, sname, uplo, n, ralpha, incx
2030 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
2032 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
2033 $
'ANGED INCORRECTLY *******' )
2034 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
2035 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2036 $
' - SUSPECT *******' )
2037 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
2038 9995
FORMAT(
' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2039 9994
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', i3,
',', f4.1,
', X,',
2041 9993
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', i3,
',', f4.1,
', X,',
2042 $ i2,
', A,', i3,
') .' )
2043 9992
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2049 SUBROUTINE cchk6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
2050 $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
2051 $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
2063 COMPLEX ZERO, HALF, ONE
2064 PARAMETER ( ZERO = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ),
2065 $ one = ( 1.0, 0.0 ) )
2067 PARAMETER ( RZERO = 0.0 )
2070 INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
2071 LOGICAL FATAL, REWI, TRACE
2074 COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
2075 $ AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
2076 $ XX( NMAX*INCMAX ), Y( NMAX ),
2077 $ YS( NMAX*INCMAX ), YT( NMAX ),
2078 $ YY( NMAX*INCMAX ), Z( NMAX, 2 )
2080 INTEGER IDIM( NIDIM ), INC( NINC )
2082 COMPLEX ALPHA, ALS, TRANSL
2084 INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
2085 $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
2087 LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
2088 CHARACTER*1 UPLO, UPLOS
2095 EXTERNAL LCE, LCERES
2099 INTRINSIC abs, conjg, max
2101 INTEGER INFOT, NOUTC
2104 COMMON /infoc/infot, noutc, ok, lerr
2108 full = sname( 3: 3 ).EQ.
'E'
2109 packed = sname( 3: 3 ).EQ.
'P'
2113 ELSE IF( packed )
THEN
2121 DO 140 in = 1, nidim
2131 laa = ( n*( n + 1 ) )/2
2137 uplo = ich( ic: ic )
2147 CALL cmake(
'GE',
' ',
' ', 1, n, x, 1, xx, abs( incx ),
2148 $ 0, n - 1, reset, transl )
2151 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
2161 CALL cmake(
'GE',
' ',
' ', 1, n, y, 1, yy,
2162 $ abs( incy ), 0, n - 1, reset, transl )
2165 yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
2170 null = n.LE.0.OR.alpha.EQ.zero
2175 CALL cmake( sname( 2: 3 ), uplo,
' ', n, n, a,
2176 $ nmax, aa, lda, n - 1, n - 1, reset,
2203 $
WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
2204 $ alpha, incx, incy, lda
2207 CALL cher2( uplo, n, alpha, xx, incx, yy, incy,
2209 ELSE IF( packed )
THEN
2211 $
WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
2215 CALL chpr2( uplo, n, alpha, xx, incx, yy, incy,
2222 WRITE( nout, fmt = 9992 )
2229 isame( 1 ) = uplo.EQ.uplos
2230 isame( 2 ) = ns.EQ.n
2231 isame( 3 ) = als.EQ.alpha
2232 isame( 4 ) = lce( xs, xx, lx )
2233 isame( 5 ) = incxs.EQ.incx
2234 isame( 6 ) = lce( ys, yy, ly )
2235 isame( 7 ) = incys.EQ.incy
2237 isame( 8 ) = lce( as, aa, laa )
2239 isame( 8 ) = lceres( sname( 2: 3 ), uplo, n, n,
2242 IF( .NOT.packed )
THEN
2243 isame( 9 ) = ldas.EQ.lda
2250 same = same.AND.isame( i )
2251 IF( .NOT.isame( i ) )
2252 $
WRITE( nout, fmt = 9998 )i
2269 z( i, 1 ) = x( n - i + 1 )
2278 z( i, 2 ) = y( n - i + 1 )
2283 w( 1 ) = alpha*conjg( z( j, 2 ) )
2284 w( 2 ) = conjg( alpha )*conjg( z( j, 1 ) )
2292 CALL cmvch(
'N', lj, 2, one, z( jj, 1 ),
2293 $ nmax, w, 1, one, a( jj, j ), 1,
2294 $ yt, g, aa( ja ), eps, err, fatal,
2305 errmax = max( errmax, err )
2328 IF( errmax.LT.thresh )
THEN
2329 WRITE( nout, fmt = 9999 )sname, nc
2331 WRITE( nout, fmt = 9997 )sname, nc, errmax
2336 WRITE( nout, fmt = 9995 )j
2339 WRITE( nout, fmt = 9996 )sname
2341 WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, incx,
2343 ELSE IF( packed )
THEN
2344 WRITE( nout, fmt = 9994 )nc, sname, uplo, n, alpha, incx, incy
2350 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
2352 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
2353 $
'ANGED INCORRECTLY *******' )
2354 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
2355 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2356 $
' - SUSPECT *******' )
2357 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
2358 9995
FORMAT(
' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2359 9994
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', i3,
',(', f4.1,
',',
2360 $ f4.1,
'), X,', i2,
', Y,', i2,
', AP) ',
2362 9993
FORMAT( 1x, i6,
': ', a6,
'(''', a1,
''',', i3,
',(', f4.1,
',',
2363 $ f4.1,
'), X,', i2,
', Y,', i2,
', A,', i3,
') ',
2365 9992
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2387 INTEGER INFOT, NOUTC
2393 COMPLEX A( 1, 1 ), X( 1 ), Y( 1 )
2395 EXTERNAL CGBMV, CGEMV, CGERC, CGERU, CHBMV, CHEMV, CHER,
2396 $ CHER2, CHKXER, CHPMV, CHPR, CHPR2, CTBMV,
2397 $ CTBSV, CTPMV, CTPSV, CTRMV, CTRSV
2399 COMMON /INFOC/INFOT, NOUTC, OK, LERR
2407 GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
2408 $ 90, 100, 110, 120, 130, 140, 150, 160,
2411 CALL cgemv(
'/', 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2412 CALL chkxer( srnamt, infot, nout, lerr, ok )
2414 CALL cgemv(
'N', -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2415 CALL chkxer( srnamt, infot, nout, lerr, ok )
2417 CALL cgemv(
'N', 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2418 CALL chkxer( srnamt, infot, nout, lerr, ok )
2420 CALL cgemv(
'N', 2, 0, alpha, a, 1, x, 1, beta, y, 1 )
2421 CALL chkxer( srnamt, infot, nout, lerr, ok )
2423 CALL cgemv(
'N', 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2424 CALL chkxer( srnamt, infot, nout, lerr, ok )
2426 CALL cgemv(
'N', 0, 0, alpha, a, 1, x, 1, beta, y, 0 )
2427 CALL chkxer( srnamt, infot, nout, lerr, ok )
2430 CALL cgbmv(
'/', 0, 0, 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2431 CALL chkxer( srnamt, infot, nout, lerr, ok )
2433 CALL cgbmv(
'N', -1, 0, 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2434 CALL chkxer( srnamt, infot, nout, lerr, ok )
2436 CALL cgbmv(
'N', 0, -1, 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2437 CALL chkxer( srnamt, infot, nout, lerr, ok )
2439 CALL cgbmv(
'N', 0, 0, -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2440 CALL chkxer( srnamt, infot, nout, lerr, ok )
2442 CALL cgbmv(
'N', 2, 0, 0, -1, alpha, a, 1, x, 1, beta, y, 1 )
2443 CALL chkxer( srnamt, infot, nout, lerr, ok )
2445 CALL cgbmv(
'N', 0, 0, 1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2446 CALL chkxer( srnamt, infot, nout, lerr, ok )
2448 CALL cgbmv(
'N', 0, 0, 0, 0, alpha, a, 1, x, 0, beta, y, 1 )
2449 CALL chkxer( srnamt, infot, nout, lerr, ok )
2451 CALL cgbmv(
'N', 0, 0, 0, 0, alpha, a, 1, x, 1, beta, y, 0 )
2452 CALL chkxer( srnamt, infot, nout, lerr, ok )
2455 CALL chemv(
'/', 0, alpha, a, 1, x, 1, beta, y, 1 )
2456 CALL chkxer( srnamt, infot, nout, lerr, ok )
2458 CALL chemv(
'U', -1, alpha, a, 1, x, 1, beta, y, 1 )
2459 CALL chkxer( srnamt, infot, nout, lerr, ok )
2461 CALL chemv(
'U', 2, alpha, a, 1, x, 1, beta, y, 1 )
2462 CALL chkxer( srnamt, infot, nout, lerr, ok )
2464 CALL chemv(
'U', 0, alpha, a, 1, x, 0, beta, y, 1 )
2465 CALL chkxer( srnamt, infot, nout, lerr, ok )
2467 CALL chemv(
'U', 0, alpha, a, 1, x, 1, beta, y, 0 )
2468 CALL chkxer( srnamt, infot, nout, lerr, ok )
2471 CALL chbmv(
'/', 0, 0, alpha, a, 1, x, 1, beta, y, 1 )
2472 CALL chkxer( srnamt, infot, nout, lerr, ok )
2474 CALL chbmv(
'U', -1, 0, alpha, a, 1, x, 1, beta, y, 1 )
2475 CALL chkxer( srnamt, infot, nout, lerr, ok )
2477 CALL chbmv(
'U', 0, -1, 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, 0, alpha, a, 1, x, 0, beta, y, 1 )
2484 CALL chkxer( srnamt, infot, nout, lerr, ok )
2486 CALL chbmv(
'U', 0, 0, alpha, a, 1, x, 1, beta, y, 0 )
2487 CALL chkxer( srnamt, infot, nout, lerr, ok )
2490 CALL chpmv(
'/', 0, alpha, a, x, 1, beta, y, 1 )
2491 CALL chkxer( srnamt, infot, nout, lerr, ok )
2493 CALL chpmv(
'U', -1, alpha, a, x, 1, beta, y, 1 )
2494 CALL chkxer( srnamt, infot, nout, lerr, ok )
2496 CALL chpmv(
'U', 0, alpha, a, x, 0, beta, y, 1 )
2497 CALL chkxer( srnamt, infot, nout, lerr, ok )
2499 CALL chpmv(
'U', 0, alpha, a, x, 1, beta, y, 0 )
2500 CALL chkxer( srnamt, infot, nout, lerr, ok )
2503 CALL ctrmv(
'/',
'N',
'N', 0, a, 1, x, 1 )
2504 CALL chkxer( srnamt, infot, nout, lerr, ok )
2506 CALL ctrmv(
'U',
'/',
'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',
'N', -1, a, 1, x, 1 )
2513 CALL chkxer( srnamt, infot, nout, lerr, ok )
2515 CALL ctrmv(
'U',
'N',
'N', 2, a, 1, x, 1 )
2516 CALL chkxer( srnamt, infot, nout, lerr, ok )
2518 CALL ctrmv(
'U',
'N',
'N', 0, a, 1, x, 0 )
2519 CALL chkxer( srnamt, infot, nout, lerr, ok )
2522 CALL ctbmv(
'/',
'N',
'N', 0, 0, a, 1, x, 1 )
2523 CALL chkxer( srnamt, infot, nout, lerr, ok )
2525 CALL ctbmv(
'U',
'/',
'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',
'N', -1, 0, a, 1, x, 1 )
2532 CALL chkxer( srnamt, infot, nout, lerr, ok )
2534 CALL ctbmv(
'U',
'N',
'N', 0, -1, 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, 0, a, 1, x, 0 )
2541 CALL chkxer( srnamt, infot, nout, lerr, ok )
2544 CALL ctpmv(
'/',
'N',
'N', 0, a, x, 1 )
2545 CALL chkxer( srnamt, infot, nout, lerr, ok )
2547 CALL ctpmv(
'U',
'/',
'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',
'N', -1, a, x, 1 )
2554 CALL chkxer( srnamt, infot, nout, lerr, ok )
2556 CALL ctpmv(
'U',
'N',
'N', 0, a, x, 0 )
2557 CALL chkxer( srnamt, infot, nout, lerr, ok )
2560 CALL ctrsv(
'/',
'N',
'N', 0, a, 1, x, 1 )
2561 CALL chkxer( srnamt, infot, nout, lerr, ok )
2563 CALL ctrsv(
'U',
'/',
'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',
'N', -1, a, 1, x, 1 )
2570 CALL chkxer( srnamt, infot, nout, lerr, ok )
2572 CALL ctrsv(
'U',
'N',
'N', 2, a, 1, x, 1 )
2573 CALL chkxer( srnamt, infot, nout, lerr, ok )
2575 CALL ctrsv(
'U',
'N',
'N', 0, a, 1, x, 0 )
2576 CALL chkxer( srnamt, infot, nout, lerr, ok )
2579 CALL ctbsv(
'/',
'N',
'N', 0, 0, a, 1, x, 1 )
2580 CALL chkxer( srnamt, infot, nout, lerr, ok )
2582 CALL ctbsv(
'U',
'/',
'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',
'N', -1, 0, a, 1, x, 1 )
2589 CALL chkxer( srnamt, infot, nout, lerr, ok )
2591 CALL ctbsv(
'U',
'N',
'N', 0, -1, 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, 0, a, 1, x, 0 )
2598 CALL chkxer( srnamt, infot, nout, lerr, ok )
2601 CALL ctpsv(
'/',
'N',
'N', 0, a, x, 1 )
2602 CALL chkxer( srnamt, infot, nout, lerr, ok )
2604 CALL ctpsv(
'U',
'/',
'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',
'N', -1, a, x, 1 )
2611 CALL chkxer( srnamt, infot, nout, lerr, ok )
2613 CALL ctpsv(
'U',
'N',
'N', 0, a, x, 0 )
2614 CALL chkxer( srnamt, infot, nout, lerr, ok )
2617 CALL cgerc( -1, 0, alpha, x, 1, y, 1, a, 1 )
2618 CALL chkxer( srnamt, infot, nout, lerr, ok )
2620 CALL cgerc( 0, -1, alpha, x, 1, y, 1, a, 1 )
2621 CALL chkxer( srnamt, infot, nout, lerr, ok )
2623 CALL cgerc( 0, 0, alpha, x, 0, y, 1, a, 1 )
2624 CALL chkxer( srnamt, infot, nout, lerr, ok )
2626 CALL cgerc( 0, 0, alpha, x, 1, y, 0, a, 1 )
2627 CALL chkxer( srnamt, infot, nout, lerr, ok )
2629 CALL cgerc( 2, 0, alpha, x, 1, y, 1, a, 1 )
2630 CALL chkxer( srnamt, infot, nout, lerr, ok )
2633 CALL cgeru( -1, 0, alpha, x, 1, y, 1, a, 1 )
2634 CALL chkxer( srnamt, infot, nout, lerr, ok )
2636 CALL cgeru( 0, -1, alpha, x, 1, y, 1, a, 1 )
2637 CALL chkxer( srnamt, infot, nout, lerr, ok )
2639 CALL cgeru( 0, 0, alpha, x, 0, y, 1, a, 1 )
2640 CALL chkxer( srnamt, infot, nout, lerr, ok )
2642 CALL cgeru( 0, 0, alpha, x, 1, y, 0, a, 1 )
2643 CALL chkxer( srnamt, infot, nout, lerr, ok )
2645 CALL cgeru( 2, 0, alpha, x, 1, y, 1, a, 1 )
2646 CALL chkxer( srnamt, infot, nout, lerr, ok )
2649 CALL cher(
'/', 0, ralpha, x, 1, a, 1 )
2650 CALL chkxer( srnamt, infot, nout, lerr, ok )
2652 CALL cher(
'U', -1, ralpha, x, 1, a, 1 )
2653 CALL chkxer( srnamt, infot, nout, lerr, ok )
2655 CALL cher(
'U', 0, ralpha, x, 0, a, 1 )
2656 CALL chkxer( srnamt, infot, nout, lerr, ok )
2658 CALL cher(
'U', 2, ralpha, x, 1, a, 1 )
2659 CALL chkxer( srnamt, infot, nout, lerr, ok )
2662 CALL chpr(
'/', 0, ralpha, x, 1, a )
2663 CALL chkxer( srnamt, infot, nout, lerr, ok )
2665 CALL chpr(
'U', -1, ralpha, x, 1, a )
2666 CALL chkxer( srnamt, infot, nout, lerr, ok )
2668 CALL chpr(
'U', 0, ralpha, x, 0, a )
2669 CALL chkxer( srnamt, infot, nout, lerr, ok )
2672 CALL cher2(
'/', 0, alpha, x, 1, y, 1, a, 1 )
2673 CALL chkxer( srnamt, infot, nout, lerr, ok )
2675 CALL cher2(
'U', -1, alpha, x, 1, y, 1, a, 1 )
2676 CALL chkxer( srnamt, infot, nout, lerr, ok )
2678 CALL cher2(
'U', 0, alpha, x, 0, y, 1, a, 1 )
2679 CALL chkxer( srnamt, infot, nout, lerr, ok )
2681 CALL cher2(
'U', 0, alpha, x, 1, y, 0, a, 1 )
2682 CALL chkxer( srnamt, infot, nout, lerr, ok )
2684 CALL cher2(
'U', 2, alpha, x, 1, y, 1, a, 1 )
2685 CALL chkxer( srnamt, infot, nout, lerr, ok )
2688 CALL chpr2(
'/', 0, alpha, x, 1, y, 1, a )
2689 CALL chkxer( srnamt, infot, nout, lerr, ok )
2691 CALL chpr2(
'U', -1, alpha, x, 1, y, 1, a )
2692 CALL chkxer( srnamt, infot, nout, lerr, ok )
2694 CALL chpr2(
'U', 0, alpha, x, 0, y, 1, a )
2695 CALL chkxer( srnamt, infot, nout, lerr, ok )
2697 CALL chpr2(
'U', 0, alpha, x, 1, y, 0, a )
2698 CALL chkxer( srnamt, infot, nout, lerr, ok )
2701 WRITE( nout, fmt = 9999 )srnamt
2703 WRITE( nout, fmt = 9998 )srnamt
2707 9999
FORMAT(
' ', a6,
' PASSED THE TESTS OF ERROR-EXITS' )
2708 9998
FORMAT(
' ******* ', a6,
' FAILED THE TESTS OF ERROR-EXITS *****',
2714 SUBROUTINE cmake( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
2715 $ KU, RESET, TRANSL )
2732 parameter( zero = ( 0.0, 0.0 ), one = ( 1.0, 0.0 ) )
2734 PARAMETER ( ROGUE = ( -1.0e10, 1.0e10 ) )
2736 PARAMETER ( RZERO = 0.0 )
2738 parameter( rrogue = -1.0e10 )
2741 INTEGER KL, KU, LDA, M, N, NMAX
2743 CHARACTER*1 DIAG, UPLO
2746 COMPLEX A( NMAX, * ), AA( * )
2748 INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK
2749 LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
2754 INTRINSIC cmplx, conjg, max, min, real
2756 gen =
TYPE( 1: 1 ).EQ.
'G'
2757 SYM = type( 1: 1 ).EQ.
'H'
2758 tri =
TYPE( 1: 1 ).EQ.
'T'
2759 upper = ( sym.OR.tri ).AND.uplo.EQ.
'U'
2760 lower = ( sym.OR.tri ).AND.uplo.EQ.
'L'
2761 unit = tri.AND.diag.EQ.
'U'
2767 IF( gen.OR.( upper.AND.i.LE.j ).OR.( lower.AND.i.GE.j ) )
2769 IF( ( i.LE.j.AND.j - i.LE.ku ).OR.
2770 $ ( i.GE.j.AND.i - j.LE.kl ) )
THEN
2771 a( i, j ) = cbeg( reset ) + transl
2777 a( j, i ) = conjg( a( i, j ) )
2785 $ a( j, j ) = cmplx( real( a( j, j ) ), rzero )
2787 $ a( j, j ) = a( j, j ) + one
2794 IF( type.EQ.
'GE' )
THEN
2797 aa( i + ( j - 1 )*lda ) = a( i, j )
2799 DO 40 i = m + 1, lda
2800 aa( i + ( j - 1 )*lda ) = rogue
2803 ELSE IF( type.EQ.
'GB' )
THEN
2805 DO 60 i1 = 1, ku + 1 - j
2806 aa( i1 + ( j - 1 )*lda ) = rogue
2808 DO 70 i2 = i1, min( kl + ku + 1, ku + 1 + m - j )
2809 aa( i2 + ( j - 1 )*lda ) = a( i2 + j - ku - 1, j )
2812 aa( i3 + ( j - 1 )*lda ) = rogue
2815 ELSE IF( type.EQ.
'HE'.OR.type.EQ.
'TR' )
THEN
2832 DO 100 i = 1, ibeg - 1
2833 aa( i + ( j - 1 )*lda ) = rogue
2835 DO 110 i = ibeg, iend
2836 aa( i + ( j - 1 )*lda ) = a( i, j )
2838 DO 120 i = iend + 1, lda
2839 aa( i + ( j - 1 )*lda ) = rogue
2842 jj = j + ( j - 1 )*lda
2843 aa( jj ) = cmplx( real( aa( jj ) ), rrogue )
2846 ELSE IF( type.EQ.
'HB'.OR.type.EQ.
'TB' )
THEN
2850 ibeg = max( 1, kl + 2 - j )
2863 iend = min( kl + 1, 1 + m - j )
2865 DO 140 i = 1, ibeg - 1
2866 aa( i + ( j - 1 )*lda ) = rogue
2868 DO 150 i = ibeg, iend
2869 aa( i + ( j - 1 )*lda ) = a( i + j - kk, j )
2871 DO 160 i = iend + 1, lda
2872 aa( i + ( j - 1 )*lda ) = rogue
2875 jj = kk + ( j - 1 )*lda
2876 aa( jj ) = cmplx( real( aa( jj ) ), rrogue )
2879 ELSE IF( type.EQ.
'HP'.OR.type.EQ.
'TP' )
THEN
2889 DO 180 i = ibeg, iend
2891 aa( ioff ) = a( i, j )
2894 $ aa( ioff ) = rogue
2896 $ aa( ioff ) = cmplx( real( aa( ioff ) ), rrogue )
2906 SUBROUTINE cmvch( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
2907 $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV )
2919 parameter( zero = ( 0.0, 0.0 ) )
2921 PARAMETER ( RZERO = 0.0, rone = 1.0 )
2925 INTEGER INCX, INCY, M, N, NMAX, NOUT
2929 COMPLEX A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * )
2934 INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
2937 INTRINSIC abs, aimag, conjg, max, real, sqrt
2941 abs1( c ) = abs( real( c ) ) + abs( aimag( c ) )
2944 ctran = trans.EQ.
'C'
2945 IF( tran.OR.ctran )
THEN
2977 yt( iy ) = yt( iy ) + a( j, i )*x( jx )
2978 g( iy ) = g( iy ) + abs1( a( j, i ) )*abs1( x( jx ) )
2981 ELSE IF( ctran )
THEN
2983 yt( iy ) = yt( iy ) + conjg( a( j, i ) )*x( jx )
2984 g( iy ) = g( iy ) + abs1( a( j, i ) )*abs1( x( jx ) )
2989 yt( iy ) = yt( iy ) + a( i, j )*x( jx )
2990 g( iy ) = g( iy ) + abs1( a( i, j ) )*abs1( x( jx ) )
2994 yt( iy ) = alpha*yt( iy ) + beta*y( iy )
2995 g( iy ) = abs1( alpha )*g( iy ) + abs1( beta )*abs1( y( iy ) )
3003 erri = abs( yt( i ) - yy( 1 + ( i - 1 )*abs( incy ) ) )/eps
3004 IF( g( i ).NE.rzero )
3005 $ erri = erri/g( i )
3006 err = max( err, erri )
3007 IF( err*sqrt( eps ).GE.rone )
3016 WRITE( nout, fmt = 9999 )
3019 WRITE( nout, fmt = 9998 )i, yt( i ),
3020 $ yy( 1 + ( i - 1 )*abs( incy ) )
3022 WRITE( nout, fmt = 9998 )i,
3023 $ yy( 1 + ( i - 1 )*abs( incy ) ), yt( i )
3030 9999
FORMAT(
' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
3031 $
'F ACCURATE *******', /
' EXPECTED RE',
3032 $
'SULT COMPUTED RESULT' )
3033 9998
FORMAT( 1x, i7, 2(
' (', g15.6,
',', g15.6,
')' ) )
3038 LOGICAL FUNCTION lce( RI, RJ, LR )
3051 COMPLEX ri( * ), rj( * )
3056 IF( ri( i ).NE.rj( i ) )
3068 LOGICAL FUNCTION lceres( TYPE, UPLO, M, N, AA, AS, LDA )
3085 COMPLEX aa( lda, * ), as( lda, * )
3087 INTEGER i, ibeg, iend, j
3091 IF( type.EQ.
'GE' )
THEN
3093 DO 10 i = m + 1, lda
3094 IF( aa( i, j ).NE.as( i, j ) )
3098 ELSE IF( type.EQ.
'HE' )
THEN
3107 DO 30 i = 1, ibeg - 1
3108 IF( aa( i, j ).NE.as( i, j ) )
3111 DO 40 i = iend + 1, lda
3112 IF( aa( i, j ).NE.as( i, j ) )
3141 INTEGER i, ic, j, mi, mj
3143 SAVE i, ic, j, mi, mj
3167 i = i - 1000*( i/1000 )
3168 j = j - 1000*( j/1000 )
3173 cbeg = cmplx( ( i - 500 )/1001.0, ( j - 500 )/1001.0 )
3195 SUBROUTINE chkxer( SRNAMT, INFOT, NOUT, LERR, OK )
3211 WRITE( nout, fmt = 9999 )infot, srnamt
3217 9999
FORMAT(
' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', i2,
' NOT D',
3218 $
'ETECTED BY ', a6,
' *****' )
3248 COMMON /INFOC/INFOT, NOUT, OK, LERR
3249 COMMON /SRNAMC/SRNAMT
3252 IF( info.NE.infot )
THEN
3253 IF( infot.NE.0 )
THEN
3254 WRITE( nout, fmt = 9999 )info, infot
3256 WRITE( nout, fmt = 9997 )info
3260 IF( srname.NE.srnamt )
THEN
3261 WRITE( nout, fmt = 9998 )srname, srnamt
3266 9999
FORMAT(
' ******* XERBLA WAS CALLED WITH INFO = ', i6,
' INSTEAD',
3267 $
' OF ', i2,
' *******' )
3268 9998
FORMAT(
' ******* XERBLA WAS CALLED WITH SRNAME = ', a6,
' INSTE',
3269 $
'AD OF ', a6,
' *******' )
3270 9997
FORMAT(
' ******* XERBLA WAS CALLED WITH INFO = ', i6,
real function sdiff(SA, SB)
subroutine cmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
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 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 cchke(ISNUM, SRNAMT, NOUT)
logical function lce(RI, RJ, LR)
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)
complex function cbeg(RESET)
logical function lceres(TYPE, UPLO, M, N, AA, AS, LDA)
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 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)
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 cmvch(TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV)
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
subroutine ctpsv(UPLO, TRANS, DIAG, N, AP, X, INCX)
CTPSV
subroutine ctbmv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
CTBMV
subroutine cgerc(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERC
subroutine ctrsv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
CTRSV
subroutine chbmv(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CHBMV
subroutine ctbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
CTBSV
subroutine cgbmv(TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGBMV
subroutine chpr2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP)
CHPR2
subroutine ctrmv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
CTRMV
subroutine cher2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CHER2
subroutine cgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERU
subroutine chemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CHEMV
subroutine chpr(UPLO, N, ALPHA, X, INCX, AP)
CHPR
subroutine chpmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
CHPMV
subroutine cher(UPLO, N, ALPHA, X, INCX, A, LDA)
CHER
subroutine ctpmv(UPLO, TRANS, DIAG, N, AP, X, INCX)
CTPMV