subroutine check0

(

double precision

SFAC

)

Definition at line 83 of file c_dblat1.f.

*     .. Parameters ..
      INTEGER           nout
      parameter              (nout=6)
*     .. Scalar Arguments ..
      DOUBLE PRECISION  sfac
*     .. Scalars in Common ..
      INTEGER           icase, incx, incy, mode, n
      LOGICAL           pass
*     .. Local Scalars ..
      DOUBLE PRECISION  sa, sb, sc, ss
      INTEGER           k
*     .. Local Arrays ..
      DOUBLE PRECISION  da1(8), datrue(8), db1(8), dbtrue(8), dc1(8),
     +                  ds1(8)
*     .. External Subroutines ..
      EXTERNAL          drotgtest, stest1
*     .. Common blocks ..
      COMMON            /combla/icase, n, incx, incy, mode, pass
*     .. Data statements ..
      DATA              da1/0.3d0, 0.4d0, -0.3d0, -0.4d0, -0.3d0, 0.0d0,
     +                  0.0d0, 1.0d0/
      DATA              db1/0.4d0, 0.3d0, 0.4d0, 0.3d0, -0.4d0, 0.0d0,
     +                  1.0d0, 0.0d0/
      DATA              dc1/0.6d0, 0.8d0, -0.6d0, 0.8d0, 0.6d0, 1.0d0,
     +                  0.0d0, 1.0d0/
      DATA              ds1/0.8d0, 0.6d0, 0.8d0, -0.6d0, 0.8d0, 0.0d0,
     +                  1.0d0, 0.0d0/
      DATA              datrue/0.5d0, 0.5d0, 0.5d0, -0.5d0, -0.5d0,
     +                  0.0d0, 1.0d0, 1.0d0/
      DATA              dbtrue/0.0d0, 0.6d0, 0.0d0, -0.6d0, 0.0d0,
     +                  0.0d0, 1.0d0, 0.0d0/
*     .. Executable Statements ..
*
*     Compute true values which cannot be prestored
*     in decimal notation
*
      dbtrue(1) = 1.0d0/0.6d0
      dbtrue(3) = -1.0d0/0.6d0
      dbtrue(5) = 1.0d0/0.6d0
*
      DO 20 k = 1, 8
*        .. Set N=K for identification in output if any ..
         n = k
         IF (icase.EQ.3) THEN
*           .. DROTGTEST ..
            IF (k.GT.8) GO TO 40
            sa = da1(k)
            sb = db1(k)
            CALL drotgtest(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: