LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ cchk1()

subroutine cchk1 ( character*6  SNAME,
real  EPS,
real  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, dimension( nalf )  ALF,
integer  NBET,
complex, dimension( nbet )  BET,
integer  NINC,
integer, dimension( ninc )  INC,
integer  NMAX,
integer  INCMAX,
complex, dimension( nmax, nmax )  A,
complex, dimension( nmax*nmax )  AA,
complex, dimension( nmax*nmax )  AS,
complex, dimension( nmax )  X,
complex, dimension( nmax*incmax )  XX,
complex, dimension( nmax*incmax )  XS,
complex, dimension( nmax )  Y,
complex, dimension( nmax*incmax )  YY,
complex, dimension( nmax*incmax )  YS,
complex, dimension( nmax )  YT,
real, dimension( nmax )  G 
)

Definition at line 441 of file cblat2.f.

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