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

◆ schk2()

subroutine schk2 ( character*13 sname,
real eps,
real thresh,
integer nout,
integer ntra,
logical trace,
logical rewi,
logical fatal,
integer nidim,
integer, dimension( nidim ) idim,
integer nalf,
real, dimension( nalf ) alf,
integer nbet,
real, dimension( nbet ) bet,
integer nmax,
real, dimension( nmax, nmax ) a,
real, dimension( nmax*nmax ) aa,
real, dimension( nmax*nmax ) as,
real, dimension( nmax, nmax ) b,
real, dimension( nmax*nmax ) bb,
real, dimension( nmax*nmax ) bs,
real, dimension( nmax, nmax ) c,
real, dimension( nmax*nmax ) cc,
real, dimension( nmax*nmax ) cs,
real, dimension( nmax ) ct,
real, dimension( nmax ) g,
integer iorder )

Definition at line 762 of file c_sblat3.f.

766*
767* Tests SSYMM.
768*
769* Auxiliary routine for test program for Level 3 Blas.
770*
771* -- Written on 8-February-1989.
772* Jack Dongarra, Argonne National Laboratory.
773* Iain Duff, AERE Harwell.
774* Jeremy Du Croz, Numerical Algorithms Group Ltd.
775* Sven Hammarling, Numerical Algorithms Group Ltd.
776*
777* .. Parameters ..
778 REAL ZERO
779 parameter( zero = 0.0 )
780* .. Scalar Arguments ..
781 REAL EPS, THRESH
782 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
783 LOGICAL FATAL, REWI, TRACE
784 CHARACTER*13 SNAME
785* .. Array Arguments ..
786 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
787 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
788 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
789 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
790 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
791 INTEGER IDIM( NIDIM )
792* .. Local Scalars ..
793 REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX
794 INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
795 $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
796 $ NARGS, NC, NS
797 LOGICAL LEFT, NULL, RESET, SAME
798 CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
799 CHARACTER*2 ICHS, ICHU
800* .. Local Arrays ..
801 LOGICAL ISAME( 13 )
802* .. External Functions ..
803 LOGICAL LSE, LSERES
804 EXTERNAL lse, lseres
805* .. External Subroutines ..
806 EXTERNAL smake, smmch, cssymm
807* .. Intrinsic Functions ..
808 INTRINSIC max
809* .. Scalars in Common ..
810 INTEGER INFOT, NOUTC
811 LOGICAL OK
812* .. Common blocks ..
813 COMMON /infoc/infot, noutc, ok
814* .. Data statements ..
815 DATA ichs/'LR'/, ichu/'UL'/
816* .. Executable Statements ..
817*
818 nargs = 12
819 nc = 0
820 reset = .true.
821 errmax = zero
822*
823 DO 100 im = 1, nidim
824 m = idim( im )
825*
826 DO 90 in = 1, nidim
827 n = idim( in )
828* Set LDC to 1 more than minimum value if room.
829 ldc = m
830 IF( ldc.LT.nmax )
831 $ ldc = ldc + 1
832* Skip tests if not enough room.
833 IF( ldc.GT.nmax )
834 $ GO TO 90
835 lcc = ldc*n
836 null = n.LE.0.OR.m.LE.0
837*
838* Set LDB to 1 more than minimum value if room.
839 ldb = m
840 IF( ldb.LT.nmax )
841 $ ldb = ldb + 1
842* Skip tests if not enough room.
843 IF( ldb.GT.nmax )
844 $ GO TO 90
845 lbb = ldb*n
846*
847* Generate the matrix B.
848*
849 CALL smake( 'GE', ' ', ' ', m, n, b, nmax, bb, ldb, reset,
850 $ zero )
851*
852 DO 80 ics = 1, 2
853 side = ichs( ics: ics )
854 left = side.EQ.'L'
855*
856 IF( left )THEN
857 na = m
858 ELSE
859 na = n
860 END IF
861* Set LDA to 1 more than minimum value if room.
862 lda = na
863 IF( lda.LT.nmax )
864 $ lda = lda + 1
865* Skip tests if not enough room.
866 IF( lda.GT.nmax )
867 $ GO TO 80
868 laa = lda*na
869*
870 DO 70 icu = 1, 2
871 uplo = ichu( icu: icu )
872*
873* Generate the symmetric matrix A.
874*
875 CALL smake( 'SY', uplo, ' ', na, na, a, nmax, aa, lda,
876 $ reset, zero )
877*
878 DO 60 ia = 1, nalf
879 alpha = alf( ia )
880*
881 DO 50 ib = 1, nbet
882 beta = bet( ib )
883*
884* Generate the matrix C.
885*
886 CALL smake( 'GE', ' ', ' ', m, n, c, nmax, cc,
887 $ ldc, reset, zero )
888*
889 nc = nc + 1
890*
891* Save every datum before calling the
892* subroutine.
893*
894 sides = side
895 uplos = uplo
896 ms = m
897 ns = n
898 als = alpha
899 DO 10 i = 1, laa
900 as( i ) = aa( i )
901 10 CONTINUE
902 ldas = lda
903 DO 20 i = 1, lbb
904 bs( i ) = bb( i )
905 20 CONTINUE
906 ldbs = ldb
907 bls = beta
908 DO 30 i = 1, lcc
909 cs( i ) = cc( i )
910 30 CONTINUE
911 ldcs = ldc
912*
913* Call the subroutine.
914*
915 IF( trace )
916 $ CALL sprcn2(ntra, nc, sname, iorder,
917 $ side, uplo, m, n, alpha, lda, ldb,
918 $ beta, ldc)
919 IF( rewi )
920 $ rewind ntra
921 CALL cssymm( iorder, side, uplo, m, n, alpha,
922 $ aa, lda, bb, ldb, beta, cc, ldc )
923*
924* Check if error-exit was taken incorrectly.
925*
926 IF( .NOT.ok )THEN
927 WRITE( nout, fmt = 9994 )
928 fatal = .true.
929 GO TO 110
930 END IF
931*
932* See what data changed inside subroutines.
933*
934 isame( 1 ) = sides.EQ.side
935 isame( 2 ) = uplos.EQ.uplo
936 isame( 3 ) = ms.EQ.m
937 isame( 4 ) = ns.EQ.n
938 isame( 5 ) = als.EQ.alpha
939 isame( 6 ) = lse( as, aa, laa )
940 isame( 7 ) = ldas.EQ.lda
941 isame( 8 ) = lse( bs, bb, lbb )
942 isame( 9 ) = ldbs.EQ.ldb
943 isame( 10 ) = bls.EQ.beta
944 IF( null )THEN
945 isame( 11 ) = lse( cs, cc, lcc )
946 ELSE
947 isame( 11 ) = lseres( 'GE', ' ', m, n, cs,
948 $ cc, ldc )
949 END IF
950 isame( 12 ) = ldcs.EQ.ldc
951*
952* If data was incorrectly changed, report and
953* return.
954*
955 same = .true.
956 DO 40 i = 1, nargs
957 same = same.AND.isame( i )
958 IF( .NOT.isame( i ) )
959 $ WRITE( nout, fmt = 9998 )i+1
960 40 CONTINUE
961 IF( .NOT.same )THEN
962 fatal = .true.
963 GO TO 110
964 END IF
965*
966 IF( .NOT.null )THEN
967*
968* Check the result.
969*
970 IF( left )THEN
971 CALL smmch( 'N', 'N', m, n, m, alpha, a,
972 $ nmax, b, nmax, beta, c, nmax,
973 $ ct, g, cc, ldc, eps, err,
974 $ fatal, nout, .true. )
975 ELSE
976 CALL smmch( 'N', 'N', m, n, n, alpha, b,
977 $ nmax, a, nmax, beta, c, nmax,
978 $ ct, g, cc, ldc, eps, err,
979 $ fatal, nout, .true. )
980 END IF
981 errmax = max( errmax, err )
982* If got really bad answer, report and
983* return.
984 IF( fatal )
985 $ GO TO 110
986 END IF
987*
988 50 CONTINUE
989*
990 60 CONTINUE
991*
992 70 CONTINUE
993*
994 80 CONTINUE
995*
996 90 CONTINUE
997*
998 100 CONTINUE
999*
1000* Report result.
1001*
1002 IF( errmax.LT.thresh )THEN
1003 IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
1004 IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
1005 ELSE
1006 IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
1007 IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
1008 END IF
1009 GO TO 120
1010*
1011 110 CONTINUE
1012 WRITE( nout, fmt = 9996 )sname
1013 CALL sprcn2(nout, nc, sname, iorder, side, uplo, m, n, alpha, lda,
1014 $ ldb, beta, ldc)
1015*
1016 120 CONTINUE
1017 RETURN
1018*
101910003 FORMAT( ' ', a13,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1020 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1021 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
102210002 FORMAT( ' ', a13,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1023 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1024 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
102510001 FORMAT( ' ', a13,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1026 $ ' (', i6, ' CALL', 'S)' )
102710000 FORMAT( ' ', a13,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1028 $ ' (', i6, ' CALL', 'S)' )
1029 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1030 $ 'ANGED INCORRECTLY *******' )
1031 9996 FORMAT( ' ******* ', a13,' FAILED ON CALL NUMBER:' )
1032 9995 FORMAT( 1x, i6, ': ', a13,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1033 $ f4.1, ', A,', i3, ', B,', i3, ',', f4.1, ', C,', i3, ') ',
1034 $ ' .' )
1035 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1036 $ '******' )
1037*
1038* End of SCHK2.
1039*
sprcn2
subroutine sprcn2(nout, nc, sname, iorder, side, uplo, m, n, alpha, lda, ldb, beta, ldc)
Definition c_sblat3.f:1044
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
smmch
subroutine smmch(transa, transb, m, n, kk, alpha, a, lda, b, ldb, beta, c, ldc, ct, g, cc, ldcc, eps, err, fatal, nout, mv)
Definition sblat3.f:2594
Here is the call graph for this function: