LAPACK  3.10.1
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 427 of file dblat2.f.

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