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

◆ 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  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 744 of file c_sblat3.f.

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