LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ 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:2744
lceres
logical function lceres(type, uplo, m, n, aa, as, lda)
Definition cblat2.f:3097
lce
logical function lce(ri, rj, lr)
Definition cblat2.f:3067
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
chemm
subroutine chemm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
CHEMM
Definition chemm.f:191
csymm
subroutine csymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
CSYMM
Definition csymm.f:189
Here is the call graph for this function: