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

◆ cchk2()

subroutine cchk2 ( character*7 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 694 of file cblat3.f.

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