gcc/testsuite/gfortran.dg/g77/980310-3.f

   1 c { dg-do compile }
   2 c
   3 c This demonstrates a problem with g77 and pic on x86 where
   4 c egcs 1.0.1 and earlier will generate bogus assembler output.
   5 c unfortunately, gas accepts the bogus acssembler output and
   6 c generates code that almost works.
   7 c
   8
   9
  10 C Date: Wed, 17 Dec 1997 23:20:29 +0000
  11 C From: Joao Cardoso <jcardoso@inescn.pt>
  12 C To: egcs-bugs@cygnus.com
  13 C Subject: egcs-1.0 f77 bug on OSR5
  14 C When trying to compile the Fortran file that I enclose bellow,
  15 C I got an assembler error:
  16 C
  17 C ./g77 -B./ -fpic -O -c scaleg.f
  18 C /usr/tmp/cca002D8.s:123:syntax error at (
  19 C
  20 C ./g77 -B./ -fpic -O0 -c scaleg.f
  21 C /usr/tmp/cca002EW.s:246:invalid operand combination: leal
  22 C
  23 C Compiling without the -fpic flag runs OK.
  24
  25       subroutine scaleg (n,ma,a,mb,b,low,igh,cscale,cperm,wk)
  26 c
  27 c     *****parameters:
  28       integer igh,low,ma,mb,n
  29       double precision a(ma,n),b(mb,n),cperm(n),cscale(n),wk(n,6)
  30 c
  31 c     *****local variables:
  32       integer i,ir,it,j,jc,kount,nr,nrp2
  33       double precision alpha,basl,beta,cmax,coef,coef2,coef5,cor,
  34      *                 ew,ewc,fi,fj,gamma,pgamma,sum,t,ta,tb,tc
  35 c
  36 c     *****fortran functions:
  37       double precision dabs, dlog10, dsign
  38 c     float
  39 c
  40 c     *****subroutines called:
  41 c     none
  42 c
  43 c     ---------------------------------------------------------------
  44 c
  45 c     *****purpose:
  46 c     scales the matrices a and b in the generalized eigenvalue
  47 c     problem a*x = (lambda)*b*x such that the magnitudes of the
  48 c     elements of the submatrices of a and b (as specified by low
  49 c     and igh) are close to unity in the least squares sense.
  50 c     ref.:  ward, r. c., balancing the generalized eigenvalue
  51 c     problem, siam j. sci. stat. comput., vol. 2, no. 2, june 1981,
  52 c     141-152.
  53 c
  54 c     *****parameter description:
  55 c
  56 c     on input:
  57 c
  58 c       ma,mb   integer
  59 c               row dimensions of the arrays containing matrices
  60 c               a and b respectively, as declared in the main calling
  61 c               program dimension statement;
  62 c
  63 c       n       integer
  64 c               order of the matrices a and b;
  65 c
  66 c       a       real(ma,n)
  67 c               contains the a matrix of the generalized eigenproblem
  68 c               defined above;
  69 c
  70 c       b       real(mb,n)
  71 c               contains the b matrix of the generalized eigenproblem
  72 c               defined above;
  73 c
  74 c       low     integer
  75 c               specifies the beginning -1 for the rows and
  76 c               columns of a and b to be scaled;
  77 c
  78 c       igh     integer
  79 c               specifies the ending -1 for the rows and columns
  80 c               of a and b to be scaled;
  81 c
  82 c       cperm   real(n)
  83 c               work array.  only locations low through igh are
  84 c               referenced and altered by this subroutine;
  85 c
  86 c       wk      real(n,6)
  87 c               work array that must contain at least 6*n locations.
  88 c               only locations low through igh, n+low through n+igh,
  89 c               ..., 5*n+low through 5*n+igh are referenced and
  90 c               altered by this subroutine.
  91 c
  92 c     on output:
  93 c
  94 c       a,b     contain the scaled a and b matrices;
  95 c
  96 c       cscale  real(n)
  97 c               contains in its low through igh locations the integer
  98 c               exponents of 2 used for the column scaling factors.
  99 c               the other locations are not referenced;
 100 c
 101 c       wk      contains in its low through igh locations the integer
 102 c               exponents of 2 used for the row scaling factors.
 103 c
 104 c     *****algorithm notes:
 105 c     none.
 106 c
 107 c     *****history:
 108 c     written by r. c. ward.......
 109 c     modified 8/86 by bobby bodenheimer so that if
 110 c       sum = 0 (corresponding to the case where the matrix
 111 c       doesn't need to be scaled) the routine returns.
 112 c
 113 c     ---------------------------------------------------------------
 114 c
 115       if (low .eq. igh) go to 410
 116       do 210 i = low,igh
 117          wk(i,1) = 0.0d0
 118          wk(i,2) = 0.0d0
 119          wk(i,3) = 0.0d0
 120          wk(i,4) = 0.0d0
 121          wk(i,5) = 0.0d0
 122          wk(i,6) = 0.0d0
 123          cscale(i) = 0.0d0
 124          cperm(i) = 0.0d0
 125   210 continue
 126 c
 127 c     compute right side vector in resulting linear equations
 128 c
 129       basl = dlog10(2.0d0)
 130       do 240 i = low,igh
 131          do 240 j = low,igh ! { dg-warning "Obsolescent feature: Shared DO termination" }
 132             tb = b(i,j)
 133             ta = a(i,j)
 134             if (ta .eq. 0.0d0) go to 220
 135             ta = dlog10(dabs(ta)) / basl
 136   220       continue
 137             if (tb .eq. 0.0d0) go to 230
 138             tb = dlog10(dabs(tb)) / basl
 139   230       continue
 140             wk(i,5) = wk(i,5) - ta - tb
 141             wk(j,6) = wk(j,6) - ta - tb
 142   240 continue
 143       nr = igh-low+1
 144       coef = 1.0d0/float(2*nr)
 145       coef2 = coef*coef
 146       coef5 = 0.5d0*coef2
 147       nrp2 = nr+2
 148       beta = 0.0d0
 149       it = 1
 150 c
 151 c     start generalized conjugate gradient iteration
 152 c
 153   250 continue
 154       ew = 0.0d0
 155       ewc = 0.0d0
 156       gamma = 0.0d0
 157       do 260 i = low,igh
 158          gamma = gamma + wk(i,5)*wk(i,5) + wk(i,6)*wk(i,6)
 159          ew = ew + wk(i,5)
 160          ewc = ewc + wk(i,6)
 161   260 continue
 162       gamma = coef*gamma - coef2*(ew**2 + ewc**2)
 163      +        - coef5*(ew - ewc)**2
 164       if (it .ne. 1) beta = gamma / pgamma
 165       t = coef5*(ewc - 3.0d0*ew)
 166       tc = coef5*(ew - 3.0d0*ewc)
 167       do 270 i = low,igh
 168          wk(i,2) = beta*wk(i,2) + coef*wk(i,5) + t
 169          cperm(i) = beta*cperm(i) + coef*wk(i,6) + tc
 170   270 continue
 171 c
 172 c     apply matrix to vector
 173 c
 174       do 300 i = low,igh
 175          kount = 0
 176          sum = 0.0d0
 177          do 290 j = low,igh
 178             if (a(i,j) .eq. 0.0d0) go to 280
 179             kount = kount+1
 180             sum = sum + cperm(j)
 181   280       continue
 182             if (b(i,j) .eq. 0.0d0) go to 290
 183             kount = kount+1
 184             sum = sum + cperm(j)
 185   290    continue
 186          wk(i,3) = float(kount)*wk(i,2) + sum
 187   300 continue
 188       do 330 j = low,igh
 189          kount = 0
 190          sum = 0.0d0
 191          do 320 i = low,igh
 192             if (a(i,j) .eq. 0.0d0) go to 310
 193             kount = kount+1
 194             sum = sum + wk(i,2)
 195   310       continue
 196             if (b(i,j) .eq. 0.0d0) go to 320
 197             kount = kount+1
 198             sum = sum + wk(i,2)
 199   320    continue
 200          wk(j,4) = float(kount)*cperm(j) + sum
 201   330 continue
 202       sum = 0.0d0
 203       do 340 i = low,igh
 204          sum = sum + wk(i,2)*wk(i,3) + cperm(i)*wk(i,4)
 205   340 continue
 206       if(sum.eq.0.0d0) return
 207       alpha = gamma / sum
 208 c
 209 c     determine correction to current iterate
 210 c
 211       cmax = 0.0d0
 212       do 350 i = low,igh
 213          cor = alpha * wk(i,2)
 214          if (dabs(cor) .gt. cmax) cmax = dabs(cor)
 215          wk(i,1) = wk(i,1) + cor
 216          cor = alpha * cperm(i)
 217          if (dabs(cor) .gt. cmax) cmax = dabs(cor)
 218          cscale(i) = cscale(i) + cor
 219   350 continue
 220       if (cmax .lt. 0.5d0) go to 370
 221       do 360 i = low,igh
 222          wk(i,5) = wk(i,5) - alpha*wk(i,3)
 223          wk(i,6) = wk(i,6) - alpha*wk(i,4)
 224   360 continue
 225       pgamma = gamma
 226       it = it+1
 227       if (it .le. nrp2) go to 250
 228 c
 229 c     end generalized conjugate gradient iteration
 230 c
 231   370 continue
 232       do 380 i = low,igh
 233          ir = wk(i,1) + dsign(0.5d0,wk(i,1))
 234          wk(i,1) = ir
 235          jc = cscale(i) + dsign(0.5d0,cscale(i))
 236          cscale(i) = jc
 237   380 continue
 238 c
 239 c     scale a and b
 240 c
 241       do 400 i = 1,igh
 242          ir = wk(i,1)
 243          fi = 2.0d0**ir
 244          if (i .lt. low) fi = 1.0d0
 245          do 400 j =low,n ! { dg-warning "Obsolescent feature: Shared DO termination" }
 246             jc = cscale(j)
 247             fj = 2.0d0**jc
 248             if (j .le. igh) go to 390
 249             if (i .lt. low) go to 400
 250             fj = 1.0d0
 251   390       continue
 252             a(i,j) = a(i,j)*fi*fj
 253             b(i,j) = b(i,j)*fi*fj
 254   400 continue
 255   410 continue
 256       return
 257 c
 258 c     last line of scaleg
 259 c
 260       end