LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cchk2 ( character*6  SNAME,
real  EPS,
real  THRESH,
integer  NOUT,
integer  NTRA,
logical  TRACE,
logical  REWI,
logical  FATAL,
integer  NIDIM,
integer, dimension( nidim )  IDIM,
integer  NKB,
integer, dimension( nkb )  KB,
integer  NALF,
complex, dimension( nalf )  ALF,
integer  NBET,
complex, dimension( nbet )  BET,
integer  NINC,
integer, dimension( ninc )  INC,
integer  NMAX,
integer  INCMAX,
complex, dimension( nmax, nmax )  A,
complex, dimension( nmax*nmax )  AA,
complex, dimension( nmax*nmax )  AS,
complex, dimension( nmax )  X,
complex, dimension( nmax*incmax )  XX,
complex, dimension( nmax*incmax )  XS,
complex, dimension( nmax )  Y,
complex, dimension( nmax*incmax )  YY,
complex, dimension( nmax*incmax )  YS,
complex, dimension( nmax )  YT,
real, dimension( nmax )  G 
)

Definition at line 786 of file cblat2.f.

786 *
787 * Tests CHEMV, CHBMV and CHPMV.
788 *
789 * Auxiliary routine for test program for Level 2 Blas.
790 *
791 * -- Written on 10-August-1987.
792 * Richard Hanson, Sandia National Labs.
793 * Jeremy Du Croz, NAG Central Office.
794 *
795 * .. Parameters ..
796  COMPLEX zero, half
797  parameter ( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ) )
798  REAL rzero
799  parameter ( rzero = 0.0 )
800 * .. Scalar Arguments ..
801  REAL eps, thresh
802  INTEGER incmax, nalf, nbet, nidim, ninc, nkb, nmax,
803  $ nout, ntra
804  LOGICAL fatal, rewi, trace
805  CHARACTER*6 sname
806 * .. Array Arguments ..
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 ),
811  $ yy( nmax*incmax )
812  REAL g( nmax )
813  INTEGER idim( nidim ), inc( ninc ), kb( nkb )
814 * .. Local Scalars ..
815  COMPLEX alpha, als, beta, bls, transl
816  REAL err, errmax
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
822  CHARACTER*2 ich
823 * .. Local Arrays ..
824  LOGICAL isame( 13 )
825 * .. External Functions ..
826  LOGICAL lce, lceres
827  EXTERNAL lce, lceres
828 * .. External Subroutines ..
829  EXTERNAL chbmv, chemv, chpmv, cmake, cmvch
830 * .. Intrinsic Functions ..
831  INTRINSIC abs, max
832 * .. Scalars in Common ..
833  INTEGER infot, noutc
834  LOGICAL lerr, ok
835 * .. Common blocks ..
836  COMMON /infoc/infot, noutc, ok, lerr
837 * .. Data statements ..
838  DATA ich/'UL'/
839 * .. Executable Statements ..
840  full = sname( 3: 3 ).EQ.'E'
841  banded = sname( 3: 3 ).EQ.'B'
842  packed = sname( 3: 3 ).EQ.'P'
843 * Define the number of arguments.
844  IF( full )THEN
845  nargs = 10
846  ELSE IF( banded )THEN
847  nargs = 11
848  ELSE IF( packed )THEN
849  nargs = 9
850  END IF
851 *
852  nc = 0
853  reset = .true.
854  errmax = rzero
855 *
856  DO 110 in = 1, nidim
857  n = idim( in )
858 *
859  IF( banded )THEN
860  nk = nkb
861  ELSE
862  nk = 1
863  END IF
864  DO 100 ik = 1, nk
865  IF( banded )THEN
866  k = kb( ik )
867  ELSE
868  k = n - 1
869  END IF
870 * Set LDA to 1 more than minimum value if room.
871  IF( banded )THEN
872  lda = k + 1
873  ELSE
874  lda = n
875  END IF
876  IF( lda.LT.nmax )
877  $ lda = lda + 1
878 * Skip tests if not enough room.
879  IF( lda.GT.nmax )
880  $ GO TO 100
881  IF( packed )THEN
882  laa = ( n*( n + 1 ) )/2
883  ELSE
884  laa = lda*n
885  END IF
886  null = n.LE.0
887 *
888  DO 90 ic = 1, 2
889  uplo = ich( ic: ic )
890 *
891 * Generate the matrix A.
892 *
893  transl = zero
894  CALL cmake( sname( 2: 3 ), uplo, ' ', n, n, a, nmax, aa,
895  $ lda, k, k, reset, transl )
896 *
897  DO 80 ix = 1, ninc
898  incx = inc( ix )
899  lx = abs( incx )*n
900 *
901 * Generate the vector X.
902 *
903  transl = half
904  CALL cmake( 'GE', ' ', ' ', 1, n, x, 1, xx,
905  $ abs( incx ), 0, n - 1, reset, transl )
906  IF( n.GT.1 )THEN
907  x( n/2 ) = zero
908  xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
909  END IF
910 *
911  DO 70 iy = 1, ninc
912  incy = inc( iy )
913  ly = abs( incy )*n
914 *
915  DO 60 ia = 1, nalf
916  alpha = alf( ia )
917 *
918  DO 50 ib = 1, nbet
919  beta = bet( ib )
920 *
921 * Generate the vector Y.
922 *
923  transl = zero
924  CALL cmake( 'GE', ' ', ' ', 1, n, y, 1, yy,
925  $ abs( incy ), 0, n - 1, reset,
926  $ transl )
927 *
928  nc = nc + 1
929 *
930 * Save every datum before calling the
931 * subroutine.
932 *
933  uplos = uplo
934  ns = n
935  ks = k
936  als = alpha
937  DO 10 i = 1, laa
938  as( i ) = aa( i )
939  10 CONTINUE
940  ldas = lda
941  DO 20 i = 1, lx
942  xs( i ) = xx( i )
943  20 CONTINUE
944  incxs = incx
945  bls = beta
946  DO 30 i = 1, ly
947  ys( i ) = yy( i )
948  30 CONTINUE
949  incys = incy
950 *
951 * Call the subroutine.
952 *
953  IF( full )THEN
954  IF( trace )
955  $ WRITE( ntra, fmt = 9993 )nc, sname,
956  $ uplo, n, alpha, lda, incx, beta, incy
957  IF( rewi )
958  $ rewind ntra
959  CALL chemv( uplo, n, alpha, aa, lda, xx,
960  $ incx, beta, yy, incy )
961  ELSE IF( banded )THEN
962  IF( trace )
963  $ WRITE( ntra, fmt = 9994 )nc, sname,
964  $ uplo, n, k, alpha, lda, incx, beta,
965  $ incy
966  IF( rewi )
967  $ rewind ntra
968  CALL chbmv( uplo, n, k, alpha, aa, lda,
969  $ xx, incx, beta, yy, incy )
970  ELSE IF( packed )THEN
971  IF( trace )
972  $ WRITE( ntra, fmt = 9995 )nc, sname,
973  $ uplo, n, alpha, incx, beta, incy
974  IF( rewi )
975  $ rewind ntra
976  CALL chpmv( uplo, n, alpha, aa, xx, incx,
977  $ beta, yy, incy )
978  END IF
979 *
980 * Check if error-exit was taken incorrectly.
981 *
982  IF( .NOT.ok )THEN
983  WRITE( nout, fmt = 9992 )
984  fatal = .true.
985  GO TO 120
986  END IF
987 *
988 * See what data changed inside subroutines.
989 *
990  isame( 1 ) = uplo.EQ.uplos
991  isame( 2 ) = ns.EQ.n
992  IF( full )THEN
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
999  IF( null )THEN
1000  isame( 9 ) = lce( ys, yy, ly )
1001  ELSE
1002  isame( 9 ) = lceres( 'GE', ' ', 1, n,
1003  $ ys, yy, abs( incy ) )
1004  END IF
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
1014  IF( null )THEN
1015  isame( 10 ) = lce( ys, yy, ly )
1016  ELSE
1017  isame( 10 ) = lceres( 'GE', ' ', 1, n,
1018  $ ys, yy, abs( incy ) )
1019  END IF
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
1027  IF( null )THEN
1028  isame( 8 ) = lce( ys, yy, ly )
1029  ELSE
1030  isame( 8 ) = lceres( 'GE', ' ', 1, n,
1031  $ ys, yy, abs( incy ) )
1032  END IF
1033  isame( 9 ) = incys.EQ.incy
1034  END IF
1035 *
1036 * If data was incorrectly changed, report and
1037 * return.
1038 *
1039  same = .true.
1040  DO 40 i = 1, nargs
1041  same = same.AND.isame( i )
1042  IF( .NOT.isame( i ) )
1043  $ WRITE( nout, fmt = 9998 )i
1044  40 CONTINUE
1045  IF( .NOT.same )THEN
1046  fatal = .true.
1047  GO TO 120
1048  END IF
1049 *
1050  IF( .NOT.null )THEN
1051 *
1052 * Check the result.
1053 *
1054  CALL cmvch( 'N', n, n, alpha, a, nmax, x,
1055  $ incx, beta, y, incy, yt, g,
1056  $ yy, eps, err, fatal, nout,
1057  $ .true. )
1058  errmax = max( errmax, err )
1059 * If got really bad answer, report and
1060 * return.
1061  IF( fatal )
1062  $ GO TO 120
1063  ELSE
1064 * Avoid repeating tests with N.le.0
1065  GO TO 110
1066  END IF
1067 *
1068  50 CONTINUE
1069 *
1070  60 CONTINUE
1071 *
1072  70 CONTINUE
1073 *
1074  80 CONTINUE
1075 *
1076  90 CONTINUE
1077 *
1078  100 CONTINUE
1079 *
1080  110 CONTINUE
1081 *
1082 * Report result.
1083 *
1084  IF( errmax.LT.thresh )THEN
1085  WRITE( nout, fmt = 9999 )sname, nc
1086  ELSE
1087  WRITE( nout, fmt = 9997 )sname, nc, errmax
1088  END IF
1089  GO TO 130
1090 *
1091  120 CONTINUE
1092  WRITE( nout, fmt = 9996 )sname
1093  IF( full )THEN
1094  WRITE( nout, fmt = 9993 )nc, sname, uplo, n, alpha, lda, incx,
1095  $ beta, incy
1096  ELSE IF( banded )THEN
1097  WRITE( nout, fmt = 9994 )nc, sname, uplo, n, k, alpha, lda,
1098  $ incx, beta, incy
1099  ELSE IF( packed )THEN
1100  WRITE( nout, fmt = 9995 )nc, sname, uplo, n, alpha, incx,
1101  $ beta, incy
1102  END IF
1103 *
1104  130 CONTINUE
1105  RETURN
1106 *
1107  9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1108  $ 'S)' )
1109  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1110  $ 'ANGED INCORRECTLY *******' )
1111  9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1112  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1113  $ ' - SUSPECT *******' )
1114  9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
1115  9995 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',(', f4.1, ',',
1116  $ f4.1, '), AP, X,', i2, ',(', f4.1, ',', f4.1, '), Y,', i2,
1117  $ ') .' )
1118  9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', 2( i3, ',' ), '(',
1119  $ f4.1, ',', f4.1, '), A,', i3, ', X,', i2, ',(', f4.1, ',',
1120  $ f4.1, '), Y,', i2, ') .' )
1121  9993 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', i3, ',(', f4.1, ',',
1122  $ f4.1, '), A,', i3, ', X,', i2, ',(', f4.1, ',', f4.1, '), ',
1123  $ 'Y,', i2, ') .' )
1124  9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1125  $ '******' )
1126 *
1127 * End of CCHK2.
1128 *
chbmv
subroutine chbmv(UPLO, N, K, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CHBMV
Definition: chbmv.f:189
chpmv
subroutine chpmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
CHPMV
Definition: chpmv.f:151
cmvch
subroutine cmvch(TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV)
Definition: cblat2.f:2911
lce
logical function lce(RI, RJ, LR)
Definition: cblat2.f:3042
chemv
subroutine chemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CHEMV
Definition: chemv.f:156
cmake
subroutine cmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: cblat2.f:2719
lceres
logical function lceres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: cblat2.f:3072

Here is the call graph for this function:

Here is the caller graph for this function: