LAPACK  3.10.1
LAPACK: Linear Algebra PACKage

◆ cchk2()

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 779 of file cblat2.f.

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