LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

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

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