LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 679 of file sblat3.f.

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

Here is the call graph for this function: