LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ zchk2()

subroutine zchk2 ( character*6  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 
)

Definition at line 695 of file zblat3.f.

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