LAPACK  3.9.1
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 689 of file zblat3.f.

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