LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ schk2()

subroutine schk2 ( character*6  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 
)

Definition at line 775 of file sblat2.f.

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