LAPACK  3.10.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  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
lse
logical function lse(RI, RJ, LR)
Definition: sblat2.f:2942
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
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: