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

◆ 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 809 of file zblat2.f.

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