LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ 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, cregr1
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* Regression test to verify preservation of y when m zero, n nonzero.
738*
739 CALL cregr1( trans, m, n, ly, kl, ku, alpha, aa, lda, xx, incx,
740 $ beta, yy, incy, ys )
741 IF( full )THEN
742 IF( trace )
743 $ WRITE( ntra, fmt = 9994 )nc, sname, trans, m, n, alpha, lda,
744 $ incx, beta, incy
745 IF( rewi )
746 $ rewind ntra
747 CALL cgemv( trans, m, n, alpha, aa, lda, xx, incx, beta, yy,
748 $ incy )
749 ELSE IF( banded )THEN
750 IF( trace )
751 $ WRITE( ntra, fmt = 9995 )nc, sname, trans, m, n, kl, ku,
752 $ alpha, lda, incx, beta, incy
753 IF( rewi )
754 $ rewind ntra
755 CALL cgbmv( trans, m, n, kl, ku, alpha, aa, lda, xx, incx,
756 $ beta, yy, incy )
757 END IF
758 nc = nc + 1
759 IF( .NOT.lce( ys, yy, ly ) )THEN
760 WRITE( nout, fmt = 9998 )nargs - 1
761 fatal = .true.
762 GO TO 130
763 END IF
764*
765* Report result.
766*
767 IF( errmax.LT.thresh )THEN
768 WRITE( nout, fmt = 9999 )sname, nc
769 ELSE
770 WRITE( nout, fmt = 9997 )sname, nc, errmax
771 END IF
772 GO TO 140
773*
774 130 CONTINUE
775 WRITE( nout, fmt = 9996 )sname
776 IF( full )THEN
777 WRITE( nout, fmt = 9994 )nc, sname, trans, m, n, alpha, lda,
778 $ incx, beta, incy
779 ELSE IF( banded )THEN
780 WRITE( nout, fmt = 9995 )nc, sname, trans, m, n, kl, ku,
781 $ alpha, lda, incx, beta, incy
782 END IF
783*
784 140 CONTINUE
785 RETURN
786*
787 9999 FORMAT( ' ', a6, ' PASSED THE COMPUTATIONAL TESTS (', i6, ' CALL',
788 $ 'S)' )
789 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', i2, ' WAS CH',
790 $ 'ANGED INCORRECTLY *******' )
791 9997 FORMAT( ' ', a6, ' COMPLETED THE COMPUTATIONAL TESTS (', i6, ' C',
792 $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', f8.2,
793 $ ' - SUSPECT *******' )
794 9996 FORMAT( ' ******* ', a6, ' FAILED ON CALL NUMBER:' )
795 9995 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', 4( i3, ',' ), '(',
796 $ f4.1, ',', f4.1, '), A,', i3, ', X,', i2, ',(', f4.1, ',',
797 $ f4.1, '), Y,', i2, ') .' )
798 9994 FORMAT( 1x, i6, ': ', a6, '(''', a1, ''',', 2( i3, ',' ), '(',
799 $ f4.1, ',', f4.1, '), A,', i3, ', X,', i2, ',(', f4.1, ',',
800 $ f4.1, '), Y,', i2, ') .' )
801 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
802 $ '******' )
803*
804* End of CCHK1
805*
cmake
subroutine cmake(type, uplo, diag, m, n, a, nmax, aa, lda, kl, ku, reset, transl)
Definition cblat2.f:2744
lceres
logical function lceres(type, uplo, m, n, aa, as, lda)
Definition cblat2.f:3097
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:2936
lce
logical function lce(ri, rj, lr)
Definition cblat2.f:3067
cregr1
subroutine cregr1(trans, m, n, ly, kl, ku, alpha, a, lda, x, incx, beta, y, incy, ys)
Definition cblat2.f:3253
cgbmv
subroutine cgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy)
CGBMV
Definition cgbmv.f:190
cgemv
subroutine cgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
CGEMV
Definition cgemv.f:160
Here is the call graph for this function:
Here is the caller graph for this function: