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

◆ 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 462 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*
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
Here is the call graph for this function: