LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ zchk1()

subroutine zchk1 ( 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  NKB,
integer, dimension( nkb )  KB,
integer  NALF,
complex*16, dimension( nalf )  ALF,
integer  NBET,
complex*16, dimension( nbet )  BET,
integer  NINC,
integer, dimension( ninc )  INC,
integer  NMAX,
integer  INCMAX,
complex*16, dimension( nmax, nmax )  A,
complex*16, dimension( nmax*nmax )  AA,
complex*16, dimension( nmax*nmax )  AS,
complex*16, dimension( nmax )  X,
complex*16, dimension( nmax*incmax )  XX,
complex*16, dimension( nmax*incmax )  XS,
complex*16, dimension( nmax )  Y,
complex*16, dimension( nmax*incmax )  YY,
complex*16, dimension( nmax*incmax )  YS,
complex*16, dimension( nmax )  YT,
double precision, dimension( nmax )  G,
integer  IORDER 
)

Definition at line 466 of file c_zblat2.f.

466 *
467 * Tests CGEMV and CGBMV.
468 *
469 * Auxiliary routine for test program for Level 2 Blas.
470 *
471 * -- Written on 10-August-1987.
472 * Richard Hanson, Sandia National Labs.
473 * Jeremy Du Croz, NAG Central Office.
474 *
475 * .. Parameters ..
476  COMPLEX*16 ZERO, HALF
477  parameter( zero = ( 0.0d0, 0.0d0 ),
478  $ half = ( 0.5d0, 0.0d0 ) )
479  DOUBLE PRECISION RZERO
480  parameter( rzero = 0.0d0 )
481 * .. Scalar Arguments ..
482  DOUBLE PRECISION EPS, THRESH
483  INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
484  $ NOUT, NTRA, IORDER
485  LOGICAL FATAL, REWI, TRACE
486  CHARACTER*12 SNAME
487 * .. Array Arguments ..
488  COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
489  $ AS( NMAX*NMAX ), BET( NBET ), X( NMAX ),
490  $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
491  $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
492  $ YY( NMAX*INCMAX )
493  DOUBLE PRECISION G( NMAX )
494  INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
495 * .. Local Scalars ..
496  COMPLEX*16 ALPHA, ALS, BETA, BLS, TRANSL
497  DOUBLE PRECISION ERR, ERRMAX
498  INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
499  $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA,
500  $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK,
501  $ NL, NS
502  LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN
503  CHARACTER*1 TRANS, TRANSS
504  CHARACTER*14 CTRANS
505  CHARACTER*3 ICH
506 * .. Local Arrays ..
507  LOGICAL ISAME( 13 )
508 * .. External Functions ..
509  LOGICAL LZE, LZERES
510  EXTERNAL lze, lzeres
511 * .. External Subroutines ..
512  EXTERNAL czgbmv, czgemv, zmake, zmvch
513 * .. Intrinsic Functions ..
514  INTRINSIC abs, max, min
515 * .. Scalars in Common ..
516  INTEGER INFOT, NOUTC
517  LOGICAL OK
518 * .. Common blocks ..
519  COMMON /infoc/infot, noutc, ok
520 * .. Data statements ..
521  DATA ich/'NTC'/
522 * .. Executable Statements ..
523  full = sname( 9: 9 ).EQ.'e'
524  banded = sname( 9: 9 ).EQ.'b'
525 * Define the number of arguments.
526  IF( full )THEN
527  nargs = 11
528  ELSE IF( banded )THEN
529  nargs = 13
530  END IF
531 *
532  nc = 0
533  reset = .true.
534  errmax = rzero
535 *
536  DO 120 in = 1, nidim
537  n = idim( in )
538  nd = n/2 + 1
539 *
540  DO 110 im = 1, 2
541  IF( im.EQ.1 )
542  $ m = max( n - nd, 0 )
543  IF( im.EQ.2 )
544  $ m = min( n + nd, nmax )
545 *
546  IF( banded )THEN
547  nk = nkb
548  ELSE
549  nk = 1
550  END IF
551  DO 100 iku = 1, nk
552  IF( banded )THEN
553  ku = kb( iku )
554  kl = max( ku - 1, 0 )
555  ELSE
556  ku = n - 1
557  kl = m - 1
558  END IF
559 * Set LDA to 1 more than minimum value if room.
560  IF( banded )THEN
561  lda = kl + ku + 1
562  ELSE
563  lda = m
564  END IF
565  IF( lda.LT.nmax )
566  $ lda = lda + 1
567 * Skip tests if not enough room.
568  IF( lda.GT.nmax )
569  $ GO TO 100
570  laa = lda*n
571  null = n.LE.0.OR.m.LE.0
572 *
573 * Generate the matrix A.
574 *
575  transl = zero
576  CALL zmake( sname( 8: 9 ), ' ', ' ', m, n, a, nmax, aa,
577  $ lda, kl, ku, reset, transl )
578 *
579  DO 90 ic = 1, 3
580  trans = ich( ic: ic )
581  IF (trans.EQ.'N')THEN
582  ctrans = ' CblasNoTrans'
583  ELSE IF (trans.EQ.'T')THEN
584  ctrans = ' CblasTrans'
585  ELSE
586  ctrans = 'CblasConjTrans'
587  END IF
588  tran = trans.EQ.'T'.OR.trans.EQ.'C'
589 *
590  IF( tran )THEN
591  ml = n
592  nl = m
593  ELSE
594  ml = m
595  nl = n
596  END IF
597 *
598  DO 80 ix = 1, ninc
599  incx = inc( ix )
600  lx = abs( incx )*nl
601 *
602 * Generate the vector X.
603 *
604  transl = half
605  CALL zmake( 'ge', ' ', ' ', 1, nl, x, 1, xx,
606  $ abs( incx ), 0, nl - 1, reset, transl )
607  IF( nl.GT.1 )THEN
608  x( nl/2 ) = zero
609  xx( 1 + abs( incx )*( nl/2 - 1 ) ) = zero
610  END IF
611 *
612  DO 70 iy = 1, ninc
613  incy = inc( iy )
614  ly = abs( incy )*ml
615 *
616  DO 60 ia = 1, nalf
617  alpha = alf( ia )
618 *
619  DO 50 ib = 1, nbet
620  beta = bet( ib )
621 *
622 * Generate the vector Y.
623 *
624  transl = zero
625  CALL zmake( 'ge', ' ', ' ', 1, ml, y, 1,
626  $ yy, abs( incy ), 0, ml - 1,
627  $ reset, transl )
628 *
629  nc = nc + 1
630 *
631 * Save every datum before calling the
632 * subroutine.
633 *
634  transs = trans
635  ms = m
636  ns = n
637  kls = kl
638  kus = ku
639  als = alpha
640  DO 10 i = 1, laa
641  as( i ) = aa( i )
642  10 CONTINUE
643  ldas = lda
644  DO 20 i = 1, lx
645  xs( i ) = xx( i )
646  20 CONTINUE
647  incxs = incx
648  bls = beta
649  DO 30 i = 1, ly
650  ys( i ) = yy( i )
651  30 CONTINUE
652  incys = incy
653 *
654 * Call the subroutine.
655 *
656  IF( full )THEN
657  IF( trace )
658  $ WRITE( ntra, fmt = 9994 )nc, sname,
659  $ ctrans, m, n, alpha, lda, incx, beta,
660  $ incy
661  IF( rewi )
662  $ rewind ntra
663  CALL czgemv( iorder, trans, m, n,
664  $ alpha, aa, lda, xx, incx,
665  $ beta, yy, incy )
666  ELSE IF( banded )THEN
667  IF( trace )
668  $ WRITE( ntra, fmt = 9995 )nc, sname,
669  $ ctrans, m, n, kl, ku, alpha, lda,
670  $ incx, beta, incy
671  IF( rewi )
672  $ rewind ntra
673  CALL czgbmv( iorder, trans, m, n, kl,
674  $ ku, alpha, aa, lda, xx,
675  $ incx, beta, yy, incy )
676  END IF
677 *
678 * Check if error-exit was taken incorrectly.
679 *
680  IF( .NOT.ok )THEN
681  WRITE( nout, fmt = 9993 )
682  fatal = .true.
683  GO TO 130
684  END IF
685 *
686 * See what data changed inside subroutines.
687 *
688 * IF(TRANS .NE. 'C' .OR. (INCX .GT. 0 .AND. INCY .GT. 0)) THEN
689  isame( 1 ) = trans.EQ.transs
690  isame( 2 ) = ms.EQ.m
691  isame( 3 ) = ns.EQ.n
692  IF( full )THEN
693  isame( 4 ) = als.EQ.alpha
694  isame( 5 ) = lze( as, aa, laa )
695  isame( 6 ) = ldas.EQ.lda
696  isame( 7 ) = lze( xs, xx, lx )
697  isame( 8 ) = incxs.EQ.incx
698  isame( 9 ) = bls.EQ.beta
699  IF( null )THEN
700  isame( 10 ) = lze( ys, yy, ly )
701  ELSE
702  isame( 10 ) = lzeres( 'ge', ' ', 1,
703  $ ml, ys, yy,
704  $ abs( incy ) )
705  END IF
706  isame( 11 ) = incys.EQ.incy
707  ELSE IF( banded )THEN
708  isame( 4 ) = kls.EQ.kl
709  isame( 5 ) = kus.EQ.ku
710  isame( 6 ) = als.EQ.alpha
711  isame( 7 ) = lze( as, aa, laa )
712  isame( 8 ) = ldas.EQ.lda
713  isame( 9 ) = lze( xs, xx, lx )
714  isame( 10 ) = incxs.EQ.incx
715  isame( 11 ) = bls.EQ.beta
716  IF( null )THEN
717  isame( 12 ) = lze( ys, yy, ly )
718  ELSE
719  isame( 12 ) = lzeres( 'ge', ' ', 1,
720  $ ml, ys, yy,
721  $ abs( incy ) )
722  END IF
723  isame( 13 ) = incys.EQ.incy
724  END IF
725 *
726 * If data was incorrectly changed, report
727 * and return.
728 *
729  same = .true.
730  DO 40 i = 1, nargs
731  same = same.AND.isame( i )
732  IF( .NOT.isame( i ) )
733  $ WRITE( nout, fmt = 9998 )i
734  40 CONTINUE
735  IF( .NOT.same )THEN
736  fatal = .true.
737  GO TO 130
738  END IF
739 *
740  IF( .NOT.null )THEN
741 *
742 * Check the result.
743 *
744  CALL zmvch( trans, m, n, alpha, a,
745  $ nmax, x, incx, beta, y,
746  $ incy, yt, g, yy, eps, err,
747  $ fatal, nout, .true. )
748  errmax = max( errmax, err )
749 * If got really bad answer, report and
750 * return.
751  IF( fatal )
752  $ GO TO 130
753  ELSE
754 * Avoid repeating tests with M.le.0 or
755 * N.le.0.
756  GO TO 110
757  END IF
758 * END IF
759 *
760  50 CONTINUE
761 *
762  60 CONTINUE
763 *
764  70 CONTINUE
765 *
766  80 CONTINUE
767 *
768  90 CONTINUE
769 *
770  100 CONTINUE
771 *
772  110 CONTINUE
773 *
774  120 CONTINUE
775 *
776 * Report result.
777 *
778  IF( errmax.LT.thresh )THEN
779  WRITE( nout, fmt = 9999 )sname, nc
780  ELSE
781  WRITE( nout, fmt = 9997 )sname, nc, errmax
782  END IF
783  GO TO 140
784 *
785  130 CONTINUE
786  WRITE( nout, fmt = 9996 )sname
787  IF( full )THEN
788  WRITE( nout, fmt = 9994 )nc, sname, ctrans, m, n, alpha, lda,
789  $ incx, beta, incy
790  ELSE IF( banded )THEN
791  WRITE( nout, fmt = 9995 )nc, sname, ctrans, m, n, kl, ku,
792  $ alpha, lda, incx, beta, incy
793  END IF
794 *
795  140 CONTINUE
796  RETURN
797 *
798  9999 FORMAT(' ',a12, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
799  $ 'S)' )
800  9998 FORMAT(' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
801  $ 'ANGED INCORRECTLY *******' )
802  9997 FORMAT(' ',a12, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
803  $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
804  $ ' - SUSPECT *******' )
805  9996 FORMAT( ' ******* ',a12, ' FAILED ON CALL NUMBER:' )
806  9995 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', 4( i3, ',' ), '(',
807  $ f4.1, ',', f4.1, '), A,',/ 10x, i3, ', X,', i2, ',(',
808  $ f4.1, ',', f4.1, '), Y,', i2, ') .' )
809  9994 FORMAT( 1x, i6, ': ',a12, '(', a14, ',', 2( i3, ',' ), '(',
810  $ f4.1, ',', f4.1, '), A,',/ 10x, i3, ', X,', i2, ',(',
811  $ f4.1, ',', f4.1, '), Y,', i2, ') .' )
812  9993 FORMAT(' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
813  $ '******' )
814 *
815 * End of ZCHK1.
816 *
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
zmvch
subroutine zmvch(TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV)
Definition: zblat2.f:2919
lze
logical function lze(RI, RJ, LR)
Definition: zblat2.f:3050