subroutine check0

(

double precision

SFAC

)

Definition at line 127 of file dblat1.f.

*     .. Parameters ..
      INTEGER           nout
      parameter              (nout=6)
*     .. Scalar Arguments ..
      DOUBLE PRECISION  sfac
*     .. Scalars in Common ..
      INTEGER           icase, incx, incy, n
      LOGICAL           pass
*     .. Local Scalars ..
      DOUBLE PRECISION  sa, sb, sc, ss, d12
      INTEGER           i, k
*     .. Local Arrays ..
      DOUBLE PRECISION  da1(8), datrue(8), db1(8), dbtrue(8), dc1(8),
     $                  ds1(8), dab(4,9), dtemp(9), dtrue(9,9)
*     .. External Subroutines ..
      EXTERNAL          drotg, drotmg, stest1
*     .. Common blocks ..
      COMMON            /combla/icase, n, incx, incy, 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/
*     INPUT FOR MODIFIED GIVENS
      DATA dab/ .1d0,.3d0,1.2d0,.2d0,
     a          .7d0, .2d0, .6d0, 4.2d0,
     b          0.d0,0.d0,0.d0,0.d0,
     c          4.d0, -1.d0, 2.d0, 4.d0,
     d          6.d-10, 2.d-2, 1.d5, 10.d0,
     e          4.d10, 2.d-2, 1.d-5, 10.d0,
     f          2.d-10, 4.d-2, 1.d5, 10.d0,
     g          2.d10, 4.d-2, 1.d-5, 10.d0,
     h          4.d0, -2.d0, 8.d0, 4.d0    /
*    TRUE RESULTS FOR MODIFIED GIVENS
      DATA dtrue/0.d0,0.d0, 1.3d0, .2d0, 0.d0,0.d0,0.d0, .5d0, 0.d0,
     a           0.d0,0.d0, 4.5d0, 4.2d0, 1.d0, .5d0, 0.d0,0.d0,0.d0,
     b           0.d0,0.d0,0.d0,0.d0, -2.d0, 0.d0,0.d0,0.d0,0.d0,
     c           0.d0,0.d0,0.d0, 4.d0, -1.d0, 0.d0,0.d0,0.d0,0.d0,
     d           0.d0, 15.d-3, 0.d0, 10.d0, -1.d0, 0.d0, -1.d-4,
     e           0.d0, 1.d0,
     f           0.d0,0.d0, 6144.d-5, 10.d0, -1.d0, 4096.d0, -1.d6,
     g           0.d0, 1.d0,
     h           0.d0,0.d0,15.d0,10.d0,-1.d0, 5.d-5, 0.d0,1.d0,0.d0,
     i           0.d0,0.d0, 15.d0, 10.d0, -1. d0, 5.d5, -4096.d0,
     j           1.d0, 4096.d-6,
     k           0.d0,0.d0, 7.d0, 4.d0, 0.d0,0.d0, -.5d0, -.25d0, 0.d0/
*                   4096 = 2 ** 12
      DATA d12  /4096.d0/
      dtrue(1,1) = 12.d0 / 130.d0
      dtrue(2,1) = 36.d0 / 130.d0
      dtrue(7,1) = -1.d0 / 6.d0
      dtrue(1,2) = 14.d0 / 75.d0
      dtrue(2,2) = 49.d0 / 75.d0
      dtrue(9,2) = 1.d0 / 7.d0
      dtrue(1,5) = 45.d-11 * (d12 * d12)
      dtrue(3,5) = 4.d5 / (3.d0 * d12)
      dtrue(6,5) = 1.d0 / d12
      dtrue(8,5) = 1.d4 / (3.d0 * d12)
      dtrue(1,6) = 4.d10 / (1.5d0 * d12 * d12)
      dtrue(2,6) = 2.d-2 / 1.5d0
      dtrue(8,6) = 5.d-7 * d12
      dtrue(1,7) = 4.d0 / 150.d0
      dtrue(2,7) = (2.d-10 / 1.5d0) * (d12 * d12)
      dtrue(7,7) = -dtrue(6,5)
      dtrue(9,7) = 1.d4 / d12
      dtrue(1,8) = dtrue(1,7)
      dtrue(2,8) = 2.d10 / (1.5d0 * d12 * d12)
      dtrue(1,9) = 32.d0 / 7.d0
      dtrue(2,9) = -16.d0 / 7.d0
*     .. 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
*           .. DROTG ..
            IF (k.GT.8) GO TO 40
            sa = da1(k)
            sb = db1(k)
            CALL drotg(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)
         ELSEIF (icase.EQ.11) THEN
*           .. DROTMG ..
            DO i=1,4
               dtemp(i)= dab(i,k)
               dtemp(i+4) = 0.0
            END DO
            dtemp(9) = 0.0
            CALL drotmg(dtemp(1),dtemp(2),dtemp(3),dtemp(4),dtemp(5))
            CALL stest(9,dtemp,dtrue(1,k),dtrue(1,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:

Here is the caller graph for this function: