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

◆ schk2()

subroutine schk2 ( 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,
real, dimension( nalf )  alf,
integer  nbet,
real, dimension( nbet )  bet,
integer  ninc,
integer, dimension( ninc )  inc,
integer  nmax,
integer  incmax,
real, dimension( nmax, nmax )  a,
real, dimension( nmax*nmax )  aa,
real, dimension( nmax*nmax )  as,
real, dimension( nmax )  x,
real, dimension( nmax*incmax )  xx,
real, dimension( nmax*incmax )  xs,
real, dimension( nmax )  y,
real, dimension( nmax*incmax )  yy,
real, dimension( nmax*incmax )  ys,
real, dimension( nmax )  yt,
real, dimension( nmax )  g,
integer  iorder 
)

Definition at line 816 of file c_sblat2.f.

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