LAPACK  3.9.1
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 768 of file sblat2.f.

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