LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ 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 820 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 *
1147 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1148  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1149  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1150 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1151  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1152  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1153 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1154  $ ' (', i6, ' CALL', 'S)' )
1155 10000 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 *
Here is the call graph for this function:
smake
subroutine smake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: sblat2.f:2653
lse
logical function lse(RI, RJ, LR)
Definition: sblat2.f:2945
lseres
logical function lseres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: sblat2.f:2975
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:2829