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( 1
x, 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( 1
x, i6,
': ', a6,
'(''', a1,
''',', 4( i3,
',' ),
'(',
771 $ f4.1,
',', f4.1,
'), A,', i3,
', X,', i2,
',(', f4.1,
',',
772 $ f4.1,
'), Y,', i2,
') .' )
773 9994
FORMAT( 1
x, 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( 1
x, i6,
': ', a6,
'(''', a1,
''',', i3,
',(', f4.1,
',',
1116 $ f4.1,
'), AP, X,', i2,
',(', f4.1,
',', f4.1,
'), Y,', i2,
1118 9994
FORMAT( 1
x, i6,
': ', a6,
'(''', a1,
''',', 2( i3,
',' ),
'(',
1119 $ f4.1,
',', f4.1,
'), A,', i3,
', X,', i2,
',(', f4.1,
',',
1120 $ f4.1,
'), Y,', i2,
') .' )
1121 9993
FORMAT( 1
x, 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
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( 1
x, i6,
': ', a6,
'(', 3(
'''', a1,
''',' ), i3,
', AP, ',
1481 9994
FORMAT( 1
x, i6,
': ', a6,
'(', 3(
'''', a1,
''',' ), 2( i3,
',' ),
1482 $
' A,', i3,
', X,', i2,
') .' )
1483 9993
FORMAT( 1
x, 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
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( 1
x, 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
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( 1
x, i6,
': ', a6,
'(''', a1,
''',', i3,
',', f4.1,
', X,',
2044 9993
FORMAT( 1
x, 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
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( 1
x, i6,
': ', a6,
'(''', a1,
''',', i3,
',(', f4.1,
',',
2363 $ f4.1,
'), X,', i2,
', Y,', i2,
', AP) ',
2365 9993
FORMAT( 1
x, 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 *',
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( 1
x, 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 ) )
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 )
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,
' *****' )
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 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 cgbmv(TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGBMV
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 cchke(ISNUM, SRNAMT, NOUT)
subroutine chpr(UPLO, N, ALPHA, X, INCX, AP)
CHPR
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine chpr2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP)
CHPR2
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
subroutine cher(UPLO, N, ALPHA, X, INCX, A, LDA)
CHER
LOGICAL function lceres(TYPE, UPLO, M, N, AA, AS, LDA)
COMPLEX function cbeg(RESET)
REAL function sdiff(SA, SB)
subroutine ctbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
CTBSV
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
subroutine chemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CHEMV
error code as a return value instead of the INFO parameter This implementation supports both the ILP64 and LP64 programming and different complex type C99 This implementation includes interfaces for the LAPACK Driver and Computational routines only Product Directories The installation directory of this package has the following compiler names for binaries to be created linked to You may choose the appropriate LP64 ILP64 convenient complex type LAPACKE name and or redefine system malloc free in make inc Several examples of make inc are provided After setting up the make inc
subroutine chbmv(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CHBMV
subroutine ctpsv(UPLO, TRANS, DIAG, N, AP, X, INCX)
CTPSV
subroutine chpmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
CHPMV
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)
LOGICAL function lce(RI, RJ, LR)
subroutine cmvch(TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV)
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine cher2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CHER2
subroutine ctbmv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
CTBMV
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 ctrmv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
CTRMV
subroutine cmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
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 cgerc(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERC
subroutine cgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERU
subroutine ctrsv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
CTRSV
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)