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

◆ schk1()

subroutine schk1 ( 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,
real, dimension( nalf )  alf,
integer  nbet,
real, dimension( nbet )  bet,
integer  ninc,
integer, dimension( ninc )  inc,
integer  nmax,
integer  incmax,
real, dimension( nmax, nmax )  a,
real, dimension( nmax*nmax )  aa,
real, dimension( nmax*nmax )  as,
real, dimension( nmax )  x,
real, dimension( nmax*incmax )  xx,
real, dimension( nmax*incmax )  xs,
real, dimension( nmax )  y,
real, dimension( nmax*incmax )  yy,
real, dimension( nmax*incmax )  ys,
real, dimension( nmax )  yt,
real, dimension( nmax )  g 
)

Definition at line 427 of file sblat2.f.

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