LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ zchk2()

subroutine zchk2 ( character*6  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 
)

Definition at line 788 of file zblat2.f.

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