LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine cchk2 ( character*12  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,
integer  IORDER 
)

Definition at line 821 of file c_cblat2.f.

821 *
822 * Tests CHEMV, CHBMV and CHPMV.
823 *
824 * Auxiliary routine for test program for Level 2 Blas.
825 *
826 * -- Written on 10-August-1987.
827 * Richard Hanson, Sandia National Labs.
828 * Jeremy Du Croz, NAG Central Office.
829 *
830 * .. Parameters ..
831  COMPLEX zero, half
832  parameter ( zero = ( 0.0, 0.0 ), half = ( 0.5, 0.0 ) )
833  REAL rzero
834  parameter ( rzero = 0.0 )
835 * .. Scalar Arguments ..
836  REAL eps, thresh
837  INTEGER incmax, nalf, nbet, nidim, ninc, nkb, nmax,
838  $ nout, ntra, iorder
839  LOGICAL fatal, rewi, trace
840  CHARACTER*12 sname
841 * .. Array Arguments ..
842  COMPLEX a( nmax, nmax ), aa( nmax*nmax ), alf( nalf ),
843  $ as( nmax*nmax ), bet( nbet ), x( nmax ),
844  $ xs( nmax*incmax ), xx( nmax*incmax ),
845  $ y( nmax ), ys( nmax*incmax ), yt( nmax ),
846  $ yy( nmax*incmax )
847  REAL g( nmax )
848  INTEGER idim( nidim ), inc( ninc ), kb( nkb )
849 * .. Local Scalars ..
850  COMPLEX alpha, als, beta, bls, transl
851  REAL err, errmax
852  INTEGER i, ia, ib, ic, ik, in, incx, incxs, incy,
853  $ incys, ix, iy, k, ks, laa, lda, ldas, lx, ly,
854  $ n, nargs, nc, nk, ns
855  LOGICAL banded, full, null, packed, reset, same
856  CHARACTER*1 uplo, uplos
857  CHARACTER*14 cuplo
858  CHARACTER*2 ich
859 * .. Local Arrays ..
860  LOGICAL isame( 13 )
861 * .. External Functions ..
862  LOGICAL lce, lceres
863  EXTERNAL lce, lceres
864 * .. External Subroutines ..
865  EXTERNAL cchbmv, cchemv, cchpmv, cmake, cmvch
866 * .. Intrinsic Functions ..
867  INTRINSIC abs, max
868 * .. Scalars in Common ..
869  INTEGER infot, noutc
870  LOGICAL ok
871 * .. Common blocks ..
872  COMMON /infoc/infot, noutc, ok
873 * .. Data statements ..
874  DATA ich/'UL'/
875 * .. Executable Statements ..
876  full = sname( 9: 9 ).EQ.'e'
877  banded = sname( 9: 9 ).EQ.'b'
878  packed = sname( 9: 9 ).EQ.'p'
879 * Define the number of arguments.
880  IF( full )THEN
881  nargs = 10
882  ELSE IF( banded )THEN
883  nargs = 11
884  ELSE IF( packed )THEN
885  nargs = 9
886  END IF
887 *
888  nc = 0
889  reset = .true.
890  errmax = rzero
891 *
892  DO 110 in = 1, nidim
893  n = idim( in )
894 *
895  IF( banded )THEN
896  nk = nkb
897  ELSE
898  nk = 1
899  END IF
900  DO 100 ik = 1, nk
901  IF( banded )THEN
902  k = kb( ik )
903  ELSE
904  k = n - 1
905  END IF
906 * Set LDA to 1 more than minimum value if room.
907  IF( banded )THEN
908  lda = k + 1
909  ELSE
910  lda = n
911  END IF
912  IF( lda.LT.nmax )
913  $ lda = lda + 1
914 * Skip tests if not enough room.
915  IF( lda.GT.nmax )
916  $ GO TO 100
917  IF( packed )THEN
918  laa = ( n*( n + 1 ) )/2
919  ELSE
920  laa = lda*n
921  END IF
922  null = n.LE.0
923 *
924  DO 90 ic = 1, 2
925  uplo = ich( ic: ic )
926  IF (uplo.EQ.'U')THEN
927  cuplo = ' CblasUpper'
928  ELSE
929  cuplo = ' CblasLower'
930  END IF
931 *
932 * Generate the matrix A.
933 *
934  transl = zero
935  CALL cmake( sname( 8: 9 ), uplo, ' ', n, n, a, nmax, aa,
936  $ lda, k, k, reset, transl )
937 *
938  DO 80 ix = 1, ninc
939  incx = inc( ix )
940  lx = abs( incx )*n
941 *
942 * Generate the vector X.
943 *
944  transl = half
945  CALL cmake( 'ge', ' ', ' ', 1, n, x, 1, xx,
946  $ abs( incx ), 0, n - 1, reset, transl )
947  IF( n.GT.1 )THEN
948  x( n/2 ) = zero
949  xx( 1 + abs( incx )*( n/2 - 1 ) ) = zero
950  END IF
951 *
952  DO 70 iy = 1, ninc
953  incy = inc( iy )
954  ly = abs( incy )*n
955 *
956  DO 60 ia = 1, nalf
957  alpha = alf( ia )
958 *
959  DO 50 ib = 1, nbet
960  beta = bet( ib )
961 *
962 * Generate the vector Y.
963 *
964  transl = zero
965  CALL cmake( 'ge', ' ', ' ', 1, n, y, 1, yy,
966  $ abs( incy ), 0, n - 1, reset,
967  $ transl )
968 *
969  nc = nc + 1
970 *
971 * Save every datum before calling the
972 * subroutine.
973 *
974  uplos = uplo
975  ns = n
976  ks = k
977  als = alpha
978  DO 10 i = 1, laa
979  as( i ) = aa( i )
980  10 CONTINUE
981  ldas = lda
982  DO 20 i = 1, lx
983  xs( i ) = xx( i )
984  20 CONTINUE
985  incxs = incx
986  bls = beta
987  DO 30 i = 1, ly
988  ys( i ) = yy( i )
989  30 CONTINUE
990  incys = incy
991 *
992 * Call the subroutine.
993 *
994  IF( full )THEN
995  IF( trace )
996  $ WRITE( ntra, fmt = 9993 )nc, sname,
997  $ cuplo, n, alpha, lda, incx, beta, incy
998  IF( rewi )
999  $ rewind ntra
1000  CALL cchemv( iorder, uplo, n, alpha, aa,
1001  $ lda, xx, incx, beta, yy,
1002  $ incy )
1003  ELSE IF( banded )THEN
1004  IF( trace )
1005  $ WRITE( ntra, fmt = 9994 )nc, sname,
1006  $ cuplo, n, k, alpha, lda, incx, beta,
1007  $ incy
1008  IF( rewi )
1009  $ rewind ntra
1010  CALL cchbmv( iorder, uplo, n, k, alpha,
1011  $ aa, lda, xx, incx, beta,
1012  $ yy, incy )
1013  ELSE IF( packed )THEN
1014  IF( trace )
1015  $ WRITE( ntra, fmt = 9995 )nc, sname,
1016  $ cuplo, n, alpha, incx, beta, incy
1017  IF( rewi )
1018  $ rewind ntra
1019  CALL cchpmv( iorder, uplo, n, alpha, aa,
1020  $ xx, incx, beta, yy, incy )
1021  END IF
1022 *
1023 * Check if error-exit was taken incorrectly.
1024 *
1025  IF( .NOT.ok )THEN
1026  WRITE( nout, fmt = 9992 )
1027  fatal = .true.
1028  GO TO 120
1029  END IF
1030 *
1031 * See what data changed inside subroutines.
1032 *
1033  isame( 1 ) = uplo.EQ.uplos
1034  isame( 2 ) = ns.EQ.n
1035  IF( full )THEN
1036  isame( 3 ) = als.EQ.alpha
1037  isame( 4 ) = lce( as, aa, laa )
1038  isame( 5 ) = ldas.EQ.lda
1039  isame( 6 ) = lce( xs, xx, lx )
1040  isame( 7 ) = incxs.EQ.incx
1041  isame( 8 ) = bls.EQ.beta
1042  IF( null )THEN
1043  isame( 9 ) = lce( ys, yy, ly )
1044  ELSE
1045  isame( 9 ) = lceres( 'ge', ' ', 1, n,
1046  $ ys, yy, abs( incy ) )
1047  END IF
1048  isame( 10 ) = incys.EQ.incy
1049  ELSE IF( banded )THEN
1050  isame( 3 ) = ks.EQ.k
1051  isame( 4 ) = als.EQ.alpha
1052  isame( 5 ) = lce( as, aa, laa )
1053  isame( 6 ) = ldas.EQ.lda
1054  isame( 7 ) = lce( xs, xx, lx )
1055  isame( 8 ) = incxs.EQ.incx
1056  isame( 9 ) = bls.EQ.beta
1057  IF( null )THEN
1058  isame( 10 ) = lce( ys, yy, ly )
1059  ELSE
1060  isame( 10 ) = lceres( 'ge', ' ', 1, n,
1061  $ ys, yy, abs( incy ) )
1062  END IF
1063  isame( 11 ) = incys.EQ.incy
1064  ELSE IF( packed )THEN
1065  isame( 3 ) = als.EQ.alpha
1066  isame( 4 ) = lce( as, aa, laa )
1067  isame( 5 ) = lce( xs, xx, lx )
1068  isame( 6 ) = incxs.EQ.incx
1069  isame( 7 ) = bls.EQ.beta
1070  IF( null )THEN
1071  isame( 8 ) = lce( ys, yy, ly )
1072  ELSE
1073  isame( 8 ) = lceres( 'ge', ' ', 1, n,
1074  $ ys, yy, abs( incy ) )
1075  END IF
1076  isame( 9 ) = incys.EQ.incy
1077  END IF
1078 *
1079 * If data was incorrectly changed, report and
1080 * return.
1081 *
1082  same = .true.
1083  DO 40 i = 1, nargs
1084  same = same.AND.isame( i )
1085  IF( .NOT.isame( i ) )
1086  $ WRITE( nout, fmt = 9998 )i
1087  40 CONTINUE
1088  IF( .NOT.same )THEN
1089  fatal = .true.
1090  GO TO 120
1091  END IF
1092 *
1093  IF( .NOT.null )THEN
1094 *
1095 * Check the result.
1096 *
1097  CALL cmvch( 'N', n, n, alpha, a, nmax, x,
1098  $ incx, beta, y, incy, yt, g,
1099  $ yy, eps, err, fatal, nout,
1100  $ .true. )
1101  errmax = max( errmax, err )
1102 * If got really bad answer, report and
1103 * return.
1104  IF( fatal )
1105  $ GO TO 120
1106  ELSE
1107 * Avoid repeating tests with N.le.0
1108  GO TO 110
1109  END IF
1110 *
1111  50 CONTINUE
1112 *
1113  60 CONTINUE
1114 *
1115  70 CONTINUE
1116 *
1117  80 CONTINUE
1118 *
1119  90 CONTINUE
1120 *
1121  100 CONTINUE
1122 *
1123  110 CONTINUE
1124 *
1125 * Report result.
1126 *
1127  IF( errmax.LT.thresh )THEN
1128  WRITE( nout, fmt = 9999 )sname, nc
1129  ELSE
1130  WRITE( nout, fmt = 9997 )sname, nc, errmax
1131  END IF
1132  GO TO 130
1133 *
1134  120 CONTINUE
1135  WRITE( nout, fmt = 9996 )sname
1136  IF( full )THEN
1137  WRITE( nout, fmt = 9993 )nc, sname, cuplo, n, alpha, lda, incx,
1138  $ beta, incy
1139  ELSE IF( banded )THEN
1140  WRITE( nout, fmt = 9994 )nc, sname, cuplo, n, k, alpha, lda,
1141  $ incx, beta, incy
1142  ELSE IF( packed )THEN
1143  WRITE( nout, fmt = 9995 )nc, sname, cuplo, n, alpha, incx,
1144  $ beta, incy
1145  END IF
1146 *
1147  130 CONTINUE
1148  RETURN
1149 *
1150  9999 FORMAT(' ',a12, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
1151  $ 'S)' )
1152  9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1153  $ 'ANGED INCORRECTLY *******' )
1154  9997 FORMAT(' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
1155  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
1156  $ ' - SUSPECT *******' )
1157  9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
1158  9995 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', i3, ',(', f4.1, ',',
1159  $ f4.1, '), AP, X,',/ 10x, i2, ',(', f4.1, ',', f4.1,
1160  $ '), Y,', i2, ') .' )
1161  9994 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', 2( i3, ',' ), '(',
1162  $ f4.1, ',', f4.1, '), A,', i3, ', X,',/ 10x, i2, ',(',
1163  $ f4.1, ',', f4.1, '), Y,', i2, ') .' )
1164  9993 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', i3, ',(', f4.1, ',',
1165  $ f4.1, '), A,', i3, ', X,',/ 10x, i2, ',(', f4.1, ',',
1166  $ f4.1, '), ', 'Y,', i2, ') .' )
1167  9992 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1168  $ '******' )
1169 *
1170 * End of CCHK2.
1171 *
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
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: