subroutine check0

(

real

SFAC

)

Definition at line 127 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 ..
      REAL              d12, sa, sb, sc, ss
      INTEGER           i, k
*     .. Local Arrays ..
      REAL              da1(8), datrue(8), db1(8), dbtrue(8), dc1(8),
     +                  ds1(8), dab(4,9), dtemp(9), dtrue(9,9)
*     .. External Subroutines ..
      EXTERNAL          srotg, srotmg, stest1
*     .. Common blocks ..
      COMMON            /combla/icase, n, incx, incy, 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/
*     INPUT FOR MODIFIED GIVENS
      DATA dab/ .1e0,.3e0,1.2e0,.2e0,
     a          .7e0, .2e0, .6e0, 4.2e0,
     b          0.e0,0.e0,0.e0,0.e0,
     c          4.e0, -1.e0, 2.e0, 4.e0,
     d          6.e-10, 2.e-2, 1.e5, 10.e0,
     e          4.e10, 2.e-2, 1.e-5, 10.e0,
     f          2.e-10, 4.e-2, 1.e5, 10.e0,
     g          2.e10, 4.e-2, 1.e-5, 10.e0,
     h          4.e0, -2.e0, 8.e0, 4.e0    /
*    TRUE RESULTS FOR MODIFIED GIVENS
      DATA dtrue/0.e0,0.e0, 1.3e0, .2e0, 0.e0,0.e0,0.e0, .5e0, 0.e0,
     a           0.e0,0.e0, 4.5e0, 4.2e0, 1.e0, .5e0, 0.e0,0.e0,0.e0,
     b           0.e0,0.e0,0.e0,0.e0, -2.e0, 0.e0,0.e0,0.e0,0.e0,
     c           0.e0,0.e0,0.e0, 4.e0, -1.e0, 0.e0,0.e0,0.e0,0.e0,
     d           0.e0, 15.e-3, 0.e0, 10.e0, -1.e0, 0.e0, -1.e-4,
     e           0.e0, 1.e0,
     f           0.e0,0.e0, 6144.e-5, 10.e0, -1.e0, 4096.e0, -1.e6,
     g           0.e0, 1.e0,
     h           0.e0,0.e0,15.e0,10.e0,-1.e0, 5.e-5, 0.e0,1.e0,0.e0,
     i           0.e0,0.e0, 15.e0, 10.e0, -1. e0, 5.e5, -4096.e0,
     j           1.e0, 4096.e-6,
     k           0.e0,0.e0, 7.e0, 4.e0, 0.e0,0.e0, -.5e0, -.25e0, 0.e0/
*                   4096 = 2 ** 12
      DATA d12  /4096.e0/
      dtrue(1,1) = 12.e0 / 130.e0
      dtrue(2,1) = 36.e0 / 130.e0
      dtrue(7,1) = -1.e0 / 6.e0
      dtrue(1,2) = 14.e0 / 75.e0
      dtrue(2,2) = 49.e0 / 75.e0
      dtrue(9,2) = 1.e0 / 7.e0
      dtrue(1,5) = 45.e-11 * (d12 * d12)
      dtrue(3,5) = 4.e5 / (3.e0 * d12)
      dtrue(6,5) = 1.e0 / d12
      dtrue(8,5) = 1.e4 / (3.e0 * d12)
      dtrue(1,6) = 4.e10 / (1.5e0 * d12 * d12)
      dtrue(2,6) = 2.e-2 / 1.5e0
      dtrue(8,6) = 5.e-7 * d12
      dtrue(1,7) = 4.e0 / 150.e0
      dtrue(2,7) = (2.e-10 / 1.5e0) * (d12 * d12)
      dtrue(7,7) = -dtrue(6,5)
      dtrue(9,7) = 1.e4 / d12
      dtrue(1,8) = dtrue(1,7)
      dtrue(2,8) = 2.e10 / (1.5e0 * d12 * d12)
      dtrue(1,9) = 32.e0 / 7.e0
      dtrue(2,9) = -16.e0 / 7.e0
*     .. 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
*           .. SROTG ..
            IF (k.GT.8) GO TO 40
            sa = da1(k)
            sb = db1(k)
            CALL srotg(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
*           .. SROTMG ..
            DO i=1,4
               dtemp(i)= dab(i,k)
               dtemp(i+4) = 0.0
            END DO
            dtemp(9) = 0.0
            CALL srotmg(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: