LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ zchk2()

subroutine zchk2 ( character*12  SNAME,
double precision  EPS,
double precision  THRESH,
integer  NOUT,
integer  NTRA,
logical  TRACE,
logical  REWI,
logical  FATAL,
integer  NIDIM,
integer, dimension( nidim )  IDIM,
integer  NALF,
complex*16, dimension( nalf )  ALF,
integer  NBET,
complex*16, dimension( nbet )  BET,
integer  NMAX,
complex*16, dimension( nmax, nmax )  A,
complex*16, dimension( nmax*nmax )  AA,
complex*16, dimension( nmax*nmax )  AS,
complex*16, dimension( nmax, nmax )  B,
complex*16, dimension( nmax*nmax )  BB,
complex*16, dimension( nmax*nmax )  BS,
complex*16, dimension( nmax, nmax )  C,
complex*16, dimension( nmax*nmax )  CC,
complex*16, dimension( nmax*nmax )  CS,
complex*16, dimension( nmax )  CT,
double precision, dimension( nmax )  G,
integer  IORDER 
)

Definition at line 760 of file c_zblat3.f.

760 *
761 * Tests ZHEMM and ZSYMM.
762 *
763 * Auxiliary routine for test program for Level 3 Blas.
764 *
765 * -- Written on 8-February-1989.
766 * Jack Dongarra, Argonne National Laboratory.
767 * Iain Duff, AERE Harwell.
768 * Jeremy Du Croz, Numerical Algorithms Group Ltd.
769 * Sven Hammarling, Numerical Algorithms Group Ltd.
770 *
771 * .. Parameters ..
772  COMPLEX*16 ZERO
773  parameter( zero = ( 0.0d0, 0.0d0 ) )
774  DOUBLE PRECISION RZERO
775  parameter( rzero = 0.0d0 )
776 * .. Scalar Arguments ..
777  DOUBLE PRECISION EPS, THRESH
778  INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER
779  LOGICAL FATAL, REWI, TRACE
780  CHARACTER*12 SNAME
781 * .. Array Arguments ..
782  COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
783  $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
784  $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
785  $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
786  $ CS( NMAX*NMAX ), CT( NMAX )
787  DOUBLE PRECISION G( NMAX )
788  INTEGER IDIM( NIDIM )
789 * .. Local Scalars ..
790  COMPLEX*16 ALPHA, ALS, BETA, BLS
791  DOUBLE PRECISION ERR, ERRMAX
792  INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
793  $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
794  $ NARGS, NC, NS
795  LOGICAL CONJ, LEFT, NULL, RESET, SAME
796  CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
797  CHARACTER*2 ICHS, ICHU
798 * .. Local Arrays ..
799  LOGICAL ISAME( 13 )
800 * .. External Functions ..
801  LOGICAL LZE, LZERES
802  EXTERNAL lze, lzeres
803 * .. External Subroutines ..
804  EXTERNAL czhemm, zmake, zmmch, czsymm
805 * .. Intrinsic Functions ..
806  INTRINSIC max
807 * .. Scalars in Common ..
808  INTEGER INFOT, NOUTC
809  LOGICAL LERR, OK
810 * .. Common blocks ..
811  COMMON /infoc/infot, noutc, ok, lerr
812 * .. Data statements ..
813  DATA ichs/'LR'/, ichu/'UL'/
814 * .. Executable Statements ..
815  conj = sname( 8: 9 ).EQ.'he'
816 *
817  nargs = 12
818  nc = 0
819  reset = .true.
820  errmax = rzero
821 *
822  DO 100 im = 1, nidim
823  m = idim( im )
824 *
825  DO 90 in = 1, nidim
826  n = idim( in )
827 * Set LDC to 1 more than minimum value if room.
828  ldc = m
829  IF( ldc.LT.nmax )
830  $ ldc = ldc + 1
831 * Skip tests if not enough room.
832  IF( ldc.GT.nmax )
833  $ GO TO 90
834  lcc = ldc*n
835  null = n.LE.0.OR.m.LE.0
836 * Set LDB to 1 more than minimum value if room.
837  ldb = m
838  IF( ldb.LT.nmax )
839  $ ldb = ldb + 1
840 * Skip tests if not enough room.
841  IF( ldb.GT.nmax )
842  $ GO TO 90
843  lbb = ldb*n
844 *
845 * Generate the matrix B.
846 *
847  CALL zmake( 'ge', ' ', ' ', m, n, b, nmax, bb, ldb, reset,
848  $ zero )
849 *
850  DO 80 ics = 1, 2
851  side = ichs( ics: ics )
852  left = side.EQ.'L'
853 *
854  IF( left )THEN
855  na = m
856  ELSE
857  na = n
858  END IF
859 * Set LDA to 1 more than minimum value if room.
860  lda = na
861  IF( lda.LT.nmax )
862  $ lda = lda + 1
863 * Skip tests if not enough room.
864  IF( lda.GT.nmax )
865  $ GO TO 80
866  laa = lda*na
867 *
868  DO 70 icu = 1, 2
869  uplo = ichu( icu: icu )
870 *
871 * Generate the hermitian or symmetric matrix A.
872 *
873  CALL zmake(sname( 8: 9 ), uplo, ' ', na, na, a, nmax,
874  $ aa, lda, reset, zero )
875 *
876  DO 60 ia = 1, nalf
877  alpha = alf( ia )
878 *
879  DO 50 ib = 1, nbet
880  beta = bet( ib )
881 *
882 * Generate the matrix C.
883 *
884  CALL zmake( 'ge', ' ', ' ', m, n, c, nmax, cc,
885  $ ldc, reset, zero )
886 *
887  nc = nc + 1
888 *
889 * Save every datum before calling the
890 * subroutine.
891 *
892  sides = side
893  uplos = uplo
894  ms = m
895  ns = n
896  als = alpha
897  DO 10 i = 1, laa
898  as( i ) = aa( i )
899  10 CONTINUE
900  ldas = lda
901  DO 20 i = 1, lbb
902  bs( i ) = bb( i )
903  20 CONTINUE
904  ldbs = ldb
905  bls = beta
906  DO 30 i = 1, lcc
907  cs( i ) = cc( i )
908  30 CONTINUE
909  ldcs = ldc
910 *
911 * Call the subroutine.
912 *
913  IF( trace )
914  $ CALL zprcn2(ntra, nc, sname, iorder,
915  $ side, uplo, m, n, alpha, lda, ldb,
916  $ beta, ldc)
917  IF( rewi )
918  $ rewind ntra
919  IF( conj )THEN
920  CALL czhemm( iorder, side, uplo, m, n,
921  $ alpha, aa, lda, bb, ldb, beta,
922  $ cc, ldc )
923  ELSE
924  CALL czsymm( iorder, side, uplo, m, n,
925  $ alpha, aa, lda, bb, ldb, beta,
926  $ cc, ldc )
927  END IF
928 *
929 * Check if error-exit was taken incorrectly.
930 *
931  IF( .NOT.ok )THEN
932  WRITE( nout, fmt = 9994 )
933  fatal = .true.
934  GO TO 110
935  END IF
936 *
937 * See what data changed inside subroutines.
938 *
939  isame( 1 ) = sides.EQ.side
940  isame( 2 ) = uplos.EQ.uplo
941  isame( 3 ) = ms.EQ.m
942  isame( 4 ) = ns.EQ.n
943  isame( 5 ) = als.EQ.alpha
944  isame( 6 ) = lze( as, aa, laa )
945  isame( 7 ) = ldas.EQ.lda
946  isame( 8 ) = lze( bs, bb, lbb )
947  isame( 9 ) = ldbs.EQ.ldb
948  isame( 10 ) = bls.EQ.beta
949  IF( null )THEN
950  isame( 11 ) = lze( cs, cc, lcc )
951  ELSE
952  isame( 11 ) = lzeres( 'ge', ' ', m, n, cs,
953  $ cc, ldc )
954  END IF
955  isame( 12 ) = ldcs.EQ.ldc
956 *
957 * If data was incorrectly changed, report and
958 * return.
959 *
960  same = .true.
961  DO 40 i = 1, nargs
962  same = same.AND.isame( i )
963  IF( .NOT.isame( i ) )
964  $ WRITE( nout, fmt = 9998 )i
965  40 CONTINUE
966  IF( .NOT.same )THEN
967  fatal = .true.
968  GO TO 110
969  END IF
970 *
971  IF( .NOT.null )THEN
972 *
973 * Check the result.
974 *
975  IF( left )THEN
976  CALL zmmch( 'N', 'N', m, n, m, alpha, a,
977  $ nmax, b, nmax, beta, c, nmax,
978  $ ct, g, cc, ldc, eps, err,
979  $ fatal, nout, .true. )
980  ELSE
981  CALL zmmch( 'N', 'N', m, n, n, alpha, b,
982  $ nmax, a, nmax, beta, c, nmax,
983  $ ct, g, cc, ldc, eps, err,
984  $ fatal, nout, .true. )
985  END IF
986  errmax = max( errmax, err )
987 * If got really bad answer, report and
988 * return.
989  IF( fatal )
990  $ GO TO 110
991  END IF
992 *
993  50 CONTINUE
994 *
995  60 CONTINUE
996 *
997  70 CONTINUE
998 *
999  80 CONTINUE
1000 *
1001  90 CONTINUE
1002 *
1003  100 CONTINUE
1004 *
1005 * Report result.
1006 *
1007  IF( errmax.LT.thresh )THEN
1008  IF ( iorder.EQ.0) WRITE( nout, fmt = 10000 )sname, nc
1009  IF ( iorder.EQ.1) WRITE( nout, fmt = 10001 )sname, nc
1010  ELSE
1011  IF ( iorder.EQ.0) WRITE( nout, fmt = 10002 )sname, nc, errmax
1012  IF ( iorder.EQ.1) WRITE( nout, fmt = 10003 )sname, nc, errmax
1013  END IF
1014  GO TO 120
1015 *
1016  110 CONTINUE
1017  WRITE( nout, fmt = 9996 )sname
1018  CALL zprcn2(nout, nc, sname, iorder, side, uplo, m, n, alpha, lda,
1019  $ ldb, beta, ldc)
1020 *
1021  120 CONTINUE
1022  RETURN
1023 *
1024 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
1025  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1026  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1027 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
1028  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
1029  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
1030 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
1031  $ ' (', i6, ' CALL', 'S)' )
1032 10000 FORMAT( ' ', a12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS',
1033  $ ' (', i6, ' CALL', 'S)' )
1034  9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
1035  $ 'ANGED INCORRECTLY *******' )
1036  9996 FORMAT( ' ******* ', a12,' FAILED ON CALL NUMBER:' )
1037  9995 FORMAT(1x, i6, ': ', a12,'(', 2( '''', a1, ''',' ), 2( i3, ',' ),
1038  $ '(', f4.1, ',', f4.1, '), A,', i3, ', B,', i3, ',(', f4.1,
1039  $ ',', f4.1, '), C,', i3, ') .' )
1040  9994 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
1041  $ '******' )
1042 *
1043 * End of ZCHK2.
1044 *
Here is the call graph for this function:
zmake
subroutine zmake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: zblat2.f:2726
lzeres
logical function lzeres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: zblat2.f:3080
lze
logical function lze(RI, RJ, LR)
Definition: zblat2.f:3050
zprcn2
subroutine zprcn2(NOUT, NC, SNAME, IORDER, SIDE, UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC)
Definition: c_zblat3.f:1049
zmmch
subroutine zmmch(TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, NOUT, MV)
Definition: zblat3.f:3064