LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 460 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 *
788 10003 FORMAT( ' ', a12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ',
789  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
790  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
791 10002 FORMAT( ' ', a12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ',
792  $ 'TESTS (', i6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ',
793  $ 'RATIO ', f8.2, ' - SUSPECT *******' )
794 10001 FORMAT( ' ', a12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS',
795  $ ' (', i6, ' CALL', 'S)' )
796 10000 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 *
smake
subroutine smake(TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, KU, RESET, TRANSL)
Definition: sblat2.f:2653
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:2829
lse
logical function lse(RI, RJ, LR)
Definition: sblat2.f:2945
lseres
logical function lseres(TYPE, UPLO, M, N, AA, AS, LDA)
Definition: sblat2.f:2975

Here is the call graph for this function: