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  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 
)

Definition at line 673 of file sblat3.f.

676*
677* Tests SSYMM.
678*
679* Auxiliary routine for test program for Level 3 Blas.
680*
681* -- Written on 8-February-1989.
682* Jack Dongarra, Argonne National Laboratory.
683* Iain Duff, AERE Harwell.
684* Jeremy Du Croz, Numerical Algorithms Group Ltd.
685* Sven Hammarling, Numerical Algorithms Group Ltd.
686*
687* .. Parameters ..
688 REAL ZERO
689 parameter( zero = 0.0 )
690* .. Scalar Arguments ..
691 REAL EPS, THRESH
692 INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
693 LOGICAL FATAL, REWI, TRACE
694 CHARACTER*6 SNAME
695* .. Array Arguments ..
696 REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
697 $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
698 $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
699 $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
700 $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
701 INTEGER IDIM( NIDIM )
702* .. Local Scalars ..
703 REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX
704 INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
705 $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
706 $ NARGS, NC, NS
707 LOGICAL LEFT, NULL, RESET, SAME
708 CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
709 CHARACTER*2 ICHS, ICHU
710* .. Local Arrays ..
711 LOGICAL ISAME( 13 )
712* .. External Functions ..
713 LOGICAL LSE, LSERES
714 EXTERNAL lse, lseres
715* .. External Subroutines ..
716 EXTERNAL smake, smmch, ssymm
717* .. Intrinsic Functions ..
718 INTRINSIC max
719* .. Scalars in Common ..
720 INTEGER INFOT, NOUTC
721 LOGICAL LERR, OK
722* .. Common blocks ..
723 COMMON /infoc/infot, noutc, ok, lerr
724* .. Data statements ..
725 DATA ichs/'LR'/, ichu/'UL'/
726* .. Executable Statements ..
727*
728 nargs = 12
729 nc = 0
730 reset = .true.
731 errmax = zero
732*
733 DO 100 im = 1, nidim
734 m = idim( im )
735*
736 DO 90 in = 1, nidim
737 n = idim( in )
738* Set LDC to 1 more than minimum value if room.
739 ldc = m
740 IF( ldc.LT.nmax )
741 $ ldc = ldc + 1
742* Skip tests if not enough room.
743 IF( ldc.GT.nmax )
744 $ GO TO 90
745 lcc = ldc*n
746 null = n.LE.0.OR.m.LE.0
747*
748* Set LDB to 1 more than minimum value if room.
749 ldb = m
750 IF( ldb.LT.nmax )
751 $ ldb = ldb + 1
752* Skip tests if not enough room.
753 IF( ldb.GT.nmax )
754 $ GO TO 90
755 lbb = ldb*n
756*
757* Generate the matrix B.
758*
759 CALL smake( 'GE', ' ', ' ', m, n, b, nmax, bb, ldb, reset,
760 $ zero )
761*
762 DO 80 ics = 1, 2
763 side = ichs( ics: ics )
764 left = side.EQ.'L'
765*
766 IF( left )THEN
767 na = m
768 ELSE
769 na = n
770 END IF
771* Set LDA to 1 more than minimum value if room.
772 lda = na
773 IF( lda.LT.nmax )
774 $ lda = lda + 1
775* Skip tests if not enough room.
776 IF( lda.GT.nmax )
777 $ GO TO 80
778 laa = lda*na
779*
780 DO 70 icu = 1, 2
781 uplo = ichu( icu: icu )
782*
783* Generate the symmetric matrix A.
784*
785 CALL smake( 'SY', uplo, ' ', na, na, a, nmax, aa, lda,
786 $ reset, zero )
787*
788 DO 60 ia = 1, nalf
789 alpha = alf( ia )
790*
791 DO 50 ib = 1, nbet
792 beta = bet( ib )
793*
794* Generate the matrix C.
795*
796 CALL smake( 'GE', ' ', ' ', m, n, c, nmax, cc,
797 $ ldc, reset, zero )
798*
799 nc = nc + 1
800*
801* Save every datum before calling the
802* subroutine.
803*
804 sides = side
805 uplos = uplo
806 ms = m
807 ns = n
808 als = alpha
809 DO 10 i = 1, laa
810 as( i ) = aa( i )
811 10 CONTINUE
812 ldas = lda
813 DO 20 i = 1, lbb
814 bs( i ) = bb( i )
815 20 CONTINUE
816 ldbs = ldb
817 bls = beta
818 DO 30 i = 1, lcc
819 cs( i ) = cc( i )
820 30 CONTINUE
821 ldcs = ldc
822*
823* Call the subroutine.
824*
825 IF( trace )
826 $ WRITE( ntra, fmt = 9995 )nc, sname, side,
827 $ uplo, m, n, alpha, lda, ldb, beta, ldc
828 IF( rewi )
829 $ rewind ntra
830 CALL ssymm( side, uplo, m, n, alpha, aa, lda,
831 $ bb, ldb, beta, cc, ldc )
832*
833* Check if error-exit was taken incorrectly.
834*
835 IF( .NOT.ok )THEN
836 WRITE( nout, fmt = 9994 )
837 fatal = .true.
838 GO TO 110
839 END IF
840*
841* See what data changed inside subroutines.
842*
843 isame( 1 ) = sides.EQ.side
844 isame( 2 ) = uplos.EQ.uplo
845 isame( 3 ) = ms.EQ.m
846 isame( 4 ) = ns.EQ.n
847 isame( 5 ) = als.EQ.alpha
848 isame( 6 ) = lse( as, aa, laa )
849 isame( 7 ) = ldas.EQ.lda
850 isame( 8 ) = lse( bs, bb, lbb )
851 isame( 9 ) = ldbs.EQ.ldb
852 isame( 10 ) = bls.EQ.beta
853 IF( null )THEN
854 isame( 11 ) = lse( cs, cc, lcc )
855 ELSE
856 isame( 11 ) = lseres( 'GE', ' ', m, n, cs,
857 $ cc, ldc )
858 END IF
859 isame( 12 ) = ldcs.EQ.ldc
860*
861* If data was incorrectly changed, report and
862* return.
863*
864 same = .true.
865 DO 40 i = 1, nargs
866 same = same.AND.isame( i )
867 IF( .NOT.isame( i ) )
868 $ WRITE( nout, fmt = 9998 )i
869 40 CONTINUE
870 IF( .NOT.same )THEN
871 fatal = .true.
872 GO TO 110
873 END IF
874*
875 IF( .NOT.null )THEN
876*
877* Check the result.
878*
879 IF( left )THEN
880 CALL smmch( 'N', 'N', m, n, m, alpha, a,
881 $ nmax, b, nmax, beta, c, nmax,
882 $ ct, g, cc, ldc, eps, err,
883 $ fatal, nout, .true. )
884 ELSE
885 CALL smmch( 'N', 'N', m, n, n, alpha, b,
886 $ nmax, a, nmax, beta, c, nmax,
887 $ ct, g, cc, ldc, eps, err,
888 $ fatal, nout, .true. )
889 END IF
890 errmax = max( errmax, err )
891* If got really bad answer, report and
892* return.
893 IF( fatal )
894 $ GO TO 110
895 END IF
896*
897 50 CONTINUE
898*
899 60 CONTINUE
900*
901 70 CONTINUE
902*
903 80 CONTINUE
904*
905 90 CONTINUE
906*
907 100 CONTINUE
908*
909* Report result.
910*
911 IF( errmax.LT.thresh )THEN
912 WRITE( nout, fmt = 9999 )sname, nc
913 ELSE
914 WRITE( nout, fmt = 9997 )sname, nc, errmax
915 END IF
916 GO TO 120
917*
918 110 CONTINUE
919 WRITE( nout, fmt = 9996 )sname
920 WRITE( nout, fmt = 9995 )nc, sname, side, uplo, m, n, alpha, lda,
921 $ ldb, beta, ldc
922*
923 120 CONTINUE
924 RETURN
925*
926 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
927 $ 'S)' )
928 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
929 $ 'ANGED INCORRECTLY *******' )
930 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
931 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
932 $ ' - SUSPECT *******' )
933 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
934 9995 FORMAT( 1x, i6, ': ', a6, '(', 2( '''', a1, ''',' ), 2( i3, ',' ),
935 $ f4.1, ', A,', i3, ', B,', i3, ',', f4.1, ', C,', i3, ') ',
936 $ ' .' )
937 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
938 $ '******' )
939*
940* End of SCHK2
941*
ssymm
subroutine ssymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
SSYMM
Definition ssymm.f:189
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: