LAPACK  3.9.1
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 687 of file cblat3.f.

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