LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ cchk2()

subroutine cchk2 ( 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,
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 
)

Definition at line 693 of file cblat3.f.

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