117 parameter( nsubs = 17 )
119 parameter( zero = ( 0.0d0, 0.0d0 ),
120 $ one = ( 1.0d0, 0.0d0 ) )
121 DOUBLE PRECISION rzero
122 parameter( rzero = 0.0d0 )
124 parameter( nmax = 65, incmax = 2 )
125 INTEGER ninmax, nidmax, nkbmax, nalmax, nbemax
126 parameter( ninmax = 7, nidmax = 9, nkbmax = 7,
127 $ nalmax = 7, nbemax = 7 )
129 DOUBLE PRECISION eps, err, thresh
130 INTEGER i, isnum,
j, n, nalf, nbet, nidim, ninc, nkb,
132 LOGICAL fatal, ltestt, rewi, same, sfatal, trace,
136 CHARACTER*32 snaps, summry
138 COMPLEX*16 a( nmax, nmax ), aa( nmax*nmax ),
139 $ alf( nalmax ), as( nmax*nmax ), bet( nbemax ),
140 $
x( nmax ), xs( nmax*incmax ),
141 $ xx( nmax*incmax ), y( nmax ),
142 $ ys( nmax*incmax ), yt( nmax ),
143 $ yy( nmax*incmax ), z( 2*nmax )
144 DOUBLE PRECISION g( nmax )
145 INTEGER idim( nidmax ),
inc( ninmax ), kb( nkbmax )
146 LOGICAL ltest( nsubs )
147 CHARACTER*6 snames( nsubs )
149 DOUBLE PRECISION ddiff
156 INTRINSIC abs, max, min
162 COMMON /infoc/infot, noutc, ok, lerr
163 COMMON /srnamc/srnamt
165 DATA snames/
'ZGEMV ',
'ZGBMV ',
'ZHEMV ',
'ZHBMV ',
166 $
'ZHPMV ',
'ZTRMV ',
'ZTBMV ',
'ZTPMV ',
167 $
'ZTRSV ',
'ZTBSV ',
'ZTPSV ',
'ZGERC ',
168 $
'ZGERU ',
'ZHER ',
'ZHPR ',
'ZHER2 ',
174 READ( nin, fmt = * )summry
175 READ( nin, fmt = * )nout
176 OPEN( nout, file = summry, status =
'UNKNOWN' )
181 READ( nin, fmt = * )snaps
182 READ( nin, fmt = * )ntra
185 OPEN( ntra, file = snaps, status =
'UNKNOWN' )
188 READ( nin, fmt = * )rewi
189 rewi = rewi.AND.trace
191 READ( nin, fmt = * )sfatal
193 READ( nin, fmt = * )tsterr
195 READ( nin, fmt = * )thresh
200 READ( nin, fmt = * )nidim
201 IF( nidim.LT.1.OR.nidim.GT.nidmax )
THEN
202 WRITE( nout, fmt = 9997 )
'N', nidmax
205 READ( nin, fmt = * )( idim( i ), i = 1, nidim )
207 IF( idim( i ).LT.0.OR.idim( i ).GT.nmax )
THEN
208 WRITE( nout, fmt = 9996 )nmax
213 READ( nin, fmt = * )nkb
214 IF( nkb.LT.1.OR.nkb.GT.nkbmax )
THEN
215 WRITE( nout, fmt = 9997 )
'K', nkbmax
218 READ( nin, fmt = * )( kb( i ), i = 1, nkb )
220 IF( kb( i ).LT.0 )
THEN
221 WRITE( nout, fmt = 9995 )
226 READ( nin, fmt = * )ninc
227 IF( ninc.LT.1.OR.ninc.GT.ninmax )
THEN
228 WRITE( nout, fmt = 9997 )
'INCX AND INCY', ninmax
231 READ( nin, fmt = * )(
inc( i ), i = 1, ninc )
233 IF(
inc( i ).EQ.0.OR.abs(
inc( i ) ).GT.incmax )
THEN
234 WRITE( nout, fmt = 9994 )incmax
239 READ( nin, fmt = * )nalf
240 IF( nalf.LT.1.OR.nalf.GT.nalmax )
THEN
241 WRITE( nout, fmt = 9997 )
'ALPHA', nalmax
244 READ( nin, fmt = * )( alf( i ), i = 1, nalf )
246 READ( nin, fmt = * )nbet
247 IF( nbet.LT.1.OR.nbet.GT.nbemax )
THEN
248 WRITE( nout, fmt = 9997 )
'BETA', nbemax
251 READ( nin, fmt = * )( bet( i ), i = 1, nbet )
255 WRITE( nout, fmt = 9993 )
256 WRITE( nout, fmt = 9992 )( idim( i ), i = 1, nidim )
257 WRITE( nout, fmt = 9991 )( kb( i ), i = 1, nkb )
258 WRITE( nout, fmt = 9990 )(
inc( i ), i = 1, ninc )
259 WRITE( nout, fmt = 9989 )( alf( i ), i = 1, nalf )
260 WRITE( nout, fmt = 9988 )( bet( i ), i = 1, nbet )
261 IF( .NOT.tsterr )
THEN
262 WRITE( nout, fmt = * )
263 WRITE( nout, fmt = 9980 )
265 WRITE( nout, fmt = * )
266 WRITE( nout, fmt = 9999 )thresh
267 WRITE( nout, fmt = * )
275 50
READ( nin, fmt = 9984,
END = 80 )snamet, ltestt
277 IF( snamet.EQ.snames( i ) )
280 WRITE( nout, fmt = 9986 )snamet
282 70 ltest( i ) = ltestt
291 WRITE( nout, fmt = 9998 )eps
298 a( i,
j ) = max( i -
j + 1, 0 )
304 yy(
j ) =
j*( (
j + 1 )*
j )/2 - ( (
j + 1 )*
j*(
j - 1 ) )/3
309 CALL
zmvch( trans, n, n, one, a, nmax,
x, 1, zero, y, 1, yt, g,
310 $ yy, eps, err, fatal, nout, .true. )
311 same =
lze( yy, yt, n )
312 IF( .NOT.same.OR.err.NE.rzero )
THEN
313 WRITE( nout, fmt = 9985 )trans, same, err
317 CALL
zmvch( trans, n, n, one, a, nmax,
x, -1, zero, y, -1, yt, g,
318 $ yy, eps, err, fatal, nout, .true. )
319 same =
lze( yy, yt, n )
320 IF( .NOT.same.OR.err.NE.rzero )
THEN
321 WRITE( nout, fmt = 9985 )trans, same, err
327 DO 210 isnum = 1, nsubs
328 WRITE( nout, fmt = * )
329 IF( .NOT.ltest( isnum ) )
THEN
331 WRITE( nout, fmt = 9983 )snames( isnum )
333 srnamt = snames( isnum )
336 CALL
zchke( isnum, snames( isnum ), nout )
337 WRITE( nout, fmt = * )
343 go to( 140, 140, 150, 150, 150, 160, 160,
344 $ 160, 160, 160, 160, 170, 170, 180,
345 $ 180, 190, 190 )isnum
347 140 CALL
zchk1( snames( isnum ), eps, thresh, nout, ntra, trace,
348 $ rewi, fatal, nidim, idim, nkb, kb, nalf, alf,
349 $ nbet, bet, ninc,
inc, nmax, incmax, a, aa, as,
350 $
x, xx, xs, y, yy, ys, yt, g )
353 150 CALL
zchk2( snames( isnum ), eps, thresh, nout, ntra, trace,
354 $ rewi, fatal, nidim, idim, nkb, kb, nalf, alf,
355 $ nbet, bet, ninc,
inc, nmax, incmax, a, aa, as,
356 $
x, xx, xs, y, yy, ys, yt, g )
360 160 CALL
zchk3( snames( isnum ), eps, thresh, nout, ntra, trace,
361 $ rewi, fatal, nidim, idim, nkb, kb, ninc,
inc,
362 $ nmax, incmax, a, aa, as, y, yy, ys, yt, g, z )
365 170 CALL
zchk4( snames( isnum ), eps, thresh, nout, ntra, trace,
366 $ rewi, fatal, nidim, idim, nalf, alf, ninc,
inc,
367 $ nmax, incmax, a, aa, as,
x, xx, xs, y, yy, ys,
371 180 CALL
zchk5( snames( isnum ), eps, thresh, nout, ntra, trace,
372 $ rewi, fatal, nidim, idim, nalf, alf, ninc,
inc,
373 $ nmax, incmax, a, aa, as,
x, xx, xs, y, yy, ys,
377 190 CALL
zchk6( snames( isnum ), eps, thresh, nout, ntra, trace,
378 $ rewi, fatal, nidim, idim, nalf, alf, ninc,
inc,
379 $ nmax, incmax, a, aa, as,
x, xx, xs, y, yy, ys,
382 200
IF( fatal.AND.sfatal )
386 WRITE( nout, fmt = 9982 )
390 WRITE( nout, fmt = 9981 )
394 WRITE( nout, fmt = 9987 )
402 9999
FORMAT(
' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
404 9998
FORMAT(
' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1p, d9.1 )
405 9997
FORMAT(
' NUMBER OF VALUES OF ', a,
' IS LESS THAN 1 OR GREATER ',
407 9996
FORMAT(
' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', i2 )
408 9995
FORMAT(
' VALUE OF K IS LESS THAN 0' )
409 9994
FORMAT(
' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',
411 9993
FORMAT(
' TESTS OF THE COMPLEX*16 LEVEL 2 BLAS', //
' THE F',
412 $
'OLLOWING PARAMETER VALUES WILL BE USED:' )
413 9992
FORMAT(
' FOR N ', 9i6 )
414 9991
FORMAT(
' FOR K ', 7i6 )
415 9990
FORMAT(
' FOR INCX AND INCY ', 7i6 )
416 9989
FORMAT(
' FOR ALPHA ',
417 $ 7(
'(', f4.1,
',', f4.1,
') ', : ) )
418 9988
FORMAT(
' FOR BETA ',
419 $ 7(
'(', f4.1,
',', f4.1,
') ', : ) )
420 9987
FORMAT(
' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
421 $ /
' ******* TESTS ABANDONED *******' )
422 9986
FORMAT(
' SUBPROGRAM NAME ', a6,
' NOT RECOGNIZED', /
' ******* T',
423 $
'ESTS ABANDONED *******' )
424 9985
FORMAT(
' ERROR IN ZMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
425 $
'ATED WRONGLY.', /
' ZMVCH WAS CALLED WITH TRANS = ', a1,
426 $
' AND RETURNED SAME = ', l1,
' AND ERR = ', f12.3,
'.', /
427 $
' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.'
428 $ , /
' ******* TESTS ABANDONED *******' )
429 9984
FORMAT( a6, l2 )
430 9983
FORMAT( 1
x, a6,
' WAS NOT TESTED' )
431 9982
FORMAT( /
' END OF TESTS' )
432 9981
FORMAT( /
' ******* FATAL ERROR - TESTS ABANDONED *******' )
433 9980
FORMAT(
' ERROR-EXITS WILL NOT BE TESTED' )
438 SUBROUTINE zchk1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
439 $ fatal, nidim, idim, nkb, kb, nalf, alf, nbet,
440 $ bet, ninc,
inc, nmax, incmax, a, aa, as,
x, xx,
441 $ xs, y, yy, ys, yt, g )
452 COMPLEX*16 zero, half
453 parameter( zero = ( 0.0d0, 0.0d0 ),
454 $ half = ( 0.5d0, 0.0d0 ) )
455 DOUBLE PRECISION rzero
456 parameter( rzero = 0.0d0 )
458 DOUBLE PRECISION eps, thresh
459 INTEGER incmax, nalf, nbet, nidim, ninc, nkb, nmax,
461 LOGICAL fatal, rewi, trace
464 COMPLEX*16 a( nmax, nmax ), aa( nmax*nmax ), alf( nalf ),
465 $ as( nmax*nmax ), bet( nbet ),
x( nmax ),
466 $ xs( nmax*incmax ), xx( nmax*incmax ),
467 $ y( nmax ), ys( nmax*incmax ), yt( nmax ),
469 DOUBLE PRECISION g( nmax )
470 INTEGER idim( nidim ),
inc( ninc ), kb( nkb )
472 COMPLEX*16 alpha, als, beta, bls, transl
473 DOUBLE PRECISION err, errmax
474 INTEGER i, ia, ib, ic, iku, im, in, incx, incxs, incy,
475 $ incys, ix, iy, kl, kls, ku, kus, laa, lda,
476 $ ldas, lx, ly, m, ml, ms, n, nargs, nc, nd, nk,
478 LOGICAL banded, full, null, reset, same, tran
479 CHARACTER*1 trans, transs
489 INTRINSIC abs, max, min
494 COMMON /infoc/infot, noutc, ok, lerr
498 full = sname( 3: 3 ).EQ.
'E'
499 banded = sname( 3: 3 ).EQ.
'B'
503 ELSE IF( banded )
THEN
517 $ m = max( n - nd, 0 )
519 $ m = min( n + nd, nmax )
529 kl = max( ku - 1, 0 )
546 null = n.LE.0.OR.m.LE.0
551 CALL
zmake( sname( 2: 3 ),
' ',
' ', m, n, a, nmax, aa,
552 $ lda, kl, ku, reset, transl )
555 trans = ich( ic: ic )
556 tran = trans.EQ.
'T'.OR.trans.EQ.
'C'
573 CALL
zmake(
'GE',
' ',
' ', 1, nl,
x, 1, xx,
574 $ abs( incx ), 0, nl - 1, reset, transl )
577 xx( 1 + abs( incx )*( nl/2 - 1 ) ) = zero
593 CALL
zmake(
'GE',
' ',
' ', 1, ml, y, 1,
594 $ yy, abs( incy ), 0, ml - 1,
626 $
WRITE( ntra, fmt = 9994 )nc, sname,
627 $ trans, m, n, alpha, lda, incx, beta,
631 CALL
zgemv( trans, m, n, alpha, aa,
632 $ lda, xx, incx, beta, yy,
634 ELSE IF( banded )
THEN
636 $
WRITE( ntra, fmt = 9995 )nc, sname,
637 $ trans, m, n, kl, ku, alpha, lda,
641 CALL
zgbmv( trans, m, n, kl, ku, alpha,
642 $ aa, lda, xx, incx, beta,
649 WRITE( nout, fmt = 9993 )
656 isame( 1 ) = trans.EQ.transs
660 isame( 4 ) = als.EQ.alpha
661 isame( 5 ) =
lze( as, aa, laa )
662 isame( 6 ) = ldas.EQ.lda
663 isame( 7 ) =
lze( xs, xx, lx )
664 isame( 8 ) = incxs.EQ.incx
665 isame( 9 ) = bls.EQ.beta
667 isame( 10 ) =
lze( ys, yy, ly )
669 isame( 10 ) =
lzeres(
'GE',
' ', 1,
673 isame( 11 ) = incys.EQ.incy
674 ELSE IF( banded )
THEN
675 isame( 4 ) = kls.EQ.kl
676 isame( 5 ) = kus.EQ.ku
677 isame( 6 ) = als.EQ.alpha
678 isame( 7 ) =
lze( as, aa, laa )
679 isame( 8 ) = ldas.EQ.lda
680 isame( 9 ) =
lze( xs, xx, lx )
681 isame( 10 ) = incxs.EQ.incx
682 isame( 11 ) = bls.EQ.beta
684 isame( 12 ) =
lze( ys, yy, ly )
686 isame( 12 ) =
lzeres(
'GE',
' ', 1,
690 isame( 13 ) = incys.EQ.incy
698 same = same.AND.isame( i )
699 IF( .NOT.isame( i ) )
700 $
WRITE( nout, fmt = 9998 )i
711 CALL
zmvch( trans, m, n, alpha, a,
712 $ nmax,
x, incx, beta, y,
713 $ incy, yt, g, yy, eps, err,
714 $ fatal, nout, .true. )
715 errmax = max( errmax, err )
744 IF( errmax.LT.thresh )
THEN
745 WRITE( nout, fmt = 9999 )sname, nc
747 WRITE( nout, fmt = 9997 )sname, nc, errmax
752 WRITE( nout, fmt = 9996 )sname
754 WRITE( nout, fmt = 9994 )nc, sname, trans, m, n, alpha, lda,
756 ELSE IF( banded )
THEN
757 WRITE( nout, fmt = 9995 )nc, sname, trans, m, n, kl, ku,
758 $ alpha, lda, incx, beta, incy
764 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
766 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
767 $
'ANGED INCORRECTLY *******' )
768 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
769 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
770 $
' - SUSPECT *******' )
771 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
772 9995
FORMAT( 1
x, i6,
': ', a6,
'(''', a1,
''',', 4( i3,
',' ),
'(',
773 $ f4.1,
',', f4.1,
'), A,', i3,
', X,', i2,
',(', f4.1,
',',
774 $ f4.1,
'), Y,', i2,
') .' )
775 9994
FORMAT( 1
x, i6,
': ', a6,
'(''', a1,
''',', 2( i3,
',' ),
'(',
776 $ f4.1,
',', f4.1,
'), A,', i3,
', X,', i2,
',(', f4.1,
',',
777 $ f4.1,
'), Y,', i2,
') .' )
778 9993
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
784 SUBROUTINE zchk2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
785 $ fatal, nidim, idim, nkb, kb, nalf, alf, nbet,
786 $ bet, ninc,
inc, nmax, incmax, a, aa, as,
x, xx,
787 $ xs, y, yy, ys, yt, g )
798 COMPLEX*16 zero, half
799 parameter( zero = ( 0.0d0, 0.0d0 ),
800 $ half = ( 0.5d0, 0.0d0 ) )
801 DOUBLE PRECISION rzero
802 parameter( rzero = 0.0d0 )
804 DOUBLE PRECISION eps, thresh
805 INTEGER incmax, nalf, nbet, nidim, ninc, nkb, nmax,
807 LOGICAL fatal, rewi, trace
810 COMPLEX*16 a( nmax, nmax ), aa( nmax*nmax ), alf( nalf ),
811 $ as( nmax*nmax ), bet( nbet ),
x( nmax ),
812 $ xs( nmax*incmax ), xx( nmax*incmax ),
813 $ y( nmax ), ys( nmax*incmax ), yt( nmax ),
815 DOUBLE PRECISION g( nmax )
816 INTEGER idim( nidim ),
inc( ninc ), kb( nkb )
818 COMPLEX*16 alpha, als, beta, bls, transl
819 DOUBLE PRECISION err, errmax
820 INTEGER i, ia, ib, ic, ik, in, incx, incxs, incy,
821 $ incys, ix, iy, k, ks, laa, lda, ldas, lx, ly,
822 $ n, nargs, nc, nk, ns
823 LOGICAL banded, full, null, packed, reset, same
824 CHARACTER*1 uplo, uplos
839 COMMON /infoc/infot, noutc, ok, lerr
843 full = sname( 3: 3 ).EQ.
'E'
844 banded = sname( 3: 3 ).EQ.
'B'
845 packed = sname( 3: 3 ).EQ.
'P'
849 ELSE IF( banded )
THEN
851 ELSE IF( packed )
THEN
885 laa = ( n*( n + 1 ) )/2
897 CALL
zmake( sname( 2: 3 ), uplo,
' ', n, n, a, nmax, aa,
898 $ lda, k, k, reset, transl )
907 CALL
zmake(
'GE',
' ',
' ', 1, n,
x, 1, xx,
908 $ abs( incx ), 0, n - 1, reset, transl )
911 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
927 CALL
zmake(
'GE',
' ',
' ', 1, n, y, 1, yy,
928 $ abs( incy ), 0, n - 1, reset,
958 $
WRITE( ntra, fmt = 9993 )nc, sname,
959 $ uplo, n, alpha, lda, incx, beta, incy
962 CALL
zhemv( uplo, n, alpha, aa, lda, xx,
963 $ incx, beta, yy, incy )
964 ELSE IF( banded )
THEN
966 $
WRITE( ntra, fmt = 9994 )nc, sname,
967 $ uplo, n, k, alpha, lda, incx, beta,
971 CALL
zhbmv( uplo, n, k, alpha, aa, lda,
972 $ xx, incx, beta, yy, incy )
973 ELSE IF( packed )
THEN
975 $
WRITE( ntra, fmt = 9995 )nc, sname,
976 $ uplo, n, alpha, incx, beta, incy
979 CALL
zhpmv( uplo, n, alpha, aa, xx, incx,
986 WRITE( nout, fmt = 9992 )
993 isame( 1 ) = uplo.EQ.uplos
996 isame( 3 ) = als.EQ.alpha
997 isame( 4 ) =
lze( as, aa, laa )
998 isame( 5 ) = ldas.EQ.lda
999 isame( 6 ) =
lze( xs, xx, lx )
1000 isame( 7 ) = incxs.EQ.incx
1001 isame( 8 ) = bls.EQ.beta
1003 isame( 9 ) =
lze( ys, yy, ly )
1005 isame( 9 ) =
lzeres(
'GE',
' ', 1, n,
1006 $ ys, yy, abs( incy ) )
1008 isame( 10 ) = incys.EQ.incy
1009 ELSE IF( banded )
THEN
1010 isame( 3 ) = ks.EQ.k
1011 isame( 4 ) = als.EQ.alpha
1012 isame( 5 ) =
lze( as, aa, laa )
1013 isame( 6 ) = ldas.EQ.lda
1014 isame( 7 ) =
lze( xs, xx, lx )
1015 isame( 8 ) = incxs.EQ.incx
1016 isame( 9 ) = bls.EQ.beta
1018 isame( 10 ) =
lze( ys, yy, ly )
1020 isame( 10 ) =
lzeres(
'GE',
' ', 1, n,
1021 $ ys, yy, abs( incy ) )
1023 isame( 11 ) = incys.EQ.incy
1024 ELSE IF( packed )
THEN
1025 isame( 3 ) = als.EQ.alpha
1026 isame( 4 ) =
lze( as, aa, laa )
1027 isame( 5 ) =
lze( xs, xx, lx )
1028 isame( 6 ) = incxs.EQ.incx
1029 isame( 7 ) = bls.EQ.beta
1031 isame( 8 ) =
lze( ys, yy, ly )
1033 isame( 8 ) =
lzeres(
'GE',
' ', 1, n,
1034 $ ys, yy, abs( incy ) )
1036 isame( 9 ) = incys.EQ.incy
1044 same = same.AND.isame( i )
1045 IF( .NOT.isame( i ) )
1046 $
WRITE( nout, fmt = 9998 )i
1057 CALL
zmvch(
'N', n, n, alpha, a, nmax,
x,
1058 $ incx, beta, y, incy, yt, g,
1059 $ yy, eps, err, fatal, nout,
1061 errmax = max( errmax, err )
1087 IF( errmax.LT.thresh )
THEN
1088 WRITE( nout, fmt = 9999 )sname, nc
1090 WRITE( nout, fmt = 9997 )sname, nc, errmax
1095 WRITE( nout, fmt = 9996 )sname
1097 WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, lda, incx,
1099 ELSE IF( banded )
THEN
1100 WRITE( nout, fmt = 9994 )nc, sname, uplo, n, k, alpha, lda,
1102 ELSE IF( packed )
THEN
1103 WRITE( nout, fmt = 9995 )nc, sname, uplo, n, alpha, incx,
1110 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
1112 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
1113 $
'ANGED INCORRECTLY *******' )
1114 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
1115 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1116 $
' - SUSPECT *******' )
1117 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
1118 9995
FORMAT( 1
x, i6,
': ', a6,
'(''', a1,
''',', i3,
',(', f4.1,
',',
1119 $ f4.1,
'), AP, X,', i2,
',(', f4.1,
',', f4.1,
'), Y,', i2,
1121 9994
FORMAT( 1
x, i6,
': ', a6,
'(''', a1,
''',', 2( i3,
',' ),
'(',
1122 $ f4.1,
',', f4.1,
'), A,', i3,
', X,', i2,
',(', f4.1,
',',
1123 $ f4.1,
'), Y,', i2,
') .' )
1124 9993
FORMAT( 1
x, i6,
': ', a6,
'(''', a1,
''',', i3,
',(', f4.1,
',',
1125 $ f4.1,
'), A,', i3,
', X,', i2,
',(', f4.1,
',', f4.1,
'), ',
1127 9992
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1133 SUBROUTINE zchk3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1134 $ fatal, nidim, idim, nkb, kb, ninc,
inc, nmax,
1135 $ incmax, a, aa, as,
x, xx, xs, xt, g, z )
1146 COMPLEX*16 zero, half, one
1147 parameter( zero = ( 0.0d0, 0.0d0 ),
1148 $ half = ( 0.5d0, 0.0d0 ),
1149 $ one = ( 1.0d0, 0.0d0 ) )
1150 DOUBLE PRECISION rzero
1151 parameter( rzero = 0.0d0 )
1153 DOUBLE PRECISION eps, thresh
1154 INTEGER incmax, nidim, ninc, nkb, nmax, nout, ntra
1155 LOGICAL fatal, rewi, trace
1158 COMPLEX*16 a( nmax, nmax ), aa( nmax*nmax ),
1159 $ as( nmax*nmax ),
x( nmax ), xs( nmax*incmax ),
1160 $ xt( nmax ), xx( nmax*incmax ), z( nmax )
1161 DOUBLE PRECISION g( nmax )
1162 INTEGER idim( nidim ),
inc( ninc ), kb( nkb )
1165 DOUBLE PRECISION err, errmax
1166 INTEGER i, icd, ict, icu, ik, in, incx, incxs, ix, k,
1167 $ ks, laa, lda, ldas, lx, n, nargs, nc, nk, ns
1168 LOGICAL banded, full, null, packed, reset, same
1169 CHARACTER*1 diag, diags, trans, transs, uplo, uplos
1170 CHARACTER*2 ichd, ichu
1183 INTEGER infot, noutc
1186 COMMON /infoc/infot, noutc, ok, lerr
1188 DATA ichu/
'UL'/, icht/
'NTC'/, ichd/
'UN'/
1190 full = sname( 3: 3 ).EQ.
'R'
1191 banded = sname( 3: 3 ).EQ.
'B'
1192 packed = sname( 3: 3 ).EQ.
'P'
1196 ELSE IF( banded )
THEN
1198 ELSE IF( packed )
THEN
1210 DO 110 in = 1, nidim
1236 laa = ( n*( n + 1 ) )/2
1243 uplo = ichu( icu: icu )
1246 trans = icht( ict: ict )
1249 diag = ichd( icd: icd )
1254 CALL
zmake( sname( 2: 3 ), uplo, diag, n, n, a,
1255 $ nmax, aa, lda, k, k, reset, transl )
1264 CALL
zmake(
'GE',
' ',
' ', 1, n,
x, 1, xx,
1265 $ abs( incx ), 0, n - 1, reset,
1269 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1292 IF( sname( 4: 5 ).EQ.
'MV' )
THEN
1295 $
WRITE( ntra, fmt = 9993 )nc, sname,
1296 $ uplo, trans, diag, n, lda, incx
1299 CALL
ztrmv( uplo, trans, diag, n, aa, lda,
1301 ELSE IF( banded )
THEN
1303 $
WRITE( ntra, fmt = 9994 )nc, sname,
1304 $ uplo, trans, diag, n, k, lda, incx
1307 CALL
ztbmv( uplo, trans, diag, n, k, aa,
1309 ELSE IF( packed )
THEN
1311 $
WRITE( ntra, fmt = 9995 )nc, sname,
1312 $ uplo, trans, diag, n, incx
1315 CALL
ztpmv( uplo, trans, diag, n, aa, xx,
1318 ELSE IF( sname( 4: 5 ).EQ.
'SV' )
THEN
1321 $
WRITE( ntra, fmt = 9993 )nc, sname,
1322 $ uplo, trans, diag, n, lda, incx
1325 CALL
ztrsv( uplo, trans, diag, n, aa, lda,
1327 ELSE IF( banded )
THEN
1329 $
WRITE( ntra, fmt = 9994 )nc, sname,
1330 $ uplo, trans, diag, n, k, lda, incx
1333 CALL
ztbsv( uplo, trans, diag, n, k, aa,
1335 ELSE IF( packed )
THEN
1337 $
WRITE( ntra, fmt = 9995 )nc, sname,
1338 $ uplo, trans, diag, n, incx
1341 CALL
ztpsv( uplo, trans, diag, n, aa, xx,
1349 WRITE( nout, fmt = 9992 )
1356 isame( 1 ) = uplo.EQ.uplos
1357 isame( 2 ) = trans.EQ.transs
1358 isame( 3 ) = diag.EQ.diags
1359 isame( 4 ) = ns.EQ.n
1361 isame( 5 ) =
lze( as, aa, laa )
1362 isame( 6 ) = ldas.EQ.lda
1364 isame( 7 ) =
lze( xs, xx, lx )
1366 isame( 7 ) =
lzeres(
'GE',
' ', 1, n, xs,
1369 isame( 8 ) = incxs.EQ.incx
1370 ELSE IF( banded )
THEN
1371 isame( 5 ) = ks.EQ.k
1372 isame( 6 ) =
lze( as, aa, laa )
1373 isame( 7 ) = ldas.EQ.lda
1375 isame( 8 ) =
lze( xs, xx, lx )
1377 isame( 8 ) =
lzeres(
'GE',
' ', 1, n, xs,
1380 isame( 9 ) = incxs.EQ.incx
1381 ELSE IF( packed )
THEN
1382 isame( 5 ) =
lze( as, aa, laa )
1384 isame( 6 ) =
lze( xs, xx, lx )
1386 isame( 6 ) =
lzeres(
'GE',
' ', 1, n, xs,
1389 isame( 7 ) = incxs.EQ.incx
1397 same = same.AND.isame( i )
1398 IF( .NOT.isame( i ) )
1399 $
WRITE( nout, fmt = 9998 )i
1407 IF( sname( 4: 5 ).EQ.
'MV' )
THEN
1411 CALL
zmvch( trans, n, n, one, a, nmax,
x,
1412 $ incx, zero, z, incx, xt, g,
1413 $ xx, eps, err, fatal, nout,
1415 ELSE IF( sname( 4: 5 ).EQ.
'SV' )
THEN
1420 z( i ) = xx( 1 + ( i - 1 )*
1422 xx( 1 + ( i - 1 )*abs( incx ) )
1425 CALL
zmvch( trans, n, n, one, a, nmax, z,
1426 $ incx, zero,
x, incx, xt, g,
1427 $ xx, eps, err, fatal, nout,
1430 errmax = max( errmax, err )
1453 IF( errmax.LT.thresh )
THEN
1454 WRITE( nout, fmt = 9999 )sname, nc
1456 WRITE( nout, fmt = 9997 )sname, nc, errmax
1461 WRITE( nout, fmt = 9996 )sname
1463 WRITE( nout, fmt = 9993 )nc, sname, uplo, trans, diag, n, lda,
1465 ELSE IF( banded )
THEN
1466 WRITE( nout, fmt = 9994 )nc, sname, uplo, trans, diag, n, k,
1468 ELSE IF( packed )
THEN
1469 WRITE( nout, fmt = 9995 )nc, sname, uplo, trans, diag, n, incx
1475 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
1477 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
1478 $
'ANGED INCORRECTLY *******' )
1479 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
1480 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1481 $
' - SUSPECT *******' )
1482 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
1483 9995
FORMAT( 1
x, i6,
': ', a6,
'(', 3(
'''', a1,
''',' ), i3,
', AP, ',
1485 9994
FORMAT( 1
x, i6,
': ', a6,
'(', 3(
'''', a1,
''',' ), 2( i3,
',' ),
1486 $
' A,', i3,
', X,', i2,
') .' )
1487 9993
FORMAT( 1
x, i6,
': ', a6,
'(', 3(
'''', a1,
''',' ), i3,
', A,',
1488 $ i3,
', X,', i2,
') .' )
1489 9992
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1495 SUBROUTINE zchk4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1496 $ fatal, nidim, idim, nalf, alf, ninc,
inc, nmax,
1497 $ incmax, a, aa, as,
x, xx, xs, y, yy, ys, yt, g,
1509 COMPLEX*16 zero, half, one
1510 parameter( zero = ( 0.0d0, 0.0d0 ),
1511 $ half = ( 0.5d0, 0.0d0 ),
1512 $ one = ( 1.0d0, 0.0d0 ) )
1513 DOUBLE PRECISION rzero
1514 parameter( rzero = 0.0d0 )
1516 DOUBLE PRECISION eps, thresh
1517 INTEGER incmax, nalf, nidim, ninc, nmax, nout, ntra
1518 LOGICAL fatal, rewi, trace
1521 COMPLEX*16 a( nmax, nmax ), aa( nmax*nmax ), alf( nalf ),
1522 $ as( nmax*nmax ),
x( nmax ), xs( nmax*incmax ),
1523 $ xx( nmax*incmax ), y( nmax ),
1524 $ ys( nmax*incmax ), yt( nmax ),
1525 $ yy( nmax*incmax ), z( nmax )
1526 DOUBLE PRECISION g( nmax )
1527 INTEGER idim( nidim ),
inc( ninc )
1529 COMPLEX*16 alpha, als, transl
1530 DOUBLE PRECISION err, errmax
1531 INTEGER i, ia, im, in, incx, incxs, incy, incys, ix,
1532 $ iy,
j, laa, lda, ldas, lx, ly, m, ms, n, nargs,
1534 LOGICAL conj, null, reset, same
1544 INTRINSIC abs, dconjg, max, min
1546 INTEGER infot, noutc
1549 COMMON /infoc/infot, noutc, ok, lerr
1551 conj = sname( 5: 5 ).EQ.
'C'
1559 DO 120 in = 1, nidim
1565 $ m = max( n - nd, 0 )
1567 $ m = min( n + nd, nmax )
1577 null = n.LE.0.OR.m.LE.0
1586 CALL
zmake(
'GE',
' ',
' ', 1, m,
x, 1, xx, abs( incx ),
1587 $ 0, m - 1, reset, transl )
1590 xx( 1 + abs( incx )*( m/2 - 1 ) ) = zero
1600 CALL
zmake(
'GE',
' ',
' ', 1, n, y, 1, yy,
1601 $ abs( incy ), 0, n - 1, reset, transl )
1604 yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
1613 CALL
zmake( sname( 2: 3 ),
' ',
' ', m, n, a, nmax,
1614 $ aa, lda, m - 1, n - 1, reset, transl )
1639 $
WRITE( ntra, fmt = 9994 )nc, sname, m, n,
1640 $ alpha, incx, incy, lda
1644 CALL
zgerc( m, n, alpha, xx, incx, yy, incy, aa,
1649 CALL
zgeru( m, n, alpha, xx, incx, yy, incy, aa,
1656 WRITE( nout, fmt = 9993 )
1663 isame( 1 ) = ms.EQ.m
1664 isame( 2 ) = ns.EQ.n
1665 isame( 3 ) = als.EQ.alpha
1666 isame( 4 ) =
lze( xs, xx, lx )
1667 isame( 5 ) = incxs.EQ.incx
1668 isame( 6 ) =
lze( ys, yy, ly )
1669 isame( 7 ) = incys.EQ.incy
1671 isame( 8 ) =
lze( as, aa, laa )
1673 isame( 8 ) =
lzeres(
'GE',
' ', m, n, as, aa,
1676 isame( 9 ) = ldas.EQ.lda
1682 same = same.AND.isame( i )
1683 IF( .NOT.isame( i ) )
1684 $
WRITE( nout, fmt = 9998 )i
1701 z( i ) =
x( m - i + 1 )
1708 w( 1 ) = y( n -
j + 1 )
1711 $ w( 1 ) = dconjg( w( 1 ) )
1712 CALL
zmvch(
'N', m, 1, alpha, z, nmax, w, 1,
1713 $ one, a( 1,
j ), 1, yt, g,
1714 $ aa( 1 + (
j - 1 )*lda ), eps,
1715 $ err, fatal, nout, .true. )
1716 errmax = max( errmax, err )
1738 IF( errmax.LT.thresh )
THEN
1739 WRITE( nout, fmt = 9999 )sname, nc
1741 WRITE( nout, fmt = 9997 )sname, nc, errmax
1746 WRITE( nout, fmt = 9995 )
j
1749 WRITE( nout, fmt = 9996 )sname
1750 WRITE( nout, fmt = 9994 )nc, sname, m, n, alpha, incx, incy, lda
1755 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
1757 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
1758 $
'ANGED INCORRECTLY *******' )
1759 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
1760 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1761 $
' - SUSPECT *******' )
1762 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
1763 9995
FORMAT(
' THESE ARE THE RESULTS FOR COLUMN ', i3 )
1764 9994
FORMAT( 1
x, i6,
': ', a6,
'(', 2( i3,
',' ),
'(', f4.1,
',', f4.1,
1765 $
'), X,', i2,
', Y,', i2,
', A,', i3,
') ',
1767 9993
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1773 SUBROUTINE zchk5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
1774 $ fatal, nidim, idim, nalf, alf, ninc,
inc, nmax,
1775 $ incmax, a, aa, as,
x, xx, xs, y, yy, ys, yt, g,
1787 COMPLEX*16 zero, half, one
1788 parameter( zero = ( 0.0d0, 0.0d0 ),
1789 $ half = ( 0.5d0, 0.0d0 ),
1790 $ one = ( 1.0d0, 0.0d0 ) )
1791 DOUBLE PRECISION rzero
1792 parameter( rzero = 0.0d0 )
1794 DOUBLE PRECISION eps, thresh
1795 INTEGER incmax, nalf, nidim, ninc, nmax, nout, ntra
1796 LOGICAL fatal, rewi, trace
1799 COMPLEX*16 a( nmax, nmax ), aa( nmax*nmax ), alf( nalf ),
1800 $ as( nmax*nmax ),
x( nmax ), xs( nmax*incmax ),
1801 $ xx( nmax*incmax ), y( nmax ),
1802 $ ys( nmax*incmax ), yt( nmax ),
1803 $ yy( nmax*incmax ), z( nmax )
1804 DOUBLE PRECISION g( nmax )
1805 INTEGER idim( nidim ),
inc( ninc )
1807 COMPLEX*16 alpha, transl
1808 DOUBLE PRECISION err, errmax, ralpha, rals
1809 INTEGER i, ia, ic, in, incx, incxs, ix,
j, ja, jj, laa,
1810 $ lda, ldas, lj, lx, n, nargs, nc, ns
1811 LOGICAL full, null, packed, reset, same, upper
1812 CHARACTER*1 uplo, uplos
1823 INTRINSIC abs, dble, dcmplx, dconjg, max
1825 INTEGER infot, noutc
1828 COMMON /infoc/infot, noutc, ok, lerr
1832 full = sname( 3: 3 ).EQ.
'E'
1833 packed = sname( 3: 3 ).EQ.
'P'
1837 ELSE IF( packed )
THEN
1845 DO 100 in = 1, nidim
1855 laa = ( n*( n + 1 ) )/2
1861 uplo = ich( ic: ic )
1871 CALL
zmake(
'GE',
' ',
' ', 1, n,
x, 1, xx, abs( incx ),
1872 $ 0, n - 1, reset, transl )
1875 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
1879 ralpha = dble( alf( ia ) )
1880 alpha = dcmplx( ralpha, rzero )
1881 null = n.LE.0.OR.ralpha.EQ.rzero
1886 CALL
zmake( sname( 2: 3 ), uplo,
' ', n, n, a, nmax,
1887 $ aa, lda, n - 1, n - 1, reset, transl )
1909 $
WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
1913 CALL
zher( uplo, n, ralpha, xx, incx, aa, lda )
1914 ELSE IF( packed )
THEN
1916 $
WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
1920 CALL
zhpr( uplo, n, ralpha, xx, incx, aa )
1926 WRITE( nout, fmt = 9992 )
1933 isame( 1 ) = uplo.EQ.uplos
1934 isame( 2 ) = ns.EQ.n
1935 isame( 3 ) = rals.EQ.ralpha
1936 isame( 4 ) =
lze( xs, xx, lx )
1937 isame( 5 ) = incxs.EQ.incx
1939 isame( 6 ) =
lze( as, aa, laa )
1941 isame( 6 ) =
lzeres( sname( 2: 3 ), uplo, n, n, as,
1944 IF( .NOT.packed )
THEN
1945 isame( 7 ) = ldas.EQ.lda
1952 same = same.AND.isame( i )
1953 IF( .NOT.isame( i ) )
1954 $
WRITE( nout, fmt = 9998 )i
1971 z( i ) =
x( n - i + 1 )
1976 w( 1 ) = dconjg( z(
j ) )
1984 CALL
zmvch(
'N', lj, 1, alpha, z( jj ), lj, w,
1985 $ 1, one, a( jj,
j ), 1, yt, g,
1986 $ aa( ja ), eps, err, fatal, nout,
1997 errmax = max( errmax, err )
2018 IF( errmax.LT.thresh )
THEN
2019 WRITE( nout, fmt = 9999 )sname, nc
2021 WRITE( nout, fmt = 9997 )sname, nc, errmax
2026 WRITE( nout, fmt = 9995 )
j
2029 WRITE( nout, fmt = 9996 )sname
2031 WRITE( nout, fmt = 9993 )nc, sname, uplo, n, ralpha, incx, lda
2032 ELSE IF( packed )
THEN
2033 WRITE( nout, fmt = 9994 )nc, sname, uplo, n, ralpha, incx
2039 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
2041 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
2042 $
'ANGED INCORRECTLY *******' )
2043 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
2044 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2045 $
' - SUSPECT *******' )
2046 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
2047 9995
FORMAT(
' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2048 9994
FORMAT( 1
x, i6,
': ', a6,
'(''', a1,
''',', i3,
',', f4.1,
', X,',
2050 9993
FORMAT( 1
x, i6,
': ', a6,
'(''', a1,
''',', i3,
',', f4.1,
', X,',
2051 $ i2,
', A,', i3,
') .' )
2052 9992
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2058 SUBROUTINE zchk6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
2059 $ fatal, nidim, idim, nalf, alf, ninc,
inc, nmax,
2060 $ incmax, a, aa, as,
x, xx, xs, y, yy, ys, yt, g,
2072 COMPLEX*16 zero, half, one
2073 parameter( zero = ( 0.0d0, 0.0d0 ),
2074 $ half = ( 0.5d0, 0.0d0 ),
2075 $ one = ( 1.0d0, 0.0d0 ) )
2076 DOUBLE PRECISION rzero
2077 parameter( rzero = 0.0d0 )
2079 DOUBLE PRECISION eps, thresh
2080 INTEGER incmax, nalf, nidim, ninc, nmax, nout, ntra
2081 LOGICAL fatal, rewi, trace
2084 COMPLEX*16 a( nmax, nmax ), aa( nmax*nmax ), alf( nalf ),
2085 $ as( nmax*nmax ),
x( nmax ), xs( nmax*incmax ),
2086 $ xx( nmax*incmax ), y( nmax ),
2087 $ ys( nmax*incmax ), yt( nmax ),
2088 $ yy( nmax*incmax ), z( nmax, 2 )
2089 DOUBLE PRECISION g( nmax )
2090 INTEGER idim( nidim ),
inc( ninc )
2092 COMPLEX*16 alpha, als, transl
2093 DOUBLE PRECISION err, errmax
2094 INTEGER i, ia, ic, in, incx, incxs, incy, incys, ix,
2095 $ iy,
j, ja, jj, laa, lda, ldas, lj, lx, ly, n,
2097 LOGICAL full, null, packed, reset, same, upper
2098 CHARACTER*1 uplo, uplos
2109 INTRINSIC abs, dconjg, max
2111 INTEGER infot, noutc
2114 COMMON /infoc/infot, noutc, ok, lerr
2118 full = sname( 3: 3 ).EQ.
'E'
2119 packed = sname( 3: 3 ).EQ.
'P'
2123 ELSE IF( packed )
THEN
2131 DO 140 in = 1, nidim
2141 laa = ( n*( n + 1 ) )/2
2147 uplo = ich( ic: ic )
2157 CALL
zmake(
'GE',
' ',
' ', 1, n,
x, 1, xx, abs( incx ),
2158 $ 0, n - 1, reset, transl )
2161 xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
2171 CALL
zmake(
'GE',
' ',
' ', 1, n, y, 1, yy,
2172 $ abs( incy ), 0, n - 1, reset, transl )
2175 yy( 1 + abs( incy )*( n/2 - 1 ) ) = zero
2180 null = n.LE.0.OR.alpha.EQ.zero
2185 CALL
zmake( sname( 2: 3 ), uplo,
' ', n, n, a,
2186 $ nmax, aa, lda, n - 1, n - 1, reset,
2213 $
WRITE( ntra, fmt = 9993 )nc, sname, uplo, n,
2214 $ alpha, incx, incy, lda
2217 CALL
zher2( uplo, n, alpha, xx, incx, yy, incy,
2219 ELSE IF( packed )
THEN
2221 $
WRITE( ntra, fmt = 9994 )nc, sname, uplo, n,
2225 CALL
zhpr2( uplo, n, alpha, xx, incx, yy, incy,
2232 WRITE( nout, fmt = 9992 )
2239 isame( 1 ) = uplo.EQ.uplos
2240 isame( 2 ) = ns.EQ.n
2241 isame( 3 ) = als.EQ.alpha
2242 isame( 4 ) =
lze( xs, xx, lx )
2243 isame( 5 ) = incxs.EQ.incx
2244 isame( 6 ) =
lze( ys, yy, ly )
2245 isame( 7 ) = incys.EQ.incy
2247 isame( 8 ) =
lze( as, aa, laa )
2249 isame( 8 ) =
lzeres( sname( 2: 3 ), uplo, n, n,
2252 IF( .NOT.packed )
THEN
2253 isame( 9 ) = ldas.EQ.lda
2260 same = same.AND.isame( i )
2261 IF( .NOT.isame( i ) )
2262 $
WRITE( nout, fmt = 9998 )i
2279 z( i, 1 ) =
x( n - i + 1 )
2288 z( i, 2 ) = y( n - i + 1 )
2293 w( 1 ) = alpha*dconjg( z(
j, 2 ) )
2294 w( 2 ) = dconjg( alpha )*dconjg( z(
j, 1 ) )
2302 CALL
zmvch(
'N', lj, 2, one, z( jj, 1 ),
2303 $ nmax, w, 1, one, a( jj,
j ), 1,
2304 $ yt, g, aa( ja ), eps, err, fatal,
2315 errmax = max( errmax, err )
2338 IF( errmax.LT.thresh )
THEN
2339 WRITE( nout, fmt = 9999 )sname, nc
2341 WRITE( nout, fmt = 9997 )sname, nc, errmax
2346 WRITE( nout, fmt = 9995 )
j
2349 WRITE( nout, fmt = 9996 )sname
2351 WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, incx,
2353 ELSE IF( packed )
THEN
2354 WRITE( nout, fmt = 9994 )nc, sname, uplo, n, alpha, incx, incy
2360 9999
FORMAT(
' ', a6,
' PASSED THE COMPUTATIONAL TESTS (', i6,
' CALL',
2362 9998
FORMAT(
' ******* FATAL ERROR - PARAMETER NUMBER ', i2,
' WAS CH',
2363 $
'ANGED INCORRECTLY *******' )
2364 9997
FORMAT(
' ', a6,
' COMPLETED THE COMPUTATIONAL TESTS (', i6,
' C',
2365 $
'ALLS)', /
' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
2366 $
' - SUSPECT *******' )
2367 9996
FORMAT(
' ******* ', a6,
' FAILED ON CALL NUMBER:' )
2368 9995
FORMAT(
' THESE ARE THE RESULTS FOR COLUMN ', i3 )
2369 9994
FORMAT( 1
x, i6,
': ', a6,
'(''', a1,
''',', i3,
',(', f4.1,
',',
2370 $ f4.1,
'), X,', i2,
', Y,', i2,
', AP) ',
2372 9993
FORMAT( 1
x, i6,
': ', a6,
'(''', a1,
''',', i3,
',(', f4.1,
',',
2373 $ f4.1,
'), X,', i2,
', Y,', i2,
', A,', i3,
') ',
2375 9992
FORMAT(
' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
2397 INTEGER infot, noutc
2400 COMPLEX*16 alpha, beta
2401 DOUBLE PRECISION ralpha
2403 COMPLEX*16 a( 1, 1 ),
x( 1 ), y( 1 )
2409 COMMON /infoc/infot, noutc, ok, lerr
2417 go to( 10, 20, 30, 40, 50, 60, 70, 80,
2418 $ 90, 100, 110, 120, 130, 140, 150, 160,
2421 CALL
zgemv(
'/', 0, 0, alpha, a, 1,
x, 1, beta, y, 1 )
2422 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2424 CALL
zgemv(
'N', -1, 0, alpha, a, 1,
x, 1, beta, y, 1 )
2425 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2427 CALL
zgemv(
'N', 0, -1, alpha, a, 1,
x, 1, beta, y, 1 )
2428 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2430 CALL
zgemv(
'N', 2, 0, alpha, a, 1,
x, 1, beta, y, 1 )
2431 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2433 CALL
zgemv(
'N', 0, 0, alpha, a, 1,
x, 0, beta, y, 1 )
2434 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2436 CALL
zgemv(
'N', 0, 0, alpha, a, 1,
x, 1, beta, y, 0 )
2437 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2440 CALL
zgbmv(
'/', 0, 0, 0, 0, alpha, a, 1,
x, 1, beta, y, 1 )
2441 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2443 CALL
zgbmv(
'N', -1, 0, 0, 0, alpha, a, 1,
x, 1, beta, y, 1 )
2444 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2446 CALL
zgbmv(
'N', 0, -1, 0, 0, alpha, a, 1,
x, 1, beta, y, 1 )
2447 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2449 CALL
zgbmv(
'N', 0, 0, -1, 0, alpha, a, 1,
x, 1, beta, y, 1 )
2450 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2452 CALL
zgbmv(
'N', 2, 0, 0, -1, alpha, a, 1,
x, 1, beta, y, 1 )
2453 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2455 CALL
zgbmv(
'N', 0, 0, 1, 0, alpha, a, 1,
x, 1, beta, y, 1 )
2456 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2458 CALL
zgbmv(
'N', 0, 0, 0, 0, alpha, a, 1,
x, 0, beta, y, 1 )
2459 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2461 CALL
zgbmv(
'N', 0, 0, 0, 0, alpha, a, 1,
x, 1, beta, y, 0 )
2462 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2465 CALL
zhemv(
'/', 0, alpha, a, 1,
x, 1, beta, y, 1 )
2466 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2468 CALL
zhemv(
'U', -1, alpha, a, 1,
x, 1, beta, y, 1 )
2469 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2471 CALL
zhemv(
'U', 2, alpha, a, 1,
x, 1, beta, y, 1 )
2472 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2474 CALL
zhemv(
'U', 0, alpha, a, 1,
x, 0, beta, y, 1 )
2475 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2477 CALL
zhemv(
'U', 0, alpha, a, 1,
x, 1, beta, y, 0 )
2478 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2481 CALL
zhbmv(
'/', 0, 0, alpha, a, 1,
x, 1, beta, y, 1 )
2482 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2484 CALL
zhbmv(
'U', -1, 0, alpha, a, 1,
x, 1, beta, y, 1 )
2485 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2487 CALL
zhbmv(
'U', 0, -1, alpha, a, 1,
x, 1, beta, y, 1 )
2488 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2490 CALL
zhbmv(
'U', 0, 1, alpha, a, 1,
x, 1, beta, y, 1 )
2491 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2493 CALL
zhbmv(
'U', 0, 0, alpha, a, 1,
x, 0, beta, y, 1 )
2494 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2496 CALL
zhbmv(
'U', 0, 0, alpha, a, 1,
x, 1, beta, y, 0 )
2497 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2500 CALL
zhpmv(
'/', 0, alpha, a,
x, 1, beta, y, 1 )
2501 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2503 CALL
zhpmv(
'U', -1, alpha, a,
x, 1, beta, y, 1 )
2504 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2506 CALL
zhpmv(
'U', 0, alpha, a,
x, 0, beta, y, 1 )
2507 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2509 CALL
zhpmv(
'U', 0, alpha, a,
x, 1, beta, y, 0 )
2510 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2513 CALL
ztrmv(
'/',
'N',
'N', 0, a, 1,
x, 1 )
2514 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2516 CALL
ztrmv(
'U',
'/',
'N', 0, a, 1,
x, 1 )
2517 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2519 CALL
ztrmv(
'U',
'N',
'/', 0, a, 1,
x, 1 )
2520 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2522 CALL
ztrmv(
'U',
'N',
'N', -1, a, 1,
x, 1 )
2523 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2525 CALL
ztrmv(
'U',
'N',
'N', 2, a, 1,
x, 1 )
2526 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2528 CALL
ztrmv(
'U',
'N',
'N', 0, a, 1,
x, 0 )
2529 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2532 CALL
ztbmv(
'/',
'N',
'N', 0, 0, a, 1,
x, 1 )
2533 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2535 CALL
ztbmv(
'U',
'/',
'N', 0, 0, a, 1,
x, 1 )
2536 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2538 CALL
ztbmv(
'U',
'N',
'/', 0, 0, a, 1,
x, 1 )
2539 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2541 CALL
ztbmv(
'U',
'N',
'N', -1, 0, a, 1,
x, 1 )
2542 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2544 CALL
ztbmv(
'U',
'N',
'N', 0, -1, a, 1,
x, 1 )
2545 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2547 CALL
ztbmv(
'U',
'N',
'N', 0, 1, a, 1,
x, 1 )
2548 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2550 CALL
ztbmv(
'U',
'N',
'N', 0, 0, a, 1,
x, 0 )
2551 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2554 CALL
ztpmv(
'/',
'N',
'N', 0, a,
x, 1 )
2555 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2557 CALL
ztpmv(
'U',
'/',
'N', 0, a,
x, 1 )
2558 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2560 CALL
ztpmv(
'U',
'N',
'/', 0, a,
x, 1 )
2561 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2563 CALL
ztpmv(
'U',
'N',
'N', -1, a,
x, 1 )
2564 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2566 CALL
ztpmv(
'U',
'N',
'N', 0, a,
x, 0 )
2567 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2570 CALL
ztrsv(
'/',
'N',
'N', 0, a, 1,
x, 1 )
2571 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2573 CALL
ztrsv(
'U',
'/',
'N', 0, a, 1,
x, 1 )
2574 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2576 CALL
ztrsv(
'U',
'N',
'/', 0, a, 1,
x, 1 )
2577 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2579 CALL
ztrsv(
'U',
'N',
'N', -1, a, 1,
x, 1 )
2580 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2582 CALL
ztrsv(
'U',
'N',
'N', 2, a, 1,
x, 1 )
2583 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2585 CALL
ztrsv(
'U',
'N',
'N', 0, a, 1,
x, 0 )
2586 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2589 CALL
ztbsv(
'/',
'N',
'N', 0, 0, a, 1,
x, 1 )
2590 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2592 CALL
ztbsv(
'U',
'/',
'N', 0, 0, a, 1,
x, 1 )
2593 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2595 CALL
ztbsv(
'U',
'N',
'/', 0, 0, a, 1,
x, 1 )
2596 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2598 CALL
ztbsv(
'U',
'N',
'N', -1, 0, a, 1,
x, 1 )
2599 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2601 CALL
ztbsv(
'U',
'N',
'N', 0, -1, a, 1,
x, 1 )
2602 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2604 CALL
ztbsv(
'U',
'N',
'N', 0, 1, a, 1,
x, 1 )
2605 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2607 CALL
ztbsv(
'U',
'N',
'N', 0, 0, a, 1,
x, 0 )
2608 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2611 CALL
ztpsv(
'/',
'N',
'N', 0, a,
x, 1 )
2612 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2614 CALL
ztpsv(
'U',
'/',
'N', 0, a,
x, 1 )
2615 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2617 CALL
ztpsv(
'U',
'N',
'/', 0, a,
x, 1 )
2618 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2620 CALL
ztpsv(
'U',
'N',
'N', -1, a,
x, 1 )
2621 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2623 CALL
ztpsv(
'U',
'N',
'N', 0, a,
x, 0 )
2624 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2627 CALL
zgerc( -1, 0, alpha,
x, 1, y, 1, a, 1 )
2628 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2630 CALL
zgerc( 0, -1, alpha,
x, 1, y, 1, a, 1 )
2631 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2633 CALL
zgerc( 0, 0, alpha,
x, 0, y, 1, a, 1 )
2634 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2636 CALL
zgerc( 0, 0, alpha,
x, 1, y, 0, a, 1 )
2637 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2639 CALL
zgerc( 2, 0, alpha,
x, 1, y, 1, a, 1 )
2640 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2643 CALL
zgeru( -1, 0, alpha,
x, 1, y, 1, a, 1 )
2644 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2646 CALL
zgeru( 0, -1, alpha,
x, 1, y, 1, a, 1 )
2647 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2649 CALL
zgeru( 0, 0, alpha,
x, 0, y, 1, a, 1 )
2650 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2652 CALL
zgeru( 0, 0, alpha,
x, 1, y, 0, a, 1 )
2653 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2655 CALL
zgeru( 2, 0, alpha,
x, 1, y, 1, a, 1 )
2656 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2659 CALL
zher(
'/', 0, ralpha,
x, 1, a, 1 )
2660 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2662 CALL
zher(
'U', -1, ralpha,
x, 1, a, 1 )
2663 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2665 CALL
zher(
'U', 0, ralpha,
x, 0, a, 1 )
2666 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2668 CALL
zher(
'U', 2, ralpha,
x, 1, a, 1 )
2669 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2672 CALL
zhpr(
'/', 0, ralpha,
x, 1, a )
2673 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2675 CALL
zhpr(
'U', -1, ralpha,
x, 1, a )
2676 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2678 CALL
zhpr(
'U', 0, ralpha,
x, 0, a )
2679 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2682 CALL
zher2(
'/', 0, alpha,
x, 1, y, 1, a, 1 )
2683 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2685 CALL
zher2(
'U', -1, alpha,
x, 1, y, 1, a, 1 )
2686 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2688 CALL
zher2(
'U', 0, alpha,
x, 0, y, 1, a, 1 )
2689 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2691 CALL
zher2(
'U', 0, alpha,
x, 1, y, 0, a, 1 )
2692 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2694 CALL
zher2(
'U', 2, alpha,
x, 1, y, 1, a, 1 )
2695 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2698 CALL
zhpr2(
'/', 0, alpha,
x, 1, y, 1, a )
2699 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2701 CALL
zhpr2(
'U', -1, alpha,
x, 1, y, 1, a )
2702 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2704 CALL
zhpr2(
'U', 0, alpha,
x, 0, y, 1, a )
2705 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2707 CALL
zhpr2(
'U', 0, alpha,
x, 1, y, 0, a )
2708 CALL
chkxer( srnamt, infot, nout, lerr, ok )
2711 WRITE( nout, fmt = 9999 )srnamt
2713 WRITE( nout, fmt = 9998 )srnamt
2717 9999
FORMAT(
' ', a6,
' PASSED THE TESTS OF ERROR-EXITS' )
2718 9998
FORMAT(
' ******* ', a6,
' FAILED THE TESTS OF ERROR-EXITS *****',
2724 SUBROUTINE zmake( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
2725 $ ku, reset, transl )
2741 COMPLEX*16 zero, one
2742 parameter( zero = ( 0.0d0, 0.0d0 ),
2743 $ one = ( 1.0d0, 0.0d0 ) )
2745 parameter( rogue = ( -1.0d10, 1.0d10 ) )
2746 DOUBLE PRECISION rzero
2747 parameter( rzero = 0.0d0 )
2748 DOUBLE PRECISION rrogue
2749 parameter( rrogue = -1.0d10 )
2752 INTEGER kl, ku, lda, m, n, nmax
2754 CHARACTER*1 diag, uplo
2757 COMPLEX*16 a( nmax, * ), aa( * )
2759 INTEGER i, i1, i2, i3, ibeg, iend, ioff,
j, jj, kk
2760 LOGICAL gen, lower, sym, tri, unit, upper
2765 INTRINSIC dble, dcmplx, dconjg, max, min
2767 gen =
TYPE( 1: 1
).EQ.
'G'
2768 sym =
TYPE( 1: 1
).EQ.
'H'
2769 tri =
TYPE( 1: 1
).EQ.
'T'
2770 upper = ( sym.OR.tri ).AND.uplo.EQ.
'U'
2771 lower = ( sym.OR.tri ).AND.uplo.EQ.
'L'
2772 unit = tri.AND.diag.EQ.
'U'
2778 IF( gen.OR.( upper.AND.i.LE.
j ).OR.( lower.AND.i.GE.
j ) )
2780 IF( ( i.LE.
j.AND.
j - i.LE.ku ).OR.
2781 $ ( i.GE.
j.AND.i -
j.LE.kl ) )
THEN
2782 a( i,
j ) =
zbeg( reset ) + transl
2788 a(
j, i ) = dconjg( a( i,
j ) )
2796 $ a(
j,
j ) = dcmplx( dble( a(
j,
j ) ), rzero )
2798 $ a(
j,
j ) = a(
j,
j ) + one
2805 IF( type.EQ.
'GE' )
THEN
2808 aa( i + (
j - 1 )*lda ) = a( i,
j )
2810 DO 40 i = m + 1, lda
2811 aa( i + (
j - 1 )*lda ) = rogue
2814 ELSE IF( type.EQ.
'GB' )
THEN
2816 DO 60 i1 = 1, ku + 1 -
j
2817 aa( i1 + (
j - 1 )*lda ) = rogue
2819 DO 70 i2 = i1, min( kl + ku + 1, ku + 1 + m -
j )
2820 aa( i2 + (
j - 1 )*lda ) = a( i2 +
j - ku - 1,
j )
2823 aa( i3 + (
j - 1 )*lda ) = rogue
2826 ELSE IF( type.EQ.
'HE'.OR.type.EQ.
'TR' )
THEN
2843 DO 100 i = 1, ibeg - 1
2844 aa( i + (
j - 1 )*lda ) = rogue
2846 DO 110 i = ibeg, iend
2847 aa( i + (
j - 1 )*lda ) = a( i,
j )
2849 DO 120 i = iend + 1, lda
2850 aa( i + (
j - 1 )*lda ) = rogue
2853 jj =
j + (
j - 1 )*lda
2854 aa( jj ) = dcmplx( dble( aa( jj ) ), rrogue )
2857 ELSE IF( type.EQ.
'HB'.OR.type.EQ.
'TB' )
THEN
2861 ibeg = max( 1, kl + 2 -
j )
2874 iend = min( kl + 1, 1 + m -
j )
2876 DO 140 i = 1, ibeg - 1
2877 aa( i + (
j - 1 )*lda ) = rogue
2879 DO 150 i = ibeg, iend
2880 aa( i + (
j - 1 )*lda ) = a( i +
j - kk,
j )
2882 DO 160 i = iend + 1, lda
2883 aa( i + (
j - 1 )*lda ) = rogue
2886 jj = kk + (
j - 1 )*lda
2887 aa( jj ) = dcmplx( dble( aa( jj ) ), rrogue )
2890 ELSE IF( type.EQ.
'HP'.OR.type.EQ.
'TP' )
THEN
2900 DO 180 i = ibeg, iend
2902 aa( ioff ) = a( i,
j )
2905 $ aa( ioff ) = rogue
2907 $ aa( ioff ) = dcmplx( dble( aa( ioff ) ), rrogue )
2917 SUBROUTINE zmvch( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
2918 $ incy, yt, g, yy, eps, err, fatal, nout, mv )
2930 parameter( zero = ( 0.0d0, 0.0d0 ) )
2931 DOUBLE PRECISION rzero, rone
2932 parameter( rzero = 0.0d0, rone = 1.0d0 )
2934 COMPLEX*16 alpha, beta
2935 DOUBLE PRECISION eps, err
2936 INTEGER incx, incy, m, n, nmax, nout
2940 COMPLEX*16 a( nmax, * ),
x( * ), y( * ), yt( * ), yy( * )
2941 DOUBLE PRECISION g( * )
2944 DOUBLE PRECISION erri
2945 INTEGER i, incxl, incyl, iy,
j, jx, kx, ky, ml, nl
2948 INTRINSIC abs, dble, dconjg, dimag, max, sqrt
2950 DOUBLE PRECISION abs1
2952 abs1( c ) = abs( dble( c ) ) + abs( dimag( c ) )
2955 ctran = trans.EQ.
'C'
2956 IF( tran.OR.ctran )
THEN
2988 yt( iy ) = yt( iy ) + a(
j, i )*
x( jx )
2989 g( iy ) = g( iy ) + abs1( a(
j, i ) )*abs1(
x( jx ) )
2992 ELSE IF( ctran )
THEN
2994 yt( iy ) = yt( iy ) + dconjg( a(
j, i ) )*
x( jx )
2995 g( iy ) = g( iy ) + abs1( a(
j, i ) )*abs1(
x( jx ) )
3000 yt( iy ) = yt( iy ) + a( i,
j )*
x( jx )
3001 g( iy ) = g( iy ) + abs1( a( i,
j ) )*abs1(
x( jx ) )
3005 yt( iy ) = alpha*yt( iy ) + beta*y( iy )
3006 g( iy ) = abs1( alpha )*g( iy ) + abs1( beta )*abs1( y( iy ) )
3014 erri = abs( yt( i ) - yy( 1 + ( i - 1 )*abs( incy ) ) )/eps
3015 IF( g( i ).NE.rzero )
3016 $ erri = erri/g( i )
3017 err = max( err, erri )
3018 IF( err*sqrt( eps ).GE.rone )
3027 WRITE( nout, fmt = 9999 )
3030 WRITE( nout, fmt = 9998 )i, yt( i ),
3031 $ yy( 1 + ( i - 1 )*abs( incy ) )
3033 WRITE( nout, fmt = 9998 )i,
3034 $ yy( 1 + ( i - 1 )*abs( incy ) ), yt( i )
3041 9999
FORMAT(
' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
3042 $
'F ACCURATE *******', /
' EXPECTED RE',
3043 $
'SULT COMPUTED RESULT' )
3044 9998
FORMAT( 1
x, i7, 2(
' (', g15.6,
',', g15.6,
')' ) )
3049 LOGICAL FUNCTION lze( RI, RJ, LR )
3062 COMPLEX*16 ri( * ), rj( * )
3067 IF( ri( i ).NE.rj( i ) )
3079 LOGICAL FUNCTION lzeres( TYPE, UPLO, M, N, AA, AS, LDA )
3096 COMPLEX*16 aa( lda, * ), as( lda, * )
3098 INTEGER i, ibeg, iend,
j
3102 IF( type.EQ.
'GE' )
THEN
3104 DO 10 i = m + 1, lda
3105 IF( aa( i,
j ).NE.as( i,
j ) )
3109 ELSE IF( type.EQ.
'HE' )
THEN
3118 DO 30 i = 1, ibeg - 1
3119 IF( aa( i,
j ).NE.as( i,
j ) )
3122 DO 40 i = iend + 1, lda
3123 IF( aa( i,
j ).NE.as( i,
j ) )
3152 INTEGER i, ic,
j, mi, mj
3154 SAVE i, ic,
j, mi, mj
3178 i = i - 1000*( i/1000 )
3179 j =
j - 1000*(
j/1000 )
3184 zbeg = dcmplx( ( i - 500 )/1001.0d0, (
j - 500 )/1001.0d0 )
3198 DOUBLE PRECISION x, y
3206 SUBROUTINE chkxer( SRNAMT, INFOT, NOUT, LERR, OK )
3222 WRITE( nout, fmt = 9999 )infot, srnamt
3228 9999
FORMAT(
' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', i2,
' NOT D',
3229 $
'ETECTED BY ', a6,
' *****' )
3259 COMMON /infoc/infot, nout, ok, lerr
3260 COMMON /srnamc/srnamt
3263 IF( info.NE.infot )
THEN
3264 IF( infot.NE.0 )
THEN
3265 WRITE( nout, fmt = 9999 )info, infot
3267 WRITE( nout, fmt = 9997 )info
3271 IF( srname.NE.srnamt )
THEN
3272 WRITE( nout, fmt = 9998 )srname, srnamt
3277 9999
FORMAT(
' ******* XERBLA WAS CALLED WITH INFO = ', i6,
' INSTEAD',
3278 $
' OF ', i2,
' *******' )
3279 9998
FORMAT(
' ******* XERBLA WAS CALLED WITH SRNAME = ', a6,
' INSTE',
3280 $
'AD OF ', a6,
' *******' )
3281 9997
FORMAT(
' ******* XERBLA WAS CALLED WITH INFO = ', i6,
subroutine zchk4(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)
LOGICAL function lze(RI, RJ, LR)
subroutine ztbmv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
ZTBMV
DOUBLE PRECISION function ddiff(X, Y)
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
subroutine ztrsv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
ZTRSV
subroutine ztpmv(UPLO, TRANS, DIAG, N, AP, X, INCX)
ZTPMV
subroutine zchk1(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 zgerc(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERC
subroutine zgbmv(TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGBMV
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zmvch(TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV)
subroutine zchke(ISNUM, SRNAMT, NOUT)
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
LOGICAL function lzeres(TYPE, UPLO, M, N, AA, AS, LDA)
subroutine zchk5(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 zchk3(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 ztpsv(UPLO, TRANS, DIAG, N, AP, X, INCX)
ZTPSV
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 zchk6(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)
COMPLEX *16 function zbeg(RESET)
subroutine ztrmv(UPLO, TRANS, DIAG, N, A, LDA, X, INCX)
ZTRMV
subroutine zchk2(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 zhpr2(UPLO, N, ALPHA, X, INCX, Y, INCY, AP)
ZHPR2
subroutine zmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine zhbmv(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZHBMV
subroutine zhemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZHEMV
subroutine ztbsv(UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX)
ZTBSV
subroutine zher(UPLO, N, ALPHA, X, INCX, A, LDA)
ZHER
subroutine zhpr(UPLO, N, ALPHA, X, INCX, AP)
ZHPR
subroutine zhpmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
ZHPMV
subroutine zher2(UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZHER2
subroutine zgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERU