LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ cchk2()

subroutine cchk2 ( 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,
complex, dimension( nalf )  ALF,
integer  NBET,
complex, dimension( nbet )  BET,
integer  NMAX,
complex, dimension( nmax, nmax )  A,
complex, dimension( nmax*nmax )  AA,
complex, dimension( nmax*nmax )  AS,
complex, dimension( nmax, nmax )  B,
complex, dimension( nmax*nmax )  BB,
complex, dimension( nmax*nmax )  BS,
complex, dimension( nmax, nmax )  C,
complex, dimension( nmax*nmax )  CC,
complex, dimension( nmax*nmax )  CS,
complex, dimension( nmax )  CT,
real, dimension( nmax )  G,
integer  IORDER 
)

Definition at line 759 of file c_cblat3.f.

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