LAPACK  3.9.0
LAPACK: Linear Algebra PACKage

◆ cchk1()

subroutine cchk1 ( character*12  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,
integer  IORDER 
)

Definition at line 466 of file c_cblat2.f.

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