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

◆ zchk1()

subroutine zchk1 ( character*6 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 )

Definition at line 435 of file zblat2.f.

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