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

◆ cchk2()

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 817 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*
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
Here is the call graph for this function: