gcc/testsuite/gfortran.dg/g77/dnrm2.f

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