LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 442 of file zblat2.f.

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

Here is the call graph for this function:

Here is the caller graph for this function: