LAPACK  3.10.0
LAPACK: Linear Algebra PACKage

◆ zchk1()

subroutine zchk1 ( 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  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 
)

Definition at line 435 of file zblat2.f.

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