LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ zchk2()

subroutine zchk2 ( character*12  SNAME,
double precision  EPS,
double precision  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*16, dimension( nalf )  ALF,
integer  NBET,
complex*16, dimension( nbet )  BET,
integer  NINC,
integer, dimension( ninc )  INC,
integer  NMAX,
integer  INCMAX,
complex*16, dimension( nmax, nmax )  A,
complex*16, dimension( nmax*nmax )  AA,
complex*16, dimension( nmax*nmax )  AS,
complex*16, dimension( nmax )  X,
complex*16, dimension( nmax*incmax )  XX,
complex*16, dimension( nmax*incmax )  XS,
complex*16, dimension( nmax )  Y,
complex*16, dimension( nmax*incmax )  YY,
complex*16, dimension( nmax*incmax )  YS,
complex*16, dimension( nmax )  YT,
double precision, dimension( nmax )  G,
integer  IORDER 
)

Definition at line 822 of file c_zblat2.f.

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