subroutine check0

(

real

SFAC

)

Definition at line 83 of file c_sblat1.f.

*     .. Parameters ..
      INTEGER           nout
      parameter              (nout=6)
*     .. Scalar Arguments ..
      REAL              sfac
*     .. Scalars in Common ..
      INTEGER           icase, incx, incy, mode, n
      LOGICAL           pass
*     .. Local Scalars ..
      REAL              sa, sb, sc, ss
      INTEGER           k
*     .. Local Arrays ..
      REAL              da1(8), datrue(8), db1(8), dbtrue(8), dc1(8),
     +                  ds1(8)
*     .. External Subroutines ..
      EXTERNAL          srotgtest, stest1
*     .. Common blocks ..
      COMMON            /combla/icase, n, incx, incy, mode, pass
*     .. Data statements ..
      DATA              da1/0.3e0, 0.4e0, -0.3e0, -0.4e0, -0.3e0, 0.0e0,
     +                  0.0e0, 1.0e0/
      DATA              db1/0.4e0, 0.3e0, 0.4e0, 0.3e0, -0.4e0, 0.0e0,
     +                  1.0e0, 0.0e0/
      DATA              dc1/0.6e0, 0.8e0, -0.6e0, 0.8e0, 0.6e0, 1.0e0,
     +                  0.0e0, 1.0e0/
      DATA              ds1/0.8e0, 0.6e0, 0.8e0, -0.6e0, 0.8e0, 0.0e0,
     +                  1.0e0, 0.0e0/
      DATA              datrue/0.5e0, 0.5e0, 0.5e0, -0.5e0, -0.5e0,
     +                  0.0e0, 1.0e0, 1.0e0/
      DATA              dbtrue/0.0e0, 0.6e0, 0.0e0, -0.6e0, 0.0e0,
     +                  0.0e0, 1.0e0, 0.0e0/
*     .. Executable Statements ..
*
*     Compute true values which cannot be prestored
*     in decimal notation
*
      dbtrue(1) = 1.0e0/0.6e0
      dbtrue(3) = -1.0e0/0.6e0
      dbtrue(5) = 1.0e0/0.6e0
*
      DO 20 k = 1, 8
*        .. Set N=K for identification in output if any ..
         n = k
         IF (icase.EQ.3) THEN
*           .. SROTGTEST ..
            IF (k.GT.8) GO TO 40
            sa = da1(k)
            sb = db1(k)
            CALL srotgtest(sa,sb,sc,ss)
            CALL stest1(sa,datrue(k),datrue(k),sfac)
            CALL stest1(sb,dbtrue(k),dbtrue(k),sfac)
            CALL stest1(sc,dc1(k),dc1(k),sfac)
            CALL stest1(ss,ds1(k),ds1(k),sfac)
         ELSE
            WRITE (nout,*) ' Shouldn''t be here in CHECK0'
            stop
         END IF
   20 CONTINUE
   40 RETURN

Here is the call graph for this function: