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

◆ 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 755 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*
102310003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1024 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1025 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
102610002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1027 $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1028 $ 'RATIO ', f8.2, ' - SUSPECT *******' )
102910001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1030 $ ' (', i6, ' CALL', 'S)' )
103110000 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*
cprcn2
subroutine cprcn2(nout, nc, sname, iorder, side, uplo, m, n, alpha, lda, ldb, beta, ldc)
Definition c_cblat3.f:1048
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
Here is the call graph for this function: