LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ dchk2()

subroutine dchk2 ( character*12  SNAME,
double precision  EPS,
double precision  THRESH,
integer  NOUT,
integer  NTRA,
logical  TRACE,
logical  REWI,
logical  FATAL,
integer  NIDIM,
integer, dimension( nidim )  IDIM,
integer  NALF,
double precision, dimension( nalf )  ALF,
integer  NBET,
double precision, dimension( nbet )  BET,
integer  NMAX,
double precision, dimension( nmax, nmax )  A,
double precision, dimension( nmax*nmax )  AA,
double precision, dimension( nmax*nmax )  AS,
double precision, dimension( nmax, nmax )  B,
double precision, dimension( nmax*nmax )  BB,
double precision, dimension( nmax*nmax )  BS,
double precision, dimension( nmax, nmax )  C,
double precision, dimension( nmax*nmax )  CC,
double precision, dimension( nmax*nmax )  CS,
double precision, dimension( nmax )  CT,
double precision, dimension( nmax )  G,
integer  IORDER 
)

Definition at line 744 of file c_dblat3.f.

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