LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ dchk1()

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

Definition at line 434 of file dblat2.f.

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