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

◆ 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 796 of file sblat2.f.

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