subroutine check1

(

real

SFAC

)

Definition at line 243 of file sblat1.f.

*     .. Parameters ..
      INTEGER           nout
      parameter              (nout=6)
*     .. Scalar Arguments ..
      REAL              sfac
*     .. Scalars in Common ..
      INTEGER           icase, incx, incy, n
      LOGICAL           pass
*     .. Local Scalars ..
      INTEGER           i, len, np1
*     .. Local Arrays ..
      REAL              dtrue1(5), dtrue3(5), dtrue5(8,5,2), dv(8,5,2),
     +                  sa(10), stemp(1), strue(8), sx(8)
      INTEGER           itrue2(5)
*     .. External Functions ..
      REAL              sasum, snrm2
      INTEGER           isamax
      EXTERNAL          sasum, snrm2, isamax
*     .. External Subroutines ..
      EXTERNAL          itest1, sscal, stest, stest1
*     .. Intrinsic Functions ..
      INTRINSIC         max
*     .. Common blocks ..
      COMMON            /combla/icase, n, incx, incy, pass
*     .. Data statements ..
      DATA              sa/0.3e0, -1.0e0, 0.0e0, 1.0e0, 0.3e0, 0.3e0,
     +                  0.3e0, 0.3e0, 0.3e0, 0.3e0/
      DATA              dv/0.1e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0,
     +                  2.0e0, 2.0e0, 0.3e0, 3.0e0, 3.0e0, 3.0e0, 3.0e0,
     +                  3.0e0, 3.0e0, 3.0e0, 0.3e0, -0.4e0, 4.0e0,
     +                  4.0e0, 4.0e0, 4.0e0, 4.0e0, 4.0e0, 0.2e0,
     +                  -0.6e0, 0.3e0, 5.0e0, 5.0e0, 5.0e0, 5.0e0,
     +                  5.0e0, 0.1e0, -0.3e0, 0.5e0, -0.1e0, 6.0e0,
     +                  6.0e0, 6.0e0, 6.0e0, 0.1e0, 8.0e0, 8.0e0, 8.0e0,
     +                  8.0e0, 8.0e0, 8.0e0, 8.0e0, 0.3e0, 9.0e0, 9.0e0,
     +                  9.0e0, 9.0e0, 9.0e0, 9.0e0, 9.0e0, 0.3e0, 2.0e0,
     +                  -0.4e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0,
     +                  0.2e0, 3.0e0, -0.6e0, 5.0e0, 0.3e0, 2.0e0,
     +                  2.0e0, 2.0e0, 0.1e0, 4.0e0, -0.3e0, 6.0e0,
     +                  -0.5e0, 7.0e0, -0.1e0, 3.0e0/
      DATA              dtrue1/0.0e0, 0.3e0, 0.5e0, 0.7e0, 0.6e0/
      DATA              dtrue3/0.0e0, 0.3e0, 0.7e0, 1.1e0, 1.0e0/
      DATA              dtrue5/0.10e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0,
     +                  2.0e0, 2.0e0, 2.0e0, -0.3e0, 3.0e0, 3.0e0,
     +                  3.0e0, 3.0e0, 3.0e0, 3.0e0, 3.0e0, 0.0e0, 0.0e0,
     +                  4.0e0, 4.0e0, 4.0e0, 4.0e0, 4.0e0, 4.0e0,
     +                  0.20e0, -0.60e0, 0.30e0, 5.0e0, 5.0e0, 5.0e0,
     +                  5.0e0, 5.0e0, 0.03e0, -0.09e0, 0.15e0, -0.03e0,
     +                  6.0e0, 6.0e0, 6.0e0, 6.0e0, 0.10e0, 8.0e0,
     +                  8.0e0, 8.0e0, 8.0e0, 8.0e0, 8.0e0, 8.0e0,
     +                  0.09e0, 9.0e0, 9.0e0, 9.0e0, 9.0e0, 9.0e0,
     +                  9.0e0, 9.0e0, 0.09e0, 2.0e0, -0.12e0, 2.0e0,
     +                  2.0e0, 2.0e0, 2.0e0, 2.0e0, 0.06e0, 3.0e0,
     +                  -0.18e0, 5.0e0, 0.09e0, 2.0e0, 2.0e0, 2.0e0,
     +                  0.03e0, 4.0e0, -0.09e0, 6.0e0, -0.15e0, 7.0e0,
     +                  -0.03e0, 3.0e0/
      DATA              itrue2/0, 1, 2, 2, 3/
*     .. Executable Statements ..
      DO 80 incx = 1, 2
         DO 60 np1 = 1, 5
            n = np1 - 1
            len = 2*max(n,1)
*           .. Set vector arguments ..
            DO 20 i = 1, len
               sx(i) = dv(i,np1,incx)
   20       CONTINUE
*
            IF (icase.EQ.7) THEN
*              .. SNRM2 ..
               stemp(1) = dtrue1(np1)
               CALL stest1(snrm2(n,sx,incx),stemp(1),stemp,sfac)
            ELSE IF (icase.EQ.8) THEN
*              .. SASUM ..
               stemp(1) = dtrue3(np1)
               CALL stest1(sasum(n,sx,incx),stemp(1),stemp,sfac)
            ELSE IF (icase.EQ.9) THEN
*              .. SSCAL ..
               CALL sscal(n,sa((incx-1)*5+np1),sx,incx)
               DO 40 i = 1, len
                  strue(i) = dtrue5(i,np1,incx)
   40          CONTINUE
               CALL stest(len,sx,strue,strue,sfac)
            ELSE IF (icase.EQ.10) THEN
*              .. ISAMAX ..
               CALL itest1(isamax(n,sx,incx),itrue2(np1))
            ELSE
               WRITE (nout,*) ' Shouldn''t be here in CHECK1'
               stop
            END IF
   60    CONTINUE
   80 CONTINUE
      RETURN

Here is the call graph for this function: