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

◆ zchk1()

subroutine zchk1 ( character*12 sname,
double precision eps,
double precision 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*16, dimension( nalf ) alf,
integer nbet,
complex*16, dimension( nbet ) bet,
integer ninc,
integer, dimension( ninc ) inc,
integer nmax,
integer incmax,
complex*16, dimension( nmax, nmax ) a,
complex*16, dimension( nmax*nmax ) aa,
complex*16, dimension( nmax*nmax ) as,
complex*16, dimension( nmax ) x,
complex*16, dimension( nmax*incmax ) xx,
complex*16, dimension( nmax*incmax ) xs,
complex*16, dimension( nmax ) y,
complex*16, dimension( nmax*incmax ) yy,
complex*16, dimension( nmax*incmax ) ys,
complex*16, dimension( nmax ) yt,
double precision, dimension( nmax ) g,
integer iorder )

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