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

◆ 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 818 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*
lze
logical function lze(ri, rj, lr)
Definition zblat2.f:3075
lzeres
logical function lzeres(type, uplo, m, n, aa, as, lda)
Definition zblat2.f:3105
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:2944
zmake
subroutine zmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition zblat2.f:2751
Here is the call graph for this function: