LAPACK  3.10.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 434 of file cblat2.f.

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