gcc/testsuite/g77.f-torture/execute/dnrm2.f

   1 CCC g77 0.5.21 `Actual Bugs':
   2 CCC   * A code-generation bug afflicts Intel x86 targets when `-O2' is
   3 CCC     specified compiling, for example, an old version of the `DNRM2'
   4 CCC     routine.  The x87 coprocessor stack is being somewhat mismanaged
   5 CCC     in cases where assigned `GOTO' and `ASSIGN' are involved.
   6 CCC
   7 CCC     Version 0.5.21 of `g77' contains an initial effort to fix the
   8 CCC     problem, but this effort is incomplete, and a more complete fix is
   9 CCC     planned for the next release.
  10
  11 C     Currently this test fails with (at least) `-O2 -funroll-loops' on
  12 C     i586-unknown-linux-gnulibc1.
  13
  14 C     (This is actually an obsolete version of dnrm2 -- consult the
  15 c     current Netlib BLAS.)
  16
  17       integer i
  18       double precision a(1:100), dnrm2
  19       do i=1,100
  20          a(i)=0.D0
  21       enddo
  22       if (dnrm2(100,a,1) .ne. 0.0) call exit(1)
  23       end
  24
  25       double precision function dnrm2 ( n, dx, incx)
  26       integer i, incx, ix, j, n, next
  27       double precision   dx(1), cutlo, cuthi, hitest, sum, xmax,zero,one
  28       data   zero, one /0.0d0, 1.0d0/
  29       data cutlo, cuthi / 8.232d-11,  1.304d19 /
  30       j = 0
  31       if(n .gt. 0 .and. incx.gt.0) go to 10
  32          dnrm2  = zero
  33          go to 300
  34    10 assign 30 to next
  35       sum = zero
  36       i = 1
  37       ix = 1
  38    20    go to next,(30, 50, 70, 110)
  39    30 if( dabs(dx(i)) .gt. cutlo) go to 85
  40       assign 50 to next
  41       xmax = zero
  42    50 if( dx(i) .eq. zero) go to 200
  43       if( dabs(dx(i)) .gt. cutlo) go to 85
  44       assign 70 to next
  45       go to 105
  46   100 continue
  47       ix = j
  48       assign 110 to next
  49       sum = (sum / dx(i)) / dx(i)
  50   105 xmax = dabs(dx(i))
  51       go to 115
  52    70 if( dabs(dx(i)) .gt. cutlo ) go to 75
  53   110 if( dabs(dx(i)) .le. xmax ) go to 115
  54          sum = one + sum * (xmax / dx(i))**2
  55          xmax = dabs(dx(i))
  56          go to 200
  57   115 sum = sum + (dx(i)/xmax)**2
  58       go to 200
  59    75 sum = (sum * xmax) * xmax
  60    85 hitest = cuthi/float( n )
  61       do 95 j = ix,n
  62       if(dabs(dx(i)) .ge. hitest) go to 100
  63          sum = sum + dx(i)**2
  64          i = i + incx
  65    95 continue
  66       dnrm2 = dsqrt( sum )
  67       go to 300
  68   200 continue
  69       ix = ix + 1
  70       i = i + incx
  71       if( ix .le. n ) go to 20
  72       dnrm2 = xmax * dsqrt(sum)
  73   300 continue
  74       end