LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 748 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 *
1001 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1002  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1003  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1004 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1005  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1006  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1007 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1008  $ ' (', i6, ' CALL', 'S)' )
1009 10000 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 *
smake
subroutine smake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: sblat2.f:2653
sprcn2
subroutine sprcn2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC)
Definition: c_sblat3.f:1026
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

Here is the call graph for this function: