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

◆ schk1()

subroutine schk1 ( 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,
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,
integer  iorder 
)

Definition at line 456 of file c_sblat2.f.

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