# to unbundle, sh this file (in an empty directory) mkdir hopdm.src echo hopdm.src/adlittle.mps 1>&2 sed >hopdm.src/adlittle.mps <<'//GO.SYSIN DD hopdm.src/adlittle.mps' 's/^-//' -NAME ADLITTLE -ROWS - N .Z.... - L ....01 - E ....02 - L ....03 - L ....04 - L ....05 - L ....06 - L ....07 - L ....08 - L ....09 - E ....10 - L ....11 - L ....12 - L ....13 - L ....14 - L ....15 - L ....16 - L ....17 - L ....18 - L ....19 - L ....20 - L ....21 - L ....22 - L ....23 - L ....24 - E ....25 - L ....26 - L ....27 - E ....28 - L ....29 - L ....30 - E ....31 - E ....32 - E ....33 - L ....34 - L ....35 - E ....36 - L ....37 - L ....38 - L ....39 - E ....40 - L ....41 - E ....42 - E ....43 - E ....44 - L ....45 - L ....46 - L ....47 - L ....48 - E ....49 - E ....50 - G ....51 - L ....52 - L ....53 - E ....54 - L ....55 - L ....56 -COLUMNS - ...100 .Z.... -3280. ....01 .506 - ...100 ....04 1. ....05 .182 - ...100 ....55 .312 - ...101 .Z.... -3280. ....01 .638 - ...101 ....04 1. ....05 .05 - ...101 ....55 .312 - ...102 .Z.... 3310. ....01 -1. - ...103 .Z.... -1890. ....05 .92 - ...103 ....30 1. ....49 -9.5 - ...103 ....52 -.042 ....53 -.063 - ...103 ....55 .08 - ...104 ....34 .825 ....35 .175 - ...104 ....40 1. ....51 16. - ...105 ....35 .175 ....40 1. - ...105 ....46 .825 ....51 21. - ...106 .Z.... -1890. ....06 1. - ...106 ....30 1. ....49 3.6 - ...106 ....52 -.042 ....53 -.063 - ...107 .Z.... -903. ....06 1. - ...107 ....38 1. - ...108 ....06 1. ....50 -.8 - ...109 .Z.... 432. ....31 -1.23 - ...109 ....42 .23 - ...110 .Z.... 432. ....32 -1.23 - ...110 ....43 .23 ....56 1. - ...111 .Z.... 432. ....33 -1.23 - ...111 ....44 .23 ....56 1. - ...112 .Z.... 446. ....07 1. - ...112 ....31 -1. - ...113 .Z.... 446. ....07 1. - ...113 ....32 -1. - ...114 .Z.... 446. ....07 1. - ...114 ....33 -1. - ...115 .Z.... 450. ....08 1. - ...115 ....31 -.95 ....42 -.05 - ...116 .Z.... 450. ....08 1. - ...116 ....32 -.95 ....43 -.05 - ...117 .Z.... 450. ....08 1. - ...117 ....33 -.95 ....44 -.05 - ...118 .Z.... 459. ....09 1. - ...118 ....31 -.79 ....42 -.21 - ...119 .Z.... 459. ....09 1. - ...119 ....32 -.79 ....43 -.21 - ...120 .Z.... 459. ....09 1. - ...120 ....33 -.79 ....44 -.21 - ...121 .Z.... 483. ....11 1. - ...121 ....31 -.42 ....42 -.58 - ...122 .Z.... 483. ....11 1. - ...122 ....32 -.42 ....43 -.58 - ...123 .Z.... 483. ....11 1. - ...123 ....33 -.42 ....44 -.58 - ...124 .Z.... 500. ....12 1. - ...124 ....31 -.05 ....42 -.95 - ...125 .Z.... 500. ....12 1. - ...125 ....32 -.05 ....43 -.95 - ...126 .Z.... 500. ....12 1. - ...126 ....33 -.05 ....44 -.95 - ...127 .Z.... 493. ....13 1. - ...127 ....31 -.26 ....42 -.74 - ...128 .Z.... 493. ....13 1. - ...128 ....32 -.26 ....43 -.74 - ...129 .Z.... 493. ....13 1. - ...129 ....33 -.26 ....44 -.74 - ...130 .Z.... -1890. ....14 1. - ...130 ....30 1. ....49 -3.2 - ...130 ....52 -.042 ....53 -.063 - ...131 .Z.... -903. ....14 1. - ...131 ....38 1. - ...132 .Z.... 506. ....17 1. - ...132 ....31 .26 ....42 -1.26 - ...133 ....14 1. ....50 -.8 - ...134 .Z.... 506. ....17 1. - ...134 ....32 .26 ....43 -1.26 - ...135 .Z.... 506. ....17 1. - ...135 ....33 .26 ....44 -1.26 - ...136 .Z.... 505. ....15 1. - ...136 ....31 .16 ....42 -1.16 - ...137 .Z.... 505. ....15 1. - ...137 ....32 .16 ....43 -1.16 - ...138 .Z.... 505. ....15 1. - ...138 ....33 .16 ....44 -1.16 - ...139 .Z.... 499. ....16 1. - ...139 ....31 -.16 ....42 -.84 - ...140 .Z.... 499. ....16 1. - ...140 ....32 -.16 ....43 -.84 - ...141 .Z.... 499. ....16 1. - ...141 ....33 -.16 ....44 -.84 - ...142 ....10 -1. - ...143 ....02 1. ....03 .79 - ...143 ....10 37. ....28 .494 - ...143 ....34 .506 ....54 2.27424 - ...144 ....02 1. ....03 .53 - ...144 ....10 47. ....28 .492 - ...144 ....46 .508 ....54 2.2632 - ...145 .Z.... 512. ....18 1. - ...145 ....31 .62 ....42 -1.62 - ...146 .Z.... 512. ....18 1. - ...146 ....32 .62 ....43 -1.62 - ...147 .Z.... 512. ....18 1. - ...147 ....33 .62 ....44 -1.62 - ...148 .Z.... 70.9 ....01 -.247 - ...148 ....06 .1726 ....14 -.3122 - ...148 ....20 1.783 ....28 .4703 - ...148 ....50 -.0928 ....54 1.40015 - ...149 .Z.... 39.8 ....01 -.157 - ...149 ....14 -.2399 ....20 1. - ...149 ....28 .4273 ....50 -.0361 - ...149 ....54 1.20404 - ...150 .Z.... 39.8 ....01 -.157 - ...150 ....14 -.2789 ....20 1. - ...150 ....28 .4663 ....50 -.0361 - ...150 ....54 1.43498 - ...151 .Z.... 2.04 ....26 1. - ...151 ....28 .55 ....50 -.52 - ...151 ....54 .6 - ...152 ....28 1. ....50 -1. - ...152 ....54 1.8 - ...153 .Z.... 1.8 ....03 -.33 - ...153 ....21 1. ....50 .017 - ...154 .Z.... 1.8 ....21 1. - ...154 ....37 -.33 - ...155 .Z.... -2600. ....01 .2 - ...155 ....14 .73 ....29 1. - ...155 ....55 .07 - ...156 .Z.... -2600. ....14 .72 - ...156 ....29 1. ....47 .2 - ...156 ....55 .08 - ...157 .Z.... 10.4 ....02 1. - ...157 ....03 .25 ....10 45. - ...157 ....22 .875 ....28 .3675 - ...157 ....34 .6325 ....50 .02536 - ...157 ....54 1.614 - ...158 .Z.... 10.4 ....02 1. - ...158 ....03 .2 ....10 55. - ...158 ....22 .875 ....28 .365 - ...158 ....46 .635 ....50 .02538 - ...158 ....54 1.59 - ...159 .Z.... 28.8 ....19 1. - ...159 ....28 -.828 ....31 1. - ...159 ....34 -.095 ....35 -.02 - ...159 ....50 .012 ....54 -1.42 - ...159 ....55 -.0467 - ...160 .Z.... 43.4 ....01 -.0022 - ...160 ....06 -.0192 ....19 1. - ...160 ....27 .679 ....28 -.808 - ...160 ....32 1. ....34 -.095 - ...160 ....35 -.02 ....50 .0205 - ...160 ....54 -1.84 ....55 -.0467 - ...161 .Z.... 30.4 ....01 -.0022 - ...161 ....06 -.0192 ....24 1. - ...161 ....27 .679 ....28 -.808 - ...161 ....33 1. ....34 -.095 - ...161 ....35 -.02 ....50 .0205 - ...161 ....54 -1.84 ....55 -.0467 - ...162 ....28 -1. ....34 1. - ...162 ....54 -5.2 - ...163 ....28 -1. ....35 1. - ...163 ....54 -6.7 - ...164 .Z.... -1218. ....35 1. - ...164 ....48 1. - ...165 ....35 1. ....50 -.8 - ...166 ....28 .482 ....34 .498 - ...166 ....35 .02 ....36 1. - ...166 ....37 .79 ....54 2.217 - ...167 ....28 .474 ....35 .02 - ...167 ....36 1. ....37 .53 - ...167 ....46 .506 ....54 2.18 - ...168 .Z.... -1322. ....06 .07 - ...168 ....35 .1 ....39 1. - ...168 ....55 .83 - ...169 .Z.... -1322. ....35 .07 - ...169 ....39 1. ....46 .33 - ...169 ....55 .6 - ...170 .Z.... -1322. ....34 .33 - ...170 ....35 .07 ....39 1. - ...170 ....55 .6 - ...171 .Z.... -1660. ....22 .625 - ...171 ....28 -.125 ....34 1.125 - ...171 ....41 1. ....50 .01812 - ...171 ....54 -.65 - ...172 .Z.... -1670. ....41 1. - ...172 ....46 1. - ...173 .Z.... 14.8 ....22 1.25 - ...173 ....28 -.25 ....34 1.03125 - ...173 ....35 .21875 ....40 1. - ...173 ....50 .03625 ....51 30. - ...173 ....54 -1.36562 - ...174 .Z.... 14.8 ....22 1.25 - ...174 ....28 -.25 ....35 .21875 - ...174 ....40 1. ....46 1.03125 - ...174 ....50 .03625 ....51 35. - ...174 ....54 -1.38375 - ...175 .Z.... 28.8 ....19 1.072 - ...175 ....28 -.706 ....35 -.027 - ...175 ....42 1. ....46 -.128 - ...175 ....50 .0129 ....54 -1.61 - ...175 ....55 -.1203 - ...176 .Z.... 43. ....01 -.0012 - ...176 ....06 -.0159 ....19 1.072 - ...176 ....27 .534 ....28 -.69 - ...176 ....35 -.027 ....43 1. - ...176 ....46 -.128 ....50 .0195 - ...176 ....54 -1.84 ....55 -.1203 - ...177 .Z.... 30. ....01 -.0012 - ...177 ....06 -.0159 ....24 1. - ...177 ....27 .534 ....28 -.69 - ...177 ....35 -.027 ....44 1. - ...177 ....46 -.128 ....50 .0195 - ...177 ....54 -1.84 ....55 -.1203 - ...178 .Z.... -1763. ....05 .181 - ...178 ....45 1. ....47 .11 - ...178 ....55 .709 - ...179 .Z.... -1722. ....05 .051 - ...179 ....45 1. ....47 .055 - ...179 ....55 .894 - ...180 .Z.... -1680. ....05 .036 - ...180 ....45 1. ....55 .964 - ...181 ....28 -1. ....46 1. - ...181 ....54 -5.3 - ...182 .Z.... -1890. ....30 1. - ...182 ....47 .92 ....49 -10.1 - ...182 ....52 -.042 ....53 -.063 - ...182 ....55 .08 - ...183 .Z.... 1780. ....02 1. - ...183 ....03 .4 ....10 45. - ...184 .Z.... 1600. ....28 -1. - ...184 ....54 -4.35 - ...185 .Z.... 903. ....28 -1. - ...185 ....54 -2.1 - ...186 .Z.... 1760. ....36 1. - ...186 ....37 .8 - ...187 .Z.... 2100. ....40 1. - ...187 ....51 24. - ...188 .Z.... 1000. ....49 -64.3 - ...188 ....52 1. - ...189 .Z.... 1000. ....49 -27.4 - ...189 ....53 1. - ...190 .Z.... -1890. ....30 1. - ...190 ....49 9.1 ....52 -.042 - ...190 ....53 -.063 ....55 1. - ...191 .Z.... 92.1 ....05 -.36 - ...191 ....23 1. ....28 -.026 - ...191 ....47 -.134 ....50 -.182 - ...191 ....54 -.1742 ....55 .826 - ...192 .Z.... -903. ....38 1. - ...192 ....55 1. - ...193 .Z.... 78.7 ....55 1. - ...194 .Z.... -1218. ....48 1. - ...194 ....55 1. - ...195 .Z.... 15.6 ....05 -.396 - ...195 ....25 1. ....28 -.029 - ...195 ....47 -.147 ....50 -.119 - ...195 ....54 -.194 ....55 .81 - ...196 ....50 -.8 ....55 1. -RHS - ZZZZ0001 ....02 52.6 ....03 22.7 - ZZZZ0001 ....04 23.4 ....07 108. - ZZZZ0001 ....08 50. ....09 13. - ZZZZ0001 ....10 2366. ....11 200. - ZZZZ0001 ....12 265. ....13 300. - ZZZZ0001 ....15 31. ....16 60. - ZZZZ0001 ....17 134. ....18 34. - ZZZZ0001 ....19 413. ....20 41.5 - ZZZZ0001 ....21 15. ....22 20.6 - ZZZZ0001 ....23 13.5 ....24 440. - ZZZZ0001 ....26 16. ....27 290. - ZZZZ0001 ....28 -524.9 ....29 3.1 - ZZZZ0001 ....30 9.1 ....36 43. - ZZZZ0001 ....37 34.4 ....38 15.6 - ZZZZ0001 ....39 19.2 ....40 44.9 - ZZZZ0001 ....41 6.1 ....45 13.2 - ZZZZ0001 ....48 31.2 ....50 2.5 - ZZZZ0001 ....51 1080. ....54 -1231.6 - ZZZZ0001 ....56 107. -ENDATA //GO.SYSIN DD hopdm.src/adlittle.mps echo hopdm.src/adlittle.spc 1>&2 sed >hopdm.src/adlittle.spc <<'//GO.SYSIN DD hopdm.src/adlittle.spc' 's/^-//' -begin -rows 60 -cols 200 -elements 600 -MPS FILE adlittle.mps -ERROR FILE adlittle.err -SOLUT FILE adlittle.res -opt tol 1.0D-8 -minimize -end //GO.SYSIN DD hopdm.src/adlittle.spc echo hopdm.src/afiro.mps 1>&2 sed >hopdm.src/afiro.mps <<'//GO.SYSIN DD hopdm.src/afiro.mps' 's/^-//' -NAME AFIRO -ROWS - E R09 - E R10 - L X05 - L X21 - E R12 - E R13 - L X17 - L X18 - L X19 - L X20 - E R19 - E R20 - L X27 - L X44 - E R22 - E R23 - L X40 - L X41 - L X42 - L X43 - L X45 - L X46 - L X47 - L X48 - L X49 - L X50 - L X51 - N COST -COLUMNS - X01 X48 .301 R09 -1. - X01 R10 -1.06 X05 1. - X02 X21 -1. R09 1. - X02 COST -.4 - X03 X46 -1. R09 1. - X04 X50 1. R10 1. - X06 X49 .301 R12 -1. - X06 R13 -1.06 X17 1. - X07 X49 .313 R12 -1. - X07 R13 -1.06 X18 1. - X08 X49 .313 R12 -1. - X08 R13 -.96 X19 1. - X09 X49 .326 R12 -1. - X09 R13 -.86 X20 1. - X10 X45 2.364 X17 -1. - X11 X45 2.386 X18 -1. - X12 X45 2.408 X19 -1. - X13 X45 2.429 X20 -1. - X14 X21 1.4 R12 1. - X14 COST -.32 - X15 X47 -1. R12 1. - X16 X51 1. R13 1. - X22 X46 .109 R19 -1. - X22 R20 -.43 X27 1. - X23 X44 -1. R19 1. - X23 COST -.6 - X24 X48 -1. R19 1. - X25 X45 -1. R19 1. - X26 X50 1. R20 1. - X28 X47 .109 R22 -.43 - X28 R23 1. X40 1. - X29 X47 .108 R22 -.43 - X29 R23 1. X41 1. - X30 X47 .108 R22 -.39 - X30 R23 1. X42 1. - X31 X47 .107 R22 -.37 - X31 R23 1. X43 1. - X32 X45 2.191 X40 -1. - X33 X45 2.219 X41 -1. - X34 X45 2.249 X42 -1. - X35 X45 2.279 X43 -1. - X36 X44 1.4 R23 -1. - X36 COST -.48 - X37 X49 -1. R23 1. - X38 X51 1. R22 1. - X39 R23 1. COST 10. -RHS - B X50 310. X51 300. - B X05 80. X17 80. - B X27 500. R23 44. - B X40 500. -ENDATA //GO.SYSIN DD hopdm.src/afiro.mps echo hopdm.src/afiro.spc 1>&2 sed >hopdm.src/afiro.spc <<'//GO.SYSIN DD hopdm.src/afiro.spc' 's/^-//' -begin -rows 30 -cols 60 -elements 120 -MPS FILE afiro.mps -ERROR FILE afiro.err -SOLUT FILE afiro.res -rhs name B -objective COST -opt tol 1.0D-8 -minimize -end //GO.SYSIN DD hopdm.src/afiro.spc echo hopdm.src/blas.f 1>&2 sed >hopdm.src/blas.f <<'//GO.SYSIN DD hopdm.src/blas.f' 's/^-//' - subroutine daxpy(n,da,dx,incx,dy,incy) -c -c constant times a vector plus a vector. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c - double precision dx(1),dy(1),da - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if (da .eq. 0.0d0) return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dy(iy) = dy(iy) + da*dx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,4) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dy(i) = dy(i) + da*dx(i) - 30 continue - if( n .lt. 4 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,4 - dy(i) = dy(i) + da*dx(i) - dy(i + 1) = dy(i + 1) + da*dx(i + 1) - dy(i + 2) = dy(i + 2) + da*dx(i + 2) - dy(i + 3) = dy(i + 3) + da*dx(i + 3) - 50 continue - return - end - subroutine dcopy(n,dx,incx,dy,incy) -c -c copies a vector, x, to a vector, y. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c - double precision dx(1),dy(1) - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dy(iy) = dx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,7) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dy(i) = dx(i) - 30 continue - if( n .lt. 7 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,7 - dy(i) = dx(i) - dy(i + 1) = dx(i + 1) - dy(i + 2) = dx(i + 2) - dy(i + 3) = dx(i + 3) - dy(i + 4) = dx(i + 4) - dy(i + 5) = dx(i + 5) - dy(i + 6) = dx(i + 6) - 50 continue - return - end - double precision function ddot(n,dx,incx,dy,incy) -c -c forms the dot product of two vectors. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c - double precision dx(1),dy(1),dtemp - integer i,incx,incy,ix,iy,m,mp1,n -c - ddot = 0.0d0 - dtemp = 0.0d0 - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = dtemp + dx(ix)*dy(iy) - ix = ix + incx - iy = iy + incy - 10 continue - ddot = dtemp - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dtemp + dx(i)*dy(i) - 30 continue - if( n .lt. 5 ) go to 60 - 40 mp1 = m + 1 - do 50 i = mp1,n,5 - dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + - * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) - 50 continue - 60 ddot = dtemp - return - end //GO.SYSIN DD hopdm.src/blas.f echo hopdm.src/cheap.f 1>&2 sed >hopdm.src/cheap.f <<'//GO.SYSIN DD hopdm.src/cheap.f' 's/^-//' -C******************************************************************** -C **** CHEAP ... CHEAP ROW ORDERING MINIMIZING NONZEROS OF L **** -C******************************************************************** -C - SUBROUTINE CHEAP(AATPAT,AATPNT,CLIQS,MAXNZL,MAXM,M,NZL, - X PERM,INVP,DGHEAD,LINKFD,LINKBK, - X RWLIST,LSTCLQ,MARKER,TEMP,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXNZL,MAXM,M,NZL,IOERR - INTEGER*4 AATPNT(MAXM+1),CLIQS(MAXNZL) - INTEGER*4 LSTCLQ(MAXM),MARKER(MAXM),TEMP(MAXM),RWLIST(MAXM) -C -C *** The following arrays can be half-length integer. - INTEGER*2 DGHEAD(MAXM),LINKFD(MAXM),LINKBK(MAXM) - INTEGER*2 AATPAT(MAXNZL),PERM(MAXM),INVP(MAXM) -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,IROW,K,ELROWS,DEGREE - CHARACTER*100 BUFFER -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C AATPAT Sparsity pattern of A*Atransp handled as -C a collection of sparse row vectors (diagonal -C elements are excluded from the list). -C AATPNT Pointers to rows of A*Atransp. -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C MAXM Maximum row dimension of the matrix to be decomposed. -C M Dimension of the matrix to be decomposed. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C NZL Number of nonzero entries in Cholesky factor. -C PERM Permutation resulting from the minimum degree ordering. -C INVP Inverse permutation. -C -C WORK ARRAYS: -C CLIQS Cliques of the pivotal rows (linked lists). -C DGHEAD Headers of the forward linked lists of rows (nodes) -C with the same degree. -C LINKFD Forward linked lists of rows with the same degree. -C LINKBK Backward linked lists of rows with the same degree. -C LSTCLQ A list of headers to different pivotal cliques -C that are still active i.e. that have not yet been -C merged with any pivotal row. -C RWLIST A list of nonzero positions of a row that is -C involved in a current step of elimination. -C MARKER Array used to mark already reordered rows. -C TEMP Temporary array used for merging lists. -C -C -C *** SUBROUTINES CALLED: -C MYWRT -C -C -C *** PURPOSE: -C This routine implements a simple heuristic producing an -C ordering of rows of A that is expected to reasonably minimize -C the number of nonzero entries in a Cholesky matrix. -C It is significantly cheaper than a minimum degree ordering -C (MDO) but in some cases it may produce considerably more -C fill-in in the Cholesky factor. -C -C -C *** NOTES: -C 1. This routine assumes that the matrix A*Atransp is -C positive definite i.e. that pivoting in the numerical -C phase will not be required. -C -C -C *** REFERENCES: -C Duff I.S., Erisman A.M., Reid J.K. (1989). Direct methods -C for sparse matrices, Clarendon Press, Oxford 1989, -C chapter 10. -C Gondzio J. (1991). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization (to appear). -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: May 13, 1993 -C -C -C -C *** BODY OF (CHEAP) *** -C -C -C -C Zero headers to the linked lists of rows -C with the same degree. - DO 20 IROW=1,M - DGHEAD(IROW)=0 - 20 CONTINUE -C -C Set the linked lists of rows with the same degree (recall -C that diagonal elements are not stored in the sparsity pattern). - DO 40 IROW=1,M - DEGREE=AATPNT(IROW+1)-AATPNT(IROW)+1 - LINKFD(IROW)=DGHEAD(DEGREE) - DGHEAD(DEGREE)=IROW - 40 CONTINUE -C -C *** DEBUGGING -C DO 42 IROW=1,M -C WRITE(BUFFER,41) IROW,DGHEAD(IROW),LINKFD(IROW) -C 41 FORMAT(1X,'CHEAP: row',I6,' header=',I6,' linkfd=',I6) -C CALL MYWRT(IOERR,BUFFER) -C 42 CONTINUE -C -C -C -C Scan linked lists of rows in order of increasing number -C of nonzero entries. -C ELROWS is the number of already eliminated rows + 1. - ELROWS=1 - DO 200 DEGREE=1,M -C - IROW=DGHEAD(DEGREE) - 100 IF(IROW.EQ.0) GO TO 200 -C WRITE(BUFFER,101) IROW,DEGREE -C 101 FORMAT(1X,'CHEAP: row',I6,' has degree=',I6) -C CALL MYWRT(IOERR,BUFFER) -C -C Eliminate row IROW (save its position in a permuted matrix). - INVP(IROW)=ELROWS - ELROWS=ELROWS+1 - IROW=LINKFD(IROW) - GO TO 100 -C - 200 CONTINUE -C -C -C -C The heuristic is completed. -C Set the permutation vector. - DO 300 I=1,M - K=INVP(I) - PERM(K)=I - 300 CONTINUE -C -C -C - RETURN -C -C -C -C *** LAST CARD OF (CHEAP) *** - END //GO.SYSIN DD hopdm.src/cheap.f echo hopdm.src/cntaat.f 1>&2 sed >hopdm.src/cntaat.f <<'//GO.SYSIN DD hopdm.src/cntaat.f' 's/^-//' -C******************************************************************* -C **** CNTAAT ... COUNT NONZERO ENTRIES OF A*Atransp **** -C******************************************************************* -C - SUBROUTINE CNTAAT(M,MAXM,MAXN,MAXNZA,NZL, - X TRIANG,AATPNT,MARKER,TEMP,STAVAR, - X CLPNTS,RWNMBS,RWHEAD,RWLINK,CLNMBS,LENCOL,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 M,MAXM,MAXN,MAXNZA,NZL,TRIANG,IOERR - INTEGER*4 AATPNT(MAXM+1),MARKER(MAXM),TEMP(MAXM) - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM+1),RWLINK(MAXNZA) -C -C *** The following arrays can be half-length integer. - INTEGER*2 STAVAR(MAXN) - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) -C -C -C *** LOCAL VARIABLES - INTEGER*4 IROW,IR,K,KBEG,KEND,JCOL,J - INTEGER*4 LENAAT,LENROW - CHARACTER*100 BUFFER -C -C -C *** COMMON ARREAS -C Markers for linking rows. -C COMMON /ICGRAD/ MSPLIT(100000) -C INTEGER*2 MSPLIT -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C TRIANG Indicator of how much of A*Atransp sparsity pattern -C is required: -C 0 if square matrix (except its diagonal) is needed; -C 1 if only strictly upper triangle is needed. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k free variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicate the position of the original variable. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C LENCOL Lengths of columns of matrix A. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C NZL Number of nonzero entries in adjacency structure -C A*Atransp. -C AATPNT Pointers to rows of A*Atransp. -C -C -C WORK ARRAYS: -C MARKER Array used to mark the rows of A that are adjacent -C to a given one. -C TEMP Array used to handle sparsity structure of rows. -C -C -C *** SUBROUTINES CALLED: -C MYWRT -C -C -C *** PURPOSE: -C This routine counts nonzeros of adjacency structure A*Atransp. -C -C -C *** NOTES: -C 1. Two different rows i and j are said to be adjacent -C if there exists a column in which they both have -C a nonzero entry. The sparsity pattern array AATPAT -C contains then an entry j in row i (and, by symmetry, -C an entry i in row j, if a square matrix is built). -C -C -C *** REFERENCES: -C Duff I.S., Erisman A.M., Reid J.K. (1989). Direct methods -C for sparse matrices, Clarendon Press, Oxford 1989, -C chapters 2 and 10. -C Gondzio J. (1993). Implementing Cholesky factorization for -C interior point methods of linear programming, Optimization -C 27, pp. 121-140. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: May 19, 1992 -C Last modified: March 16, 1995 -C -C -C -C *** BODY OF (CNTAAT) *** -C -C -C -C -C Initialize for building the sparsity pattern of A*Atransp. -C Zero MARKER array (it will indicate rows adjacent -C to a given one). - DO 100 IROW=1,M - MARKER(IROW)=0 - 100 CONTINUE -C -C -C Set the parameters controlling the progress -C of building AATPAT array. -C LENAAT is the current length of AATPAT array. -C LENROW is the length of a given row of AATPAT array. - LENAAT=0 - LENROW=0 -C -C -C -C -C -C Main loop begins here (loop over rows of A). -C For every row IROW, a list of other rows adjacent -C to a given one is created. Row IROW itself is omitted. - DO 500 IROW=1,M - LENROW=0 - AATPNT(IROW)=LENAAT+1 - MARKER(IROW)=1 -C -C -C Scan row IROW. Every column that intersects it, indicates -C rows adjacent to a given one. Every row that appears -C for the first time may then be added to the temporary -C list of rows adjacent to IROW. - J=RWHEAD(IROW) - 200 IF(J.EQ.0) GO TO 350 - JCOL=CLNMBS(J) -C -C Omit fixed columns. - IF(STAVAR(JCOL).EQ.6) GO TO 300 - KBEG=CLPNTS(JCOL) - KEND=KBEG+LENCOL(JCOL)-1 - DO 250 K=KBEG,KEND - IR=RWNMBS(K) - IF(MARKER(IR).EQ.1) GO TO 250 -C -C Omit adjacencies of linking and structural rows. -C IF(MSPLIT(IR)+MSPLIT(IROW).GE.1) GO TO 250 -C -C Here if the row appears for the first time. -C Add it to the adjacency list and mark the adjacent row. - LENROW=LENROW+1 - TEMP(LENROW)=IR - MARKER(IR)=1 - 250 CONTINUE - 300 J=RWLINK(J) - GO TO 200 -C -C Restore zero value of MARKER array. - 350 IF(LENROW.EQ.0) GO TO 450 - DO 400 K=1,LENROW - LENAAT=LENAAT+1 - IR=TEMP(K) - MARKER(IR)=0 - 400 CONTINUE -C -C Decide how much of the sparsity pattern of A*Atransp -C is required. If only upper triangle of it is to be built, -C then all rows that have already been scanned should -C be excluded from further search. - 450 IF(TRIANG.EQ.0) MARKER(IROW)=0 -C -C -C -C -C -C End of main loop. - 500 CONTINUE - AATPNT(M+1)=LENAAT+1 -C -C -C -C -C Write problem statistics. - NZL=LENAAT/2 - IF(TRIANG.EQ.1) NZL=LENAAT - WRITE(BUFFER,501) NZL - 501 FORMAT(1X,'CNTAAT: A*Atransp will have ',I13, - X ' subdiagonal elts.') - CALL MYWRT(IOERR,BUFFER) -C -C -C - RETURN -C -C -C -C *** LAST CARD OF (CNTAAT) *** - END //GO.SYSIN DD hopdm.src/cntaat.f echo hopdm.src/dattim.f 1>&2 sed >hopdm.src/dattim.f <<'//GO.SYSIN DD hopdm.src/dattim.f' 's/^-//' - subroutine dattim(job,nout,eltime) -C Subroutine writes current time and date. -C nout denotes number of file, if nout is negative there are no writing. -C If job=0 then sets elapsed time equal zero. -C If job<>0 then sets eltime:=number of seconds after last secnds call -C Written by Anna Altman -C Date of lst modification: May 6, 1992. - integer job,nout - real eltime(3),t0,t1,secnds,tar(2),dtime - character*24 dati,fdate -C -C -C *** VARIABLES FOR MYWRT ROUTINE - CHARACTER*100 BUFFER -C -C character*9 dmy -C character*8 hmr -C Computing date -C call date(dmy) -C Computing current time -C call time(hmr) -C Compute current date & time - dati=fdate() - t1=dtime(tar) - t0=0.0 - if(job.eq.0) then -C eltime=secnds(t0) -C t1=t0 - eltime(1)=t0 - eltime(2)=t0 - eltime(3)=t0 - else -C eltime=secnds(eltime) - eltime(1)=eltime(1)+t1 - eltime(2)=eltime(2)+tar(1) - eltime(3)=eltime(3)+tar(2) -C t1=eltime - endif - if(nout.lt.0) return - WRITE(BUFFER,101) dati,eltime - 101 format(1X,A24,' Elapsed tm (u+s): ',f10.2,' (',f10.2, - X '+',f8.2,')') - CALL MYWRT(NOUT,BUFFER) - return - end //GO.SYSIN DD hopdm.src/dattim.f echo hopdm.src/daxpy.f 1>&2 sed >hopdm.src/daxpy.f <<'//GO.SYSIN DD hopdm.src/daxpy.f' 's/^-//' -C****************************************************************** -C **** DAXPY ... (dense)Y = ALPHA * (dense)X + (dense)Y **** -C****************************************************************** -C - SUBROUTINE DAXPY(X,Y,K,ALPHA) -C -C *** PARAMETERS - INTEGER*4 K - DOUBLE PRECISION X(*),Y(*),ALPHA -C -C *** LOCAL VARIABLES - INTEGER*4 I -C -C *** PURPOSE -C This routine computes the following sum: -C (dense)Y = ALPHA * (dense)X + (dense)Y -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: March 24, 1992 -C -C *** BODY OF (DAXPY) *** -C - DO 100 I=1,K - Y(I)=Y(I)+ALPHA*X(I) - 100 CONTINUE - RETURN -C -C *** LAST CARD OF (DAXPY) *** - END //GO.SYSIN DD hopdm.src/daxpy.f echo hopdm.src/dcopy.f 1>&2 sed >hopdm.src/dcopy.f <<'//GO.SYSIN DD hopdm.src/dcopy.f' 's/^-//' -C************************************************************* -C **** DCOPY ... COPY DENSE VECTOR ONTO ANOTHER ONE **** -C************************************************************* -C - SUBROUTINE DCOPY(X,Y,K) -C -C *** PARAMETERS - INTEGER*4 K - DOUBLE PRECISION X(*),Y(*) -C -C *** LOCAL VARIABLES - INTEGER*4 I -C -C *** PURPOSE -C This routine copies dense vector X onto another one Y. -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: March 24, 1992 -C -C *** BODY OF (DCOPY) *** -C - DO 100 I=1,K - Y(I)=X(I) - 100 CONTINUE - RETURN -C -C *** LAST CARD OF (DCOPY) *** - END //GO.SYSIN DD hopdm.src/dcopy.f echo hopdm.src/ddot.f 1>&2 sed >hopdm.src/ddot.f <<'//GO.SYSIN DD hopdm.src/ddot.f' 's/^-//' -C************************************************************** -C **** DDOT ... DENSE INNER PRODUCT OF TWO VECTORS **** -C************************************************************** -C - SUBROUTINE DDOT(X,Y,K,PROD) -C -C *** PARAMETERS - INTEGER*4 K - DOUBLE PRECISION X(*),Y(*),PROD -C -C *** LOCAL VARIABLES - INTEGER*4 I -C -C *** PURPOSE -C This routine computes the scalar product -C of two dense vectors X and Y. -C -C -C *** PARAMETERS DESCRIPTION -C ON INPUT: -C X The first (dense) vector. -C Y The second (dense) vector. -C K Dimension of vectors X and Y. -C ON OUTPUT: -C PROD Scalar product of vectors X and Y. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C -C and Dominique Tachat, LAMSADE, -C University of Paris Dauphine, -C Place du Marechal de Lattre de Tassigny, -C 75775 Paris Cedex 16, France. -C -C Last modified: March 24, 1992 -C -C -C -C -C *** BODY OF (DDOT) *** -C - PROD=0. - DO 100 I=1,K - PROD=PROD+X(I)*Y(I) - 100 CONTINUE - RETURN -C -C *** LAST CARD OF (DDOT) *** - END //GO.SYSIN DD hopdm.src/ddot.f echo hopdm.src/defaat.f 1>&2 sed >hopdm.src/defaat.f <<'//GO.SYSIN DD hopdm.src/defaat.f' 's/^-//' -C******************************************************************* -C **** DEFAAT ... DEFINE SPARSITY PATTERN OF A*Atransp **** -C******************************************************************* -C - SUBROUTINE DEFAAT(AATPAT,AATPNT,ITEMP0, - X MAXNZL,MAXM,MAXN,MAXNZA,M,TRIANG, - X MARKER,TEMP,STAVAR, - X CLPNTS,RWNMBS,RWHEAD,RWLINK,CLNMBS,LENCOL,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXNZL,MAXM,MAXN,MAXNZA,M,TRIANG,IOERR - INTEGER*4 AATPNT(MAXM+1),ITEMP0(MAXNZL) - INTEGER*4 MARKER(MAXM),TEMP(MAXM) - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM+1),RWLINK(MAXNZA) -C -C *** The following arrays can be half-length integer. - INTEGER*2 STAVAR(MAXN),AATPAT(MAXNZL) - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) -C -C -C *** LOCAL VARIABLES - INTEGER*4 IROW,IR,K,KBEG,KEND,JCOL,J,IPOS - INTEGER*4 LENAAT,LENROW - REAL A1,A2 - CHARACTER*100 BUFFER -C -C -C *** COMMON ARREAS -C Markers for linking rows. -C COMMON /ICGRAD/ MSPLIT(100000) -C INTEGER*2 MSPLIT -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C TRIANG Indicator of how much of A*Atransp sparsity pattern -C is required: -C 0 if square matrix (except its diagonal) is needed; -C 1 if only strictly upper triangle is needed. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k free variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicate the position of the original variable. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C LENCOL Lengths of columns of matrix A. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C AATPAT Sparsity pattern of A*Atransp handled as -C a collection of sparse row vectors (diagonal -C elements are excluded from the list). -C AATPNT Pointers to rows of A*Atransp. -C -C WORK ARRAYS: -C ITEMP0 Array used to handle unordered sparsity pattern -C of A*Atransp. -C MARKER Array used to mark the rows of A that are -C adjacent to a given row. -C TEMP Temporary array. At the beginning it is used -C to handle sparsity structure of rows. Later -C it is used to control the reordering within rows. -C -C -C *** SUBROUTINES CALLED: -C MYWRT,DTSORT -C -C -C *** PURPOSE: -C This routine sets up the sparsity pattern of A*Atransp -C that is later used by the minimum degree routine MDO. -C -C -C *** NOTES: -C 1. Two different rows i and j are said to be adjacent -C if there exists a column in which they both have -C a nonzero entry. The sparsity pattern array AATPAT -C contains then an entry j in row i (and, by symmetry, -C an entry i in row j, if a square matrix is built). -C 2. Having created the sparsity structure of A*Atransp -C by rows in ITEMP0 array, we additionally scan the matrix -C to obtain column increasing order within each row -C (see e.g. Duff et al. (1989), section 2.10). -C -C -C *** REFERENCES: -C Duff I.S., Erisman A.M., Reid J.K. (1989). Direct methods -C for sparse matrices, Clarendon Press, Oxford 1989, -C chapters 2 and 10. -C Gondzio J. (1993). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization 27, pp. 121-140. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: March 19, 1991 -C Last modified: March 28, 1995 -C -C -C -C *** BODY OF (DEFAAT) *** -C -C -C -C -C Initialize for building the sparsity pattern of A*Atransp. -C Zero MARKER array (it will indicate rows adjacent -C to a given one). - DO 100 IROW=1,M - MARKER(IROW)=0 - 100 CONTINUE -C -C -C Set the parameters controlling the progress -C of building AATPAT array. -C LENAAT is the current length of AATPAT array. -C LENROW is the length of a given row of AATPAT array. - LENAAT=0 - LENROW=0 -C -C -C -C -C -C Main loop begins here (loop over rows of A). -C For every row IROW, a list of other rows adjacent -C to a given one is created. Row IROW itself is omitted. - DO 500 IROW=1,M - LENROW=0 - AATPNT(IROW)=LENAAT+1 - MARKER(IROW)=1 -C -C -C Scan row IROW. Every column that intersects it, indicates -C rows adjacent to a given one. Every row that appears -C for the first time may then be added to the temporary -C list of rows adjacent to IROW. - J=RWHEAD(IROW) - 200 IF(J.EQ.0) GO TO 350 - JCOL=CLNMBS(J) -C -C Omit fixed columns. -C IF(STAVAR(JCOL).EQ.6) GO TO 300 - KBEG=CLPNTS(JCOL) - KEND=KBEG+LENCOL(JCOL)-1 - DO 250 K=KBEG,KEND - IR=RWNMBS(K) - IF(MARKER(IR).EQ.1) GO TO 250 -C -C Omit adjacencies of linking and structural rows. -C IF(MSPLIT(IR)+MSPLIT(IROW).GE.1) GO TO 250 -C -C Here if the row appears for the first time. -C Add it to the adjacency list and mark the adjacent row. - LENROW=LENROW+1 - TEMP(LENROW)=IR - MARKER(IR)=1 - 250 CONTINUE - 300 J=RWLINK(J) - GO TO 200 -C -C Copy the adjacency list to ITEMP0 array. -C Restore zero value of MARKER array. - 350 IF(LENROW.EQ.0) GO TO 450 - IF(LENAAT+LENROW.GT.MAXNZL) GO TO 9000 - DO 400 K=1,LENROW - LENAAT=LENAAT+1 - IR=TEMP(K) - ITEMP0(LENAAT)=IR - MARKER(IR)=0 - 400 CONTINUE -C -C Decide how much of the sparsity pattern of A*Atransp -C is required. If only upper triangle of it is to be built, -C then all rows that have already been scanned should -C be excluded from further search. - 450 IF(TRIANG.EQ.0) MARKER(IROW)=0 -C -C -C -C -C -C End of main loop. - 500 CONTINUE - AATPNT(M+1)=LENAAT+1 -C -C -C *** DEBUGGING -C DO 510 IR=1,M -C KBEG=AATPNT(IR) -C KEND=AATPNT(IR+1)-1 -C IF(KBEG.GT.KEND) GO TO 510 -C WRITE(IOERR,505) IR,(ITEMP0(K),K=KBEG,KEND) -C 505 FORMAT(1X,' List of rows adjacent to row: ',I6/(1X,10I6)) -C 510 CONTINUE -C -C -C -C -C Sort the sparsity pattern of each row of AATPAT array -C with increasing order of column numbers. -C Decide what type of sort have to be done. - IF(TRIANG.EQ.1) GO TO 700 -C -C -C Here if square matrix is to be built. -C Set TEMP array to just after where each row -C ends in a collection of rows. - DO 550 IR=1,M - TEMP(IR)=AATPNT(IR+1) - 550 CONTINUE - DO 650 IROW=M,1,-1 - KBEG=AATPNT(IROW) - KEND=AATPNT(IROW+1)-1 - DO 600 K=KBEG,KEND - IR=ITEMP0(K) - IPOS=TEMP(IR)-1 - TEMP(IR)=IPOS - AATPAT(IPOS)=IROW - 600 CONTINUE - 650 CONTINUE - GO TO 1000 -C -C -C Here if triangular matrix is to be built. -C Go perform a double transpose sort. - 700 DO 800 K=1,LENAAT - AATPAT(K)=ITEMP0(K) - 800 CONTINUE -C -C SUBROUTINE DTSORT(ROWNBS,COLPTS, -C X ICLNBS,IRWPTS,MAXNZ,MAXM,M,IOERR) -C - CALL DTSORT(AATPAT,AATPNT, - X ITEMP0(1),TEMP,MAXNZL,MAXM,M,IOERR) -C -C -C -C -C Write problem statistics. - 1000 K=LENAAT/2 - A1=LENAAT*100.0 - IF(TRIANG.EQ.1) THEN - K=LENAAT - A1=A1*2.0 - ENDIF - A2=M*M-M - IF(M.GT.1) THEN - A1=A1/A2 - ELSE - A1=0.0 - ENDIF - WRITE(BUFFER,1001) K,A1 - 1001 FORMAT(1X,'DEFAAT: A*Atransp has ',I13, - X ' subdiagonal elts (density=',F5.1,'%).') - CALL MYWRT(IOERR,BUFFER) -C -C -C *** DEBUGGING -C WRITE(IOERR,902) -C 902 FORMAT(1x,'DEFAAT: Matrix after reordering within the rows.'/) -C DO 904 IR=1,M -C KBEG=AATPNT(IR) -C KEND=AATPNT(IR+1)-1 -C IF(KBEG.GT.KEND) GO TO 904 -C WRITE(IOERR,903) IR,(AATPAT(K),K=KBEG,KEND) -C 903 FORMAT(1X,' List of rows adjacent to row: ',I6/(1X,10I6)) -C 904 CONTINUE -C -C -C - RETURN -C -C -C Here to write error message. - 9000 WRITE(BUFFER,9001) LENAAT+LENROW - 9001 FORMAT(1X,'DEFAAT ERROR: A*Atransp overflow',I10) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9002) MAXNZL - 9002 FORMAT(1X,' space was provided for only ',I10,' nonzeros.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C -C -C *** LAST CARD OF (DEFAAT) *** - END //GO.SYSIN DD hopdm.src/defaat.f echo hopdm.src/detspl.f 1>&2 sed >hopdm.src/detspl.f <<'//GO.SYSIN DD hopdm.src/detspl.f' 's/^-//' -C***************************************************************** -C *** DETSPL ... DETERMINE PREFERABLE LENGTH OF DENSE COLS *** -C***************************************************************** -C - SUBROUTINE DETSPL(IOERR, - X MAXM,MAXN,M,N,NSTRCT, - X MAXCOL,LENCOL,STAVAR) -C -C -C *** PARAMETERS - INTEGER*4 IOERR,MAXM,MAXN,M,N,NSTRCT,MAXCOL - INTEGER*2 LENCOL(MAXN),STAVAR(MAXN) -C -C *** LOCAL VARIABLES - INTEGER*4 J,K,NCOL,NONZ,MAXLEN - CHARACTER*100 BUFFER -C -C *** PARAMETERS DESCRIPTION -C -C *** ON INPUT: -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C MAXM Maximum number of constraints. -C MAXN Maximum number of variables. -C M Number of constraints. -C N Number of variables (total, i.e. including slacks, -C surplus and artificials). -C NSTRCT Number of structural variables (excluding slacks, -C surplus and artificials). -C MAXCOL A suggested length of dense columns after splitting. -C LENCOL Lengths of (sparse) columns of matrix A. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C -C *** ON OUTPUT: -C MAXCOL Preferable length of dense columns after splitting. -C -C -C *** PURPOSE -C This routine determines the "reasonable" length of dense columns -C after splitting heuristic. -C -C *** SUBROUTINES CALLED -C -C *** NOTES -C -C *** REFERENCES: -C Gondzio J. (1992). Splitting dense columns of the constraint -C matrix in interior point methods for large scale linear -C programming, Optimization 24, pp. 285-297. -C Gondzio J. (1994). Analysis of linear programs prior to applying -C the interior point method, Technical Report, -C Department of Management Studies, University of Geneva, -C 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, February 1994. -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: March 28, 1995 -C -C -C -C -C *** BODY OF (DETSPL) *** -C -C Determine the number of columns longer than MAXCOL, -C the number of nonzero entries in them -C and the column with tha maximum length. - NCOL=0 - NONZ=0 - MAXLEN=0 - DO 100 J=1,NSTRCT - IF(STAVAR(J).GE.6) GO TO 100 - IF(STAVAR(J).LT.0) THEN - K=-STAVAR(J) - IF(J.GE.K) GO TO 100 - ENDIF - IF(LENCOL(J).GT.MAXLEN) MAXLEN=LENCOL(J) - IF(LENCOL(J).LT.MAXCOL) GO TO 100 - NCOL=NCOL+1 - NONZ=NONZ+LENCOL(J) - 100 CONTINUE -C -C Determine the number of entries in split dense columns. - IF(NCOL.EQ.0) GO TO 200 -C - MAXCOL=80 - IF(MAXLEN.GE.200) MAXCOL=MAXLEN/2+1 - IF(MAXLEN.GE.300) MAXCOL=MAXLEN/3+1 - IF(MAXLEN.GE.400) MAXCOL=MAXLEN/4+1 - IF(MAXLEN.GE.500) MAXCOL=MAXLEN/5+1 - IF(MAXLEN.GE.1000) MAXCOL=200 -C - 200 CONTINUE -C WRITE(BUFFER,201) NCOL,MAXLEN,MAXCOL -C 201 FORMAT(1X,'DETSPL: NCOL=',I6,' MAXLEN=',I6,' MAXCOL=',I6) -C CALL MYWRT(IOERR,BUFFER) -C CALL MYWRT(0,BUFFER) -C CALL MYWRT(99,BUFFER) - RETURN -C -C *** LAST CARD OF (DETSPL) *** - END //GO.SYSIN DD hopdm.src/detspl.f echo hopdm.src/dtsort.f 1>&2 sed >hopdm.src/dtsort.f <<'//GO.SYSIN DD hopdm.src/dtsort.f' 's/^-//' -C***************************************************** -C **** DTSORT ... DUOBLE TRANSPOSE SORT **** -C***************************************************** -C - SUBROUTINE DTSORT(ROWNBS,COLPTS, - X ICLNBS,IRWPTS,MAXNZ,MAXM,M,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXNZ,MAXM,M,IOERR - INTEGER*4 COLPTS(MAXM+1),IRWPTS(MAXM+1) -C -C *** The following arrays can be half-length integer. - INTEGER*2 ROWNBS(MAXNZ),ICLNBS(MAXNZ) -C -C -C *** LOCAL VARIABLES - INTEGER*4 IROW,JCOL,K,KBEG,KEND,IPOS,NONZ -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C ROWNBS Row numbers of nonzeros in columns of the matrix -C (unordered within columns). -C COLPTS Pointers to the beginning of columns of the matrix. -C MAXNZ Maximum number of nonzeros of the matrix. -C MAXM Maximum dimension of the matrix. -C M Dimension of the matrix. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C ROWNBS Row numbers of nonzeros in columns of the matrix -C (with an increasing order of row numbers). -C COLPTS Pointers to the beginning of columns of the matrix. -C -C WORK ARRAYS: -C ICLNBS Column numbers of nonzeros in rows of the matrix -C IRWPTS Pointers to the beginning of rows of the matrix. -C -C -C *** SUBROUTINES CALLED: -C NONE -C -C -C *** PURPOSE: -C This routine implements a double transpose sort of a given -C matrix handled as a collection of sparse columns to obtain -C the increasing order of row numbers within each column. -C -C -C *** NOTES: -C -C -C *** REFERENCES: -C Duff I.S., Erisman A.M., Reid J.K. (1989). Direct methods -C for sparse matrices, Clarendon Press, Oxford 1989, -C chapter 2. -C Gondzio J. (1993). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization 27, pp. 121-140. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: March 26, 1991 -C Last modified: January 20, 1994 -C -C -C -C *** BODY OF (DTSORT) *** -C -C -C -C Determine the number of matrix nonzero entries. - NONZ=COLPTS(M+1)-1 -C -C -C -C -C *** First transposition. -C Transpose the matrix to obtain the collection of sparse rows. -C Count the row lengths. - DO 700 IROW=1,M - IRWPTS(IROW)=0 - 700 CONTINUE - DO 740 K=1,NONZ - IROW=ROWNBS(K) - IRWPTS(IROW)=IRWPTS(IROW)+1 - 740 CONTINUE -C -C Set IRWPTS array to indicate the positions just after every row. - IRWPTS(1)=IRWPTS(1)+1 - DO 760 IROW=2,M - IRWPTS(IROW)=IRWPTS(IROW)+IRWPTS(IROW-1) - 760 CONTINUE - IRWPTS(M+1)=IRWPTS(M) -C -C Move the matrix to a form of a collection of sparse rows. - DO 800 JCOL=1,M - KBEG=COLPTS(JCOL) - KEND=COLPTS(JCOL+1)-1 - DO 780 K=KBEG,KEND - IROW=ROWNBS(K) - IPOS=IRWPTS(IROW)-1 - IRWPTS(IROW)=IPOS - ICLNBS(IPOS)=JCOL - 780 CONTINUE - 800 CONTINUE -C -C -C -C -C *** Second transposition. -C Transpose the matrix back to the collection of sparse columns. -C Set COLPTS array to indicate the positions just after every column. - DO 820 JCOL=1,M - COLPTS(JCOL)=COLPTS(JCOL+1) - 820 CONTINUE -C -C Move the matrix back to a form of a collection of sparse columns. - DO 860 IROW=M,1,-1 - KBEG=IRWPTS(IROW) - KEND=IRWPTS(IROW+1)-1 - DO 840 K=KBEG,KEND - JCOL=ICLNBS(K) - IPOS=COLPTS(JCOL)-1 - COLPTS(JCOL)=IPOS - ROWNBS(IPOS)=IROW - 840 CONTINUE - 860 CONTINUE -C -C -C -C - RETURN -C -C -C -C *** LAST CARD OF (DTSORT) *** - END //GO.SYSIN DD hopdm.src/dtsort.f echo hopdm.src/dtsrta.f 1>&2 sed >hopdm.src/dtsrta.f <<'//GO.SYSIN DD hopdm.src/dtsrta.f' 's/^-//' -C********************************************************** -C *** DTSRTA ... DUOBLE TRANSPOSE SORT OF MATRIX A *** -C********************************************************** -C - SUBROUTINE DTSRTA(MAXM,MAXN,MAXNZA,M,N, - X ACOEFF,CLPNTS,RWNMBS,LENCOL, - X RWHEAD,RWLINK,CLNMBS, - X ACOPY,CPCOPY,STAVAR,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXM,MAXN,MAXNZA,M,N,IOERR - DOUBLE PRECISION ACOEFF(MAXNZA),ACOPY(MAXNZA) - INTEGER*4 CLPNTS(MAXN+1),CPCOPY(MAXN+1) - INTEGER*4 RWHEAD(MAXM+1),RWLINK(MAXNZA) -C -C *** The following arrays can be half-length integer. - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) - INTEGER*2 STAVAR(MAXN) -C -C -C *** LOCAL VARIABLES - INTEGER*4 IROW,JCOL,K,KBEG,KEND,IPOS,NONZ - CHARACTER*100 BUFFER -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of rows of the LP constraint matrix. -C N Number of columns of the LP constraint matrix. -C ACOEFF Nonzero entries of an LP constraint matrix. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C RWHEAD Headers to the row linked lists of entries of matrix A. -C RWLINK Row linked lists of entries of matrix A. -C CLNMBS Column numbers of nonzeros in a given row of matrix A. -C LENCOL Lengths of columns of matrix A. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k free variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicate the position of the original variable. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C Reordered LP constraint matrix. -C ACOEFF Nonzero entries of an LP constraint matrix. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A -C (in an increasing order). -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C -C WORK ARRAYS: -C ACOPY A copy of nonzero entries of an LP constraint matrix. -C CPCOPY A copy of pointers to the beginning of columns of A. -C -C -C *** SUBROUTINES CALLED: -C NONE -C -C -C *** PURPOSE: -C This routine implements a double transpose sort of matrix -C A handled as a collection of sparse columns to obtain the -C increasing order of row numbers within each column. -C -C -C *** NOTES: -C We assume that a row-wise access to matrix A is ensured via -C RWHEAD, RWLINK and CLNMBS arrays on entry to this routine. -C Hence we can omit the first transpose. -C -C -C *** REFERENCES: -C Duff I.S., Erisman A.M., Reid J.K. (1989). Direct methods -C for sparse matrices, Clarendon Press, Oxford 1989, -C chapter 2. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: January 20, 1994 -C -C -C -C *** BODY OF (DTSRTA) *** -C -C -C -C Determine the number of matrix nonzero entries. - NONZ=CLPNTS(N+1)-1 -C -C Save copy of nonzero entries of A. - DO 100 K=1,NONZ - ACOPY(K)=ACOEFF(K) - 100 CONTINUE -C -C Save copy of pointers to the beginning of columns of A. - DO 200 JCOL=1,N+1 - CPCOPY(JCOL)=CLPNTS(JCOL) - 200 CONTINUE -C -C Move the matrix back to a form of a collection of sparse -C columns. Access rows in an increasing order. - DO 500 IROW=1,M - K=RWHEAD(IROW) - 400 IF(K.LE.0) GO TO 500 - JCOL=CLNMBS(K) - IPOS=CPCOPY(JCOL) - RWNMBS(IPOS)=IROW - ACOEFF(IPOS)=ACOPY(K) - CPCOPY(JCOL)=CPCOPY(JCOL)+1 - K=RWLINK(K) - GO TO 400 - 500 CONTINUE -C -C Restore row linked lists for matrix A. - DO 600 IROW=1,M - RWHEAD(IROW)=0 - 600 CONTINUE - DO 800 JCOL=1,N -C -C Omit all FIXED variables. - IF(STAVAR(JCOL).GE.6) GO TO 800 - KBEG=CLPNTS(JCOL) - KEND=KBEG+LENCOL(JCOL)-1 - DO 700 K=KBEG,KEND - IROW=RWNMBS(K) - RWLINK(K)=RWHEAD(IROW) - RWHEAD(IROW)=K - 700 CONTINUE - 800 CONTINUE -C -C *** DEBUGGING -C DO 940 JCOL=1,N -C IF(STAVAR(JCOL).GE.6) GO TO 940 -C KBEG=CLPNTS(JCOL) -C KEND=KBEG+LENCOL(JCOL)-2 -C DO 920 K=KBEG,KEND -C IF(RWNMBS(K+1).LE.RWNMBS(K)) THEN -C WRITE(BUFFER,921) JCOL,K,RWNMBS(K),RWNMBS(K+1) -C 921 FORMAT(1X,'cl=',I6,' pos=',I6,' rw1=',I6,' rw2=',I6) -C CALL MYWRT(IOERR,BUFFER) -C STOP -C ENDIF -C 920 CONTINUE -C 940 CONTINUE -C - RETURN -C -C -C -C *** LAST CARD OF (DTSRTA) *** - END //GO.SYSIN DD hopdm.src/dtsrta.f echo hopdm.src/elcnst.f 1>&2 sed >hopdm.src/elcnst.f <<'//GO.SYSIN DD hopdm.src/elcnst.f' 's/^-//' -C******************************************************* -C *** ELCNST ... ELIMINATE REDUNDANT CONSTRAINTS *** -C******************************************************* -C - SUBROUTINE ELCNST(IOERR,MSGLEV,LEVPRS, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X RWORK,IWORK,RMAP,IMAP,IROW,RELT, - X IMTMP1,INTMP1,INTMP2,RMTMP1,RNTMP1, - X B,RANGES,C,LOBND,UPBND,BNDBIG, - X ACOEFF,CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X P,Q,PRLVAR,STAVAR,RWSTAT,STAROW,RWNAME,CLNAME, - X PERM,INVP,LENROW) -C -C -C -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(*),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(*) -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real array that contains real LP problem data. -C IWORK Integer array that contains integer LP problem data. -C RMAP Map of RWORK array. -C IMAP Map of IWORK array. -C -C -C -C -C *** PARAMETERS - INTEGER*4 IOERR,MSGLEV,LEVPRS,MAXM,MAXN,MAXNZA - INTEGER*4 M,N,NSTRCT,LNHIST,MXHIST - INTEGER*2 INHIST(MXHIST) - DOUBLE PRECISION DPHIST(MXHIST) - INTEGER*4 IROW(MAXN),IMTMP1(MAXM),INTMP1(MAXN) - INTEGER*2 INTMP2(MAXN) - DOUBLE PRECISION RELT(MAXN),RMTMP1(MAXM),RNTMP1(MAXN) - DOUBLE PRECISION ACOEFF(MAXNZA),B(MAXM),RANGES(MAXM) - DOUBLE PRECISION C(MAXN),LOBND(MAXN),UPBND(MAXN),BNDBIG - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM+1),RWLINK(MAXNZA) - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) - DOUBLE PRECISION P(MAXM),Q(MAXM),PRLVAR(MAXN) - CHARACTER*8 RWNAME(MAXM),CLNAME(MAXN) - INTEGER*2 STAVAR(MAXN),STAROW(MAXM),RWSTAT(MAXM) - INTEGER*2 INVP(MAXM),PERM(MAXM),LENROW(MAXM) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 ROWLEN,LIMIT,NFIXED,NELIM,NTIGHT,NT0,M1,N1 - INTEGER*4 I,IKX,IPOS,IR,IRUN,J,K,KOK,KOUT - INTEGER*4 KBEG,KEND,MNEW,KRWBEG,LNKUPD - INTEGER*4 NNEG,NPOS,NNEGBG,NPOSBG,KNEGBG,KPOSBG - DOUBLE PRECISION BIG,BIGNEW,X0,BNDNEW,BNDJUP,RHS0,RNRM - DOUBLE PRECISION BLOWER,BUPPER,FSBTOL,BNDTOL,SMALLA - CHARACTER*100 BUFFER - CHARACTER*2 RTYPE -C -C -C -C -C *** PARAMETERS DESCRIPTION -C -C *** ON INPUT: -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C MSGLEV The level of PRE_SOLVE information desired: -C 0 only final problem dimensions are printed; -C 1 numbers of eliminated rows and columns are printed; -C 2 names of eliminated rows and columns are printed; -C 3 detailed DEBUGGING information is printed. -C LEVPRS The level of PRE_SOLVE desired: -C 0 only splitting dense columns; -C 1 incomplete analysis (no tightening UPPER bounds); -C 2 maximum analysis possible. -C MAXM Maximum number of constraints. -C MAXN Maximum number of variables. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of constraints. -C N Number of variables (total, i.e. including slacks, -C surplus and artificials). -C NSTRCT Number of structural variables (excluding slacks, -C surplus and artificials). -C LNHIST Length of the PRE_SOLVE history list. -C MXHIST Maximum number of entries in the PRE_SOLVE history list. -C INHIST Integer PRE_SOLVE history information. -C DPHIST Double precision PRE_SOLVE history information. -C ACOEFF Array of nonzero elements for each column. -C B Right hand side of the linear program. -C RANGES Array of constraint ranges. -C C Objective function coefficients. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C LENCOL Lengths of (sparse) columns of matrix A. -C LOBND Array of lower bounds. -C UPBND Array of upper bounds. Note that the upper bound -C is changed when the variable has a lower bound. -C BNDBIG Value of an unacceptably large implicit bound. -C P LOWER bounds on shadow prices (dual variables). -C Q UPPER bounds on shadow prices (dual variables). -C PRLVAR Primal variables of the linear program. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C RWSTAT Array of row types: -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 objective row; -C 5 other free row. -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C RWNAME Array of row names (increasing order sort). -C CLNAME Array of column names (unordered). -C -C *** ON OUTPUT: -C -C -C -C -C *** WORK ARRAYS: -C IROW and RELT are the arrays for temporary handling of rows -C and columns of the constraint matrix. They are primarily -C intended to handle sparse vectors (in packed form) -C but may also be used for storing dense ones. -C IMTMP1 Integer work array of size MAXM. -C INTMP1 Integer work array of size MAXN -C INTMP2 Half-length integer work array of size MAXN. -C RMTMP1 Double precision work array of size MAXM. -C RNTMP1 Double precision work array of size MAXN. -C PERM Half-length integer work array of size MAXM. -C INVP Half-length integer work array of size MAXM. -C LENROW Half-length integer work array of size MAXM. -C -C -C -C -C *** PURPOSE -C This routine computes bounds on the LP constraints and uses -C them to eliminate redundant constraints. Next, it uses these -C values to adjust variables' bounds. -C -C -C -C *** SUBROUTINES CALLED -C MYWRT,GETCOL,GETROW,DABS,EMPTYR,REORDA,REORDI,REORDV -C -C -C *** NOTES -C This routine is given direct access to the matrix A. -C It alters hidden data structures. -C -C -C -C *** REFERENCES: -C Gondzio J. (1994). Presolve analysis of linear programs prior -C to applying an interior point method, Technical Report -C No 1994.3, Department of Management Studies, University -C of Geneva, 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, -C February 1994, revised in December 1994. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: May 17, 1993 -C Last modified: March 30, 1995 -C -C -C -C -C *** BODY OF (ELCNST) *** -C -C -C -C Initialize. - BIG=1.0D+30 - BIGNEW=1.0D+20 - FSBTOL=5.0D-8 - BNDTOL=1.0D-5 - SMALLA=1.0D-8 - NFIXED=0 - NELIM=0 - NTIGHT=0 -C - IF(MSGLEV.LE.3) GO TO 140 - DO 130 J=1,N - IF(STAVAR(J).LT.6) GO TO 130 - WRITE(BUFFER,131) J,LENCOL(J),STAVAR(J), - X LOBND(J),UPBND(J),PRLVAR(J) - 131 FORMAT(1X,'col=',I6,' ln=',I4,' st=',I6,' LO=',D10.3, - X ' UP=',D10.3,' X=',D10.3) - CALL MYWRT(IOERR,BUFFER) - 130 CONTINUE - 140 CONTINUE -C -C -C Compute norms of the LP constraints. - DO 150 I=1,M - RMTMP1(I)=1.0D-4+DABS(B(I)) - 150 CONTINUE - DO 180 J=1,NSTRCT - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 160 K=KBEG,KEND - I=RWNMBS(K) - IF(DABS(ACOEFF(K)).GT.RMTMP1(I)) RMTMP1(I)=DABS(ACOEFF(K)) - 160 CONTINUE - 180 CONTINUE - DO 190 I=1,M - RNRM=SMALLA*RMTMP1(I) - IF(RNRM.LE.FSBTOL) RNRM=FSBTOL - IF(RNRM.GE.1.0D-5) RNRM=1.0D-5 - IF(DABS(B(I)).LE.RNRM) B(I)=0.0D0 - IF(RMTMP1(I).LE.1.0E-15) GO TO 190 -C IF(RMTMP1(I).LE.1.0E-4) THEN -C WRITE(BUFFER,191) I,RMTMP1(I) -C 191 FORMAT(1X,' ELCNST: row=',I6,' has norm=',D10.3) -C CALL MYWRT(IOERR,BUFFER) -C ENDIF - 190 CONTINUE -C -C -C -C -C -C -C -C First main loop begins here. -C Loop over all LP constraints. -C Eliminate redundant constraints. -C LNKUPD equal to 1 forces update of row linked lists. - IRUN=1 - LNKUPD=0 - 200 NT0=NTIGHT - M1=M - DO 1000 I=1,M - ROWLEN=0 - KRWBEG=RWHEAD(I) - IPOS=KRWBEG - IF(RWSTAT(I).GE.2) THEN - ROWLEN=1 - IPOS=RWLINK(KRWBEG) - ENDIF -C -C Compute LOWER and UPPER limits of the LP constraint. -C Loop over nonzero entries of row I. - BLOWER=0.0D0 - BUPPER=0.0D0 - 300 IF(IPOS.EQ.0) GO TO 400 - ROWLEN=ROWLEN+1 - J=CLNMBS(IPOS) - K=STAVAR(J) - IF(K.GE.6) GO TO 350 - BNDJUP=BIG - IF(K.EQ.1.OR.K.EQ.3) BNDJUP=UPBND(J) - IF(ACOEFF(IPOS).LT.0.0D0) THEN - BLOWER=BLOWER+BNDJUP*ACOEFF(IPOS) - ELSE - BUPPER=BUPPER+BNDJUP*ACOEFF(IPOS) - ENDIF - 350 IPOS=RWLINK(IPOS) - GO TO 300 -C - 400 CONTINUE - RNRM=SMALLA*(RMTMP1(I)+DABS(B(I))) - IF(RNRM.LE.FSBTOL) RNRM=FSBTOL - IF(RNRM.GE.1.0D-5) RNRM=1.0D-5 - IF(DABS(BLOWER-B(I)).LE.RNRM) BLOWER=B(I) - IF(DABS(BUPPER-B(I)).LE.RNRM) BUPPER=B(I) - LENROW(I)=ROWLEN -C WRITE(BUFFER,401) I,RWNAME(I),ROWLEN,RWSTAT(I) -C 401 FORMAT(1X,'ELCNST: Row ',I6,' (name=',A8, -C X ') len=',I6,' RWSTAT=',I6) -C CALL MYWRT(IOERR,BUFFER) -C -C -C -C The following notation is used below: -C LIMIT = 0 corresponds to FORCING row (RHS = BLOWER); -C LIMIT = 1 corresponds to FORCING row (RHS = BUPPER); -C LIMIT = -1 corresponds to REDUNDANT row. - IF(RWSTAT(I).EQ.1) THEN -C -C Here for EQUALITY type constraint. - RTYPE='EQ' - IF(BLOWER-B(I).GT.-FSBTOL) THEN - IF(BLOWER-B(I).GT.FSBTOL) GO TO 9010 - LIMIT=0 - GO TO 500 - ENDIF - IF(BUPPER-B(I).LT.FSBTOL) THEN - IF(BUPPER-B(I).LT.-FSBTOL) GO TO 9010 - LIMIT=1 - GO TO 500 - ENDIF - GO TO 1000 - ENDIF -C -C -C - IF(RWSTAT(I).EQ.2) THEN -C -C Here for GREATER OR EQUAL type constraint. - RTYPE='GE' - IF(BUPPER-B(I).LT.FSBTOL) THEN - IF(BUPPER-B(I).LT.-FSBTOL) GO TO 9010 - LIMIT=1 - GO TO 500 - ENDIF - IF(BLOWER-B(I).GT.-FSBTOL) THEN -C -C Ranged row need to satify one more condition to be eliminated. - IF(RANGES(I).LE.BIGNEW) THEN - IF(BUPPER.GT.B(I)+RANGES(I)+FSBTOL) GO TO 1000 - ENDIF - LIMIT=-1 - GO TO 500 - ENDIF - ENDIF -C -C -C - IF(RWSTAT(I).EQ.3) THEN -C -C Here for LESS OR EQUAL type constraint. - RTYPE='LE' - IF(BLOWER-B(I).GT.-FSBTOL) THEN - IF(BLOWER-B(I).GT.FSBTOL) GO TO 9010 - LIMIT=0 - GO TO 500 - ENDIF - IF(BUPPER-B(I).LT.FSBTOL) THEN -C -C Ranged row need to satify one more condition to be eliminated. - IF(RANGES(I).LE.BIGNEW) THEN - IF(BLOWER.LT.B(I)-RANGES(I)-FSBTOL) GO TO 1000 - ENDIF - LIMIT=-1 - GO TO 500 - ENDIF - ENDIF -C -C -C - GO TO 1000 -C -C -C -C Here to eliminate the LP constraint. - 500 NELIM=NELIM+1 - RWHEAD(I)=-RWHEAD(I) -C -C *** DEBUGGING - IF(MSGLEV.LE.1) GO TO 505 - WRITE(BUFFER,501) I,RWNAME(I),RTYPE - 501 FORMAT(1X,'ELCNST: Row ',I6,' (name=',A8, - X ' type=',A2,') is eliminated.') - CALL MYWRT(IOERR,BUFFER) - IF(MSGLEV.LE.2) GO TO 505 - WRITE(BUFFER,502) I,ROWLEN,RTYPE,BLOWER,BUPPER,B(I) - 502 FORMAT(1X,'row=',I6,' ln=',I6,' type=',A2, - X ' BLO=',D10.3,' BUP=',D10.3,' RHS=',D10.3) - CALL MYWRT(IOERR,BUFFER) -C IF(RANGES(I).GE.BIGNEW) GO TO 505 - WRITE(BUFFER,503) I,RWNAME(I),RANGES(I) - 503 FORMAT(1X,'ELCNST: Row ',I6,' name=',A8,' range=',D12.6) - CALL MYWRT(IOERR,BUFFER) - 505 CONTINUE -C - IF(LIMIT.EQ.-1) THEN - NFIXED=NFIXED+1 - J=CLNMBS(KRWBEG) - STAVAR(J)=14 - PRLVAR(J)=0.0D0 - GO TO 1000 - ENDIF -C -C Here to eliminate the constraint and fix variables. -C Loop over nonzero entries of row I. - IPOS=KRWBEG - 600 IF(IPOS.EQ.0) GO TO 800 - J=CLNMBS(IPOS) - IF(STAVAR(J).GE.6) GO TO 750 - IF(ACOEFF(IPOS).LT.0.0D0) THEN - IF(LIMIT.EQ.0) X0=UPBND(J) - IF(LIMIT.EQ.1) X0=0.0D0 - ELSE - IF(LIMIT.EQ.0) X0=0.0D0 - IF(LIMIT.EQ.1) X0=UPBND(J) - ENDIF -C -C Fix and eliminate column J. Omit already FIXED variables. -C Update RHS array. - NFIXED=NFIXED+1 - PRLVAR(J)=X0 - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - IF(STAVAR(J).NE.1.AND.STAVAR(J).NE.3) THEN -C -C Reinitialize bounds on shadow prices. -C WRITE(BUFFER,701) J1,CLNAME(J1),STAVAR(J1) -C 701 FORMAT(1X,'ELCNST: Variable ',I6,' (name=',A8, -C X ' st=',I6,')') -C CALL MYWRT(IOERR,BUFFER) - DO 700 K=KBEG,KEND - IR=RWNMBS(K) - P(IR)=-BIG - Q(IR)=BIG - IF(RANGES(IR).LE.BIGNEW) GO TO 700 - IF(RWSTAT(IR).EQ.2) P(IR)=0.0D0 - IF(RWSTAT(IR).EQ.3) Q(IR)=0.0D0 - 700 CONTINUE - ENDIF - IF(DABS(X0).LE.FSBTOL) X0=0.0D0 - STAVAR(J)=6 - IF(J.GT.NSTRCT) THEN - STAVAR(J)=14 - PRLVAR(J)=0.0D0 - GO TO 720 - ENDIF - IF(DABS(X0).LE.FSBTOL) GO TO 720 - DO 710 K=KBEG,KEND - IR=RWNMBS(K) - B(IR)=B(IR)-X0*ACOEFF(K) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - 710 CONTINUE - 720 CONTINUE - IF(MSGLEV.LE.1) GO TO 722 - WRITE(BUFFER,721) J,CLNAME(J),X0 - 721 FORMAT(1X,'ELCNST: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 722 CONTINUE -C - 750 IPOS=RWLINK(IPOS) - GO TO 600 -C - 800 CONTINUE -C -C -C -C -C -C End of the first main loop. - 1000 CONTINUE - N1=NFIXED -C -C -C -C -C -C -C Determine the permutation that puts all empty and inactive -C rows at the end of the list. -C - I=3 - IF(MSGLEV.LE.1) I=4 - CALL EMPTYR(MAXM,M,MNEW,I, - X RWHEAD,STAROW,PERM,INVP,IOERR) -C -C -C Reorder the rows of the LP constraint matrix according to -C the permutation resulting from the analysis of EMPTYR. - IF(MNEW.LT.M) THEN -C - CALL REORDA(MAXM,MAXN,MAXNZA,M,N, - X CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X PERM,INVP,IMTMP1,IROW,RELT, - X RWNAME,STAROW,RWSTAT,RANGES,B,IOERR) -C -C Reorder bounds on shadow prices P and Q. - CALL REORDV(MAXM,M, - X PERM,INVP,P,RELT,IOERR) - CALL REORDV(MAXM,M, - X PERM,INVP,Q,RELT,IOERR) -C -C Reorder elements within each column of the LP constraint -C matrix in such a way that those of the active part of A -C are at the beginning of the lists. The column lengths will -C later be decreased to forget inactive part of matrix A. -C Set the new row linked lists of nonzero elements of matrix A. -C Recall that CLPNTS(j) indicates the first entry of column j. -C Zero RWHEAD and LENROW arrays. - DO 1200 I=1,M - RWHEAD(I)=0 - LENROW(I)=0 - 1200 CONTINUE -C -C Reorder nonzero elements within each column. - DO 1500 J=1,N - IF(STAVAR(J).GE.6) GO TO 1500 - KBEG=CLPNTS(J)-1 - KOK=0 - KOUT=0 - DO 1300 IKX=1,LENCOL(J) - K=KBEG+IKX - I=RWNMBS(K) - IF(I.LE.MNEW) THEN - KOK=KOK+1 - IROW(KOK)=RWNMBS(K) - RELT(KOK)=ACOEFF(K) - ELSE - IPOS=LENCOL(J)-KOUT - KOUT=KOUT+1 - IROW(IPOS)=RWNMBS(K) - RELT(IPOS)=ACOEFF(K) - ENDIF - 1300 CONTINUE - LENCOL(J)=KOK -C -C Set the row linked lists. -C Count nonzero elements in all rows of A. - DO 1400 IKX=1,LENCOL(J) - K=KBEG+IKX - I=IROW(IKX) - RWNMBS(K)=I - ACOEFF(K)=RELT(IKX) - RWLINK(K)=RWHEAD(I) - RWHEAD(I)=K - LENROW(I)=LENROW(I)+1 - 1400 CONTINUE - 1500 CONTINUE -C -C Set the new number of rows of the constraint matrix. -C Observe that row linked lists are OK. - M=MNEW - LNKUPD=0 -C - ENDIF -C -C -C Remove numerical errors frm RHS. - DO 1600 I=1,M - IF(DABS(B(I)).LE.FSBTOL) B(I)=0.0D0 - 1600 CONTINUE -C -C -C -C -C -C -C Second main loop begins here. -C Loop over all LP constraints. -C Tighten bounds on variables. - DO 3000 I=1,M - RHS0=B(I) - RTYPE='EQ' - IF(RWSTAT(I).EQ.2) RTYPE='GE' - IF(RWSTAT(I).EQ.3) RTYPE='LE' -C -C Compute LOWER and UPPER limits of the LP constraint. - KRWBEG=RWHEAD(I) - IF(RWSTAT(I).GE.2) KRWBEG=RWLINK(KRWBEG) - BLOWER=0.0D0 - BUPPER=0.0D0 - NPOS=0 - NNEG=0 - NPOSBG=0 - NNEGBG=0 -C -C Loop over nonzero entries of row I. - IPOS=KRWBEG - 2100 IF(IPOS.EQ.0) GO TO 2200 - J=CLNMBS(IPOS) - K=STAVAR(J) - IF(K.GE.6) GO TO 2150 - BNDJUP=BIG - IF(K.EQ.1.OR.K.EQ.3) BNDJUP=UPBND(J) - IF(ACOEFF(IPOS).LT.0.0D0) THEN - NNEG=NNEG+1 - IF(BNDJUP.GT.BIGNEW) THEN - NNEGBG=NNEGBG+1 - KNEGBG=IPOS - ELSE - BLOWER=BLOWER+BNDJUP*ACOEFF(IPOS) - ENDIF - ELSE - NPOS=NPOS+1 - IF(BNDJUP.GT.BIGNEW) THEN - NPOSBG=NPOSBG+1 - KPOSBG=IPOS - ELSE - BUPPER=BUPPER+BNDJUP*ACOEFF(IPOS) - ENDIF - ENDIF - 2150 IPOS=RWLINK(IPOS) - GO TO 2100 -C - 2200 CONTINUE - RNRM=SMALLA*(RMTMP1(I)+DABS(B(I))) - IF(RNRM.LE.FSBTOL) RNRM=FSBTOL - IF(RNRM.GE.1.0D-5) RNRM=1.0D-5 - IF(DABS(BLOWER-B(I)).LE.RNRM) BLOWER=B(I) - IF(DABS(BUPPER-B(I)).LE.RNRM) BUPPER=B(I) -C -C *** DEBUGGING - IF(MSGLEV.LE.2) GO TO 2210 - WRITE(BUFFER,2201) I,RTYPE,BLOWER,BUPPER,B(I) - 2201 FORMAT(1X,'Row=',I6,' type=',A2, - X ' BLO=',D10.3,' BUP=',D10.3,' RHS=',D10.3) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,2202) NPOS,NNEG,NPOSBG,NNEGBG - 2202 FORMAT(1X,' Npos=',I5,' Nneg=',I5, - X ' Nposbg=',I5,' Nnegbg=',I5) - CALL MYWRT(IOERR,BUFFER) - IF(RANGES(I).GE.BIGNEW) GO TO 2210 - WRITE(BUFFER,2203) I,RWNAME(I),RANGES(I) - 2203 FORMAT(1X,'ELCNST: Row ',I6,' name=',A8,' range=',D12.6) - CALL MYWRT(IOERR,BUFFER) - 2210 CONTINUE -C -C -C - IF(RWSTAT(I).EQ.1.OR.RWSTAT(I).EQ.3) THEN -C -C Here for EQUALITY type or LESS OR EQUAL type constraint. - IF(BLOWER-RHS0.GT.FSBTOL.AND.NNEGBG.EQ.0) GO TO 9010 - IF(NNEGBG.GE.1) GO TO 2400 -C -C -C Here if there are no negative entries with BIG Uj. -C Loop over nonzero entries of row I. - BLOWER=RHS0-BLOWER - IPOS=KRWBEG - 2300 IF(IPOS.EQ.0) GO TO 2380 - J=CLNMBS(IPOS) - K=STAVAR(J) - IF(K.GE.6) GO TO 2360 - IF(ACOEFF(IPOS).GT.0.0D0) THEN -C -C Implicit UPPER bound can be defined for each variable -C refering to POSITIVE entry of row I. Ignore large bound. - BNDJUP=BIG - IF(K.EQ.1.OR.K.EQ.3) BNDJUP=UPBND(J) - BNDNEW=BLOWER/ACOEFF(IPOS) - IF(BNDNEW.GE.BNDJUP-BNDTOL) GO TO 2360 -C IF(BNDNEW.GE.BNDBIG) GO TO 2360 - IF(BNDNEW.GE.BNDBIG) THEN - IF(K.EQ.0.OR.K.EQ.2) GO TO 2360 - ENDIF - IF(LEVPRS.LE.1) GO TO 2360 - NTIGHT=NTIGHT+1 - UPBND(J)=BNDNEW - IF(MSGLEV.LE.2) GO TO 2304 - WRITE(BUFFER,2301) J,STAVAR(J),BNDJUP,BNDNEW - 2301 FORMAT(1X,'cl=',I6,' st=',I6,' oldUPj=',D16.8, - X ' newUPj=',D16.8) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,2303) J,CLNAME(J),BNDNEW - 2303 FORMAT(1X,'ELCNST: Variable ',I6,' (name=',A8, - X ') has new UPPER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2304 CONTINUE -C -C Reinitialize bounds on shadow prices. - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 2310 IKX=KBEG,KEND - IR=RWNMBS(IKX) - P(IR)=-BIG - Q(IR)=BIG - IF(RANGES(IR).LE.BIGNEW) GO TO 2310 - IF(RWSTAT(IR).EQ.2) P(IR)=0.0D0 - IF(RWSTAT(IR).EQ.3) Q(IR)=0.0D0 - 2310 CONTINUE -C - IF(BNDNEW.LE.FSBTOL) THEN -C -C Fix variable J on its LOWER bound. - NFIXED=NFIXED+1 - X0=0.0D0 - PRLVAR(J)=X0 - STAVAR(J)=6 - IF(MSGLEV.LE.1) GO TO 2312 - WRITE(BUFFER,2311) J,CLNAME(J),X0 - 2311 FORMAT(1X,'ELCNST: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) -C CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - 2312 CONTINUE - GO TO 2360 - ENDIF - IF(K.EQ.1.OR.K.EQ.3) GO TO 2360 - STAVAR(J)=STAVAR(J)+1 -C - ELSE -C -C Implicit LOWER bound can be defined for each variable -C refering to NEGATIVE entry of row I. - BNDJUP=UPBND(J) - BNDNEW=BNDJUP+BLOWER/ACOEFF(IPOS) - IF(BNDNEW.LE.BNDTOL) GO TO 2360 - NTIGHT=NTIGHT+1 - LOBND(J)=LOBND(J)+BNDNEW - UPBND(J)=UPBND(J)-BNDNEW - STAVAR(J)=3 -C -C Save the new LOWER bound in a PRE_SOLVE history list. - IF(LNHIST.GE.MXHIST) GO TO 9200 - LNHIST=LNHIST+1 - INHIST(LNHIST)=-J - DPHIST(LNHIST)=BNDNEW -C -C Modify RHS (take account of the new LOWER bound on Xj). - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 2340 IKX=KBEG,KEND - IR=RWNMBS(IKX) - IF(IR.GT.0) THEN - B(IR)=B(IR)-BNDNEW*ACOEFF(IKX) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - ENDIF - 2340 CONTINUE -C -C *** DEBUGGING - IF(MSGLEV.LE.2) GO TO 2342 - WRITE(BUFFER,2341) J,STAVAR(J),BNDNEW - 2341 FORMAT(1X,'cl=',I6,' st=',I6,' oldLOj=0.0D0', - X ' newLOj=',D16.8) - CALL MYWRT(IOERR,BUFFER) - 2342 IF(MSGLEV.LE.2) GO TO 2344 - WRITE(BUFFER,2343) J,CLNAME(J),BNDNEW - 2343 FORMAT(1X,'ELCNST: Variable ',I6,' (name=',A8, - X ') has new LOWER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2344 CONTINUE -C - ENDIF - 2360 IPOS=RWLINK(IPOS) - GO TO 2300 -C - 2380 CONTINUE - BLOWER=RHS0-BLOWER - GO TO 2500 -C -C -C Here if there exist negative entries with BIG Uj. -C If only one variable has big UPPER bound, then its LOWER -C bound can be improved. KNEGBG indicates its position. - 2400 IF(NNEGBG.GE.2) GO TO 2500 - J=CLNMBS(KNEGBG) - K=STAVAR(J) - IF(K.GE.6) GO TO 2500 - IF(K.LT.0) GO TO 2500 - BNDNEW=(RHS0-BLOWER)/ACOEFF(KNEGBG) - IF(BNDNEW.LE.BNDTOL) GO TO 2500 - NTIGHT=NTIGHT+1 - LOBND(J)=LOBND(J)+BNDNEW - STAVAR(J)=2 -C -C Save the new LOWER bound in a PRE_SOLVE history list. - IF(LNHIST.GE.MXHIST) GO TO 9200 - LNHIST=LNHIST+1 - INHIST(LNHIST)=-J - DPHIST(LNHIST)=BNDNEW -C -C Modify RHS (take account of the new LOWER bound on Xj). - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 2420 IKX=KBEG,KEND - IR=RWNMBS(IKX) - IF(IR.GT.0) THEN - B(IR)=B(IR)-BNDNEW*ACOEFF(IKX) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - ENDIF - 2420 CONTINUE -C -C *** DEBUGGING - IF(MSGLEV.LE.2) GO TO 2422 - WRITE(BUFFER,2421) J,STAVAR(J),BNDNEW - 2421 FORMAT(1X,'5 BIG Uj, cl=',I6,' st=',I6,' oldLOj=0.0D0', - X ' newLOj=',D16.8) - CALL MYWRT(IOERR,BUFFER) - 2422 IF(MSGLEV.LE.2) GO TO 2424 - WRITE(BUFFER,2423) J,CLNAME(J),BNDNEW - 2423 FORMAT(1X,'ELCNST: Variable ',I6,' (name=',A8, - X ') has new LOWER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2424 CONTINUE -C - ENDIF -C -C -C - 2500 CONTINUE - IF(RWSTAT(I).EQ.1.OR.RWSTAT(I).EQ.2) THEN -C -C Here for EQUALITY type or GREATER OR EQUAL type constraint. - IF(BUPPER-RHS0.LT.-FSBTOL.AND.NPOSBG.EQ.0) GO TO 9010 - IF(NPOSBG.GE.1) GO TO 2700 -C -C -C Here if there are no positive entries with BIG Uj. -C Loop over nonzero entries of row I. - BUPPER=RHS0-BUPPER - IPOS=KRWBEG - 2600 IF(IPOS.EQ.0) GO TO 2680 - J=CLNMBS(IPOS) - K=STAVAR(J) - IF(K.GE.6) GO TO 2660 - IF(ACOEFF(IPOS).LT.0.0D0) THEN -C -C Implicit UPPER bound can be defined for each variable -C refering to NEGATIVE entry of row I. Ignore large bound. - BNDJUP=BIG - IF(K.EQ.1.OR.K.EQ.3) BNDJUP=UPBND(J) - BNDNEW=BUPPER/ACOEFF(IPOS) - IF(BNDNEW.GE.BNDJUP-BNDTOL) GO TO 2660 -C IF(BNDNEW.GE.BNDBIG) GO TO 2660 - IF(BNDNEW.GE.BNDBIG) THEN - IF(K.EQ.0.OR.K.EQ.2) GO TO 2660 - ENDIF - IF(LEVPRS.LE.1) GO TO 2660 - NTIGHT=NTIGHT+1 - UPBND(J)=BNDNEW - IF(MSGLEV.LE.2) GO TO 2604 - WRITE(BUFFER,2601) J,STAVAR(J),BNDJUP,BNDNEW - 2601 FORMAT(1X,'cl=',I6,' st=',I6,' oldUPj=',D16.8, - X ' newUPj=',D16.8) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,2603) J,CLNAME(J),BNDNEW - 2603 FORMAT(1X,'ELCNST: Variable ',I6,' (name=',A8, - X ') has new UPPER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2604 CONTINUE -C -C Reinitialize bounds on shadow prices. - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 2610 IKX=KBEG,KEND - IR=RWNMBS(IKX) - P(IR)=-BIG - Q(IR)=BIG - IF(RANGES(IR).LE.BIGNEW) GO TO 2610 - IF(RWSTAT(IR).EQ.2) P(IR)=0.0D0 - IF(RWSTAT(IR).EQ.3) Q(IR)=0.0D0 - 2610 CONTINUE -C - IF(BNDNEW.LE.FSBTOL) THEN -C -C Fix variable J on its LOWER bound. - NFIXED=NFIXED+1 - X0=0.0D0 - PRLVAR(J)=X0 - STAVAR(J)=6 - IF(MSGLEV.LE.1) GO TO 2612 - WRITE(BUFFER,2611) J,CLNAME(J),X0 - 2611 FORMAT(1X,'ELCNST: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) -C CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - 2612 CONTINUE - GO TO 2660 - ENDIF - IF(K.EQ.1.OR.K.EQ.3) GO TO 2660 - STAVAR(J)=STAVAR(J)+1 -C - ELSE -C -C Implicit LOWER bound can be defined for each variable -C refering to POSITIVE entry of row I. - BNDJUP=UPBND(J) - BNDNEW=BNDJUP+BUPPER/ACOEFF(IPOS) - IF(BNDNEW.LE.BNDTOL) GO TO 2660 - NTIGHT=NTIGHT+1 - LOBND(J)=LOBND(J)+BNDNEW - UPBND(J)=UPBND(J)-BNDNEW - STAVAR(J)=3 -C -C Save the new LOWER bound in a PRE_SOLVE history list. - IF(LNHIST.GE.MXHIST) GO TO 9200 - LNHIST=LNHIST+1 - INHIST(LNHIST)=-J - DPHIST(LNHIST)=BNDNEW -C -C Modify RHS (take account of the new LOWER bound on Xj). - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 2640 IKX=KBEG,KEND - IR=RWNMBS(IKX) - IF(IR.GT.0) THEN - B(IR)=B(IR)-BNDNEW*ACOEFF(IKX) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - ENDIF - 2640 CONTINUE -C -C *** DEBUGGING - IF(MSGLEV.LE.2) GO TO 2642 - WRITE(BUFFER,2641) J,STAVAR(J),BNDNEW - 2641 FORMAT(1X,'cl=',I6,' st=',I6,' oldLOj=0.0D0', - X ' newLOj=',D16.8) - CALL MYWRT(IOERR,BUFFER) - 2642 IF(MSGLEV.LE.2) GO TO 2644 - WRITE(BUFFER,2643) J,CLNAME(J),BNDNEW - 2643 FORMAT(1X,'ELCNST: Variable ',I6,' (name=',A8, - X ') has new LOWER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2644 CONTINUE -C - ENDIF - 2660 IPOS=RWLINK(IPOS) - GO TO 2600 -C - 2680 CONTINUE - BUPPER=RHS0-BUPPER - GO TO 3000 -C -C -C Here if there exist positive entries with BIG Uj. -C If only one variable has big UPPER bound, then its LOWER -C bound can be improved. KPOSBG indicates its position. - 2700 IF(NPOSBG.GE.2) GO TO 3000 - J=CLNMBS(KPOSBG) - K=STAVAR(J) - IF(K.GE.6) GO TO 3000 - IF(K.LT.0) GO TO 3000 - BNDNEW=(RHS0-BUPPER)/ACOEFF(KPOSBG) - IF(BNDNEW.LE.BNDTOL) GO TO 3000 - NTIGHT=NTIGHT+1 - LOBND(J)=LOBND(J)+BNDNEW - STAVAR(J)=2 -C -C Save the new LOWER bound in a PRE_SOLVE history list. - IF(LNHIST.GE.MXHIST) GO TO 9200 - LNHIST=LNHIST+1 - INHIST(LNHIST)=-J - DPHIST(LNHIST)=BNDNEW -C -C Modify RHS (take account of the new LOWER bound on Xj). - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 2720 IKX=KBEG,KEND - IR=RWNMBS(IKX) - IF(IR.GT.0) THEN - B(IR)=B(IR)-BNDNEW*ACOEFF(IKX) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - ENDIF - 2720 CONTINUE -C -C *** DEBUGGING - IF(MSGLEV.LE.2) GO TO 2722 - WRITE(BUFFER,2721) J,STAVAR(J),BNDNEW - 2721 FORMAT(1X,'8 BIG Uj, cl=',I6,' st=',I6,' oldLOj=0.0D0', - X ' newLOj=',D16.8) - CALL MYWRT(IOERR,BUFFER) - 2722 IF(MSGLEV.LE.2) GO TO 2724 - WRITE(BUFFER,2723) J,CLNAME(J),BNDNEW - 2723 FORMAT(1X,'ELCNST: Variable ',I6,' (name=',A8, - X ') has new LOWER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2724 CONTINUE -C - ENDIF -C -C -C -C -C -C End of the second main loop. - 3000 CONTINUE - IF(NFIXED.GT.N1) LNKUPD=1 -C -C -C -C Check if 1000 and 3000 loops should be repeated. - IF(M.LT.M1) THEN - IRUN=IRUN+1 - GO TO 200 - ENDIF - IF(100*(NTIGHT-NT0).GE.N) THEN - IRUN=IRUN+1 - IF(IRUN.GE.6) GO TO 3100 - GO TO 200 - ELSE - GO TO 3100 - ENDIF -C -C -C -C -C - 3100 CONTINUE - IF(LNKUPD.EQ.1) THEN -C -C Restore linked lists of rows of A (new FIXED variables -C have to be removed). Zero RWHEAD and LENROW arrays. - DO 3200 I=1,M - RWHEAD(I)=0 - LENROW(I)=0 - 3200 CONTINUE -C -C Set the row linked lists. - DO 3400 J=1,N - IF(STAVAR(J).GE.6) GO TO 3400 - KBEG=CLPNTS(J)-1 - DO 3300 IKX=1,LENCOL(J) - K=KBEG+IKX - I=RWNMBS(K) - RWLINK(K)=RWHEAD(I) - RWHEAD(I)=K - LENROW(I)=LENROW(I)+1 - 3300 CONTINUE - 3400 CONTINUE - N1=NFIXED - LNKUPD=0 - ENDIF -C -C -C Check if there are inequality type rows to be eliminated. -C Check if the eliminated rows were not violated. - FSBTOL=1.0D-7 - DO 3500 I=1,M - IF(DABS(B(I)).LE.FSBTOL) B(I)=0.0D0 - K=RWHEAD(I) -C WRITE(BUFFER,3501) I,RWSTAT(I),LENROW(I),K -C3501 FORMAT(1X,'row=',I6,' st=',I2,' ln=',I6,' K=',I8) -C CALL MYWRT(IOERR,BUFFER) - IF(RWSTAT(I).EQ.1) THEN -C -C Here for EQUALITY constraint. - IF(K.GT.0) GO TO 3500 - IF(DABS(B(I)).GT.FSBTOL) GO TO 9030 - GO TO 3500 - ENDIF - IF(LENROW(I).GE.2) GO TO 3500 -C WRITE(BUFFER,3502) I,RWSTAT(I),LENROW(I),K,CLNMBS(K) -C3502 FORMAT(1X,'rw=',I6,' st=',I2,' ln=',I6,' hd=',I8,' cl=',I6) -C CALL MYWRT(IOERR,BUFFER) - IF(RWSTAT(I).EQ.2) THEN -C -C Here for GREATER OR EQUAL type constraint. - IF(B(I).GT.FSBTOL) GO TO 9030 - IF(K.LE.0) GO TO 3500 - NELIM=NELIM+1 - RWHEAD(I)=-RWHEAD(I) - J=CLNMBS(K) - STAVAR(J)=14 - NFIXED=NFIXED+1 - GO TO 3500 - ENDIF - IF(RWSTAT(I).EQ.3) THEN -C -C Here for LESS OR EQUAL type constraint. - IF(B(I).LT.-FSBTOL) GO TO 9030 - IF(K.LE.0) GO TO 3500 - NELIM=NELIM+1 - RWHEAD(I)=-RWHEAD(I) - J=CLNMBS(K) - STAVAR(J)=14 - NFIXED=NFIXED+1 - GO TO 3500 - ENDIF - 3500 CONTINUE -C -C -C - IF(NFIXED.GT.N1) THEN -C -C Determine the permutation that puts all empty and inactive -C rows at the end of the list. -C - IRUN=3 - IF(MSGLEV.LE.1) IRUN=4 - CALL EMPTYR(MAXM,M,MNEW,IRUN, - X RWHEAD,STAROW,PERM,INVP,IOERR) -C -C -C Reorder the rows of the LP constraint matrix according to -C the permutation resulting from the analysis of EMPTYR. -C Reorder LENROW array accordingly. - IF(MNEW.LT.M) THEN -C - CALL REORDA(MAXM,MAXN,MAXNZA,M,N, - X CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X PERM,INVP,IMTMP1,IROW,RELT, - X RWNAME,STAROW,RWSTAT,RANGES,B,IOERR) -C -C Reorder bounds on shadow prices P and Q. - CALL REORDV(MAXM,M, - X PERM,INVP,P,RELT,IOERR) - CALL REORDV(MAXM,M, - X PERM,INVP,Q,RELT,IOERR) -C -C Reorder LENROW array. - CALL REORDI(MAXM,M, - X PERM,INVP,LENROW,IMTMP1(1),IOERR) -C -C Set the new number of rows of the constraint matrix. - M=MNEW -C - ENDIF - ENDIF -C -C -C -C -C -C -C Here if a successful run of the loop has been completed. - IF(MSGLEV.LE.0) GO TO 5010 - WRITE(BUFFER,5001) NELIM - 5001 FORMAT(1X,'ELCNST: Constraints eliminated: ',I9) -C CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,5002) NFIXED - 5002 FORMAT(1X,' Variables eliminated: ',I9) -C CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,5003) NTIGHT - 5003 FORMAT(1X,' Variable bounds improved:',I8) -C CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - 5010 CONTINUE -C -C -C - RETURN -C -C - 9010 WRITE(BUFFER,9011) RWNAME(I),RTYPE,BLOWER,BUPPER,B(I) - 9011 FORMAT(1X,'ELCNST: Row=',A8,' type=',A2, - X ' BLO=',D10.3,' BUP=',D10.3,' RHS=',D10.3) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9012) - 9012 FORMAT(1X,'ELCNST: Problem is infeasible.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9030 WRITE(BUFFER,9031) I,RWNAME(I),B(I) - 9031 FORMAT(1X,'ELCNST: Constraint ',I6,' (name=',A8, - X ') is violated, B=',D12.6) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9032) - 9032 FORMAT(1X,'ELCNST: Problem is infeasible.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9200 WRITE(BUFFER,9201) - 9201 FORMAT(1X,'ELCNST: Please increase space for PRE_SOLVE ', - X 'history list.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C -C -C -C *** LAST CARD OF (ELCNST) *** - END //GO.SYSIN DD hopdm.src/elcnst.f echo hopdm.src/elvrbl.f 1>&2 sed >hopdm.src/elvrbl.f <<'//GO.SYSIN DD hopdm.src/elvrbl.f' 's/^-//' -C*************************************************************** -C *** ELVRBL ... ELIMINATE VARIABLES FROM THE LP PROBLEM *** -C*************************************************************** -C - SUBROUTINE ELVRBL(IOERR,MSGLEV,ICALL, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X IMTMP1,IROW,RELT, - X B,RANGES,C,UPBND, - X ACOEFF,CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X P,Q,PRLVAR,STAVAR,RWSTAT,STAROW,RWNAME,CLNAME, - X PERM,INVP,LENROW) -C -C -C -C *** PARAMETERS - INTEGER*4 IOERR,MSGLEV,ICALL,MAXM,MAXN,MAXNZA,M,N,NSTRCT - INTEGER*4 LNHIST,MXHIST - INTEGER*2 INHIST(MXHIST) - DOUBLE PRECISION DPHIST(MXHIST) - DOUBLE PRECISION ACOEFF(MAXNZA),B(MAXM),RANGES(MAXM) - DOUBLE PRECISION RELT(MAXN),C(MAXN),UPBND(MAXN) - INTEGER*4 IMTMP1(MAXM+1),IROW(MAXN) - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM+1),RWLINK(MAXNZA) - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) - DOUBLE PRECISION P(MAXM),Q(MAXM),PRLVAR(MAXN) - CHARACTER*8 RWNAME(MAXM),CLNAME(MAXN) - INTEGER*2 STAVAR(MAXN),STAROW(MAXM),RWSTAT(MAXM) - INTEGER*2 INVP(MAXM),PERM(MAXM),LENROW(MAXM) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,IR,IRUN,J,K,KBEG,KEND,LBIG - INTEGER*4 MEQ,MFREE,MNEW,NFIXED,NTIGHT,NT0,NNEG,NPOS,NBIG - DOUBLE PRECISION BIG,BIGNEW,X0,FSBTOL,OPTTOL,SMALLA - DOUBLE PRECISION PNEW,QNEW,PJ,QJ,PPOSJ,PNEGJ,PPOSJ0,PNEGJ0 - CHARACTER*100 BUFFER -C -C -C -C -C *** PARAMETERS DESCRIPTION -C -C *** ON INPUT: -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C MSGLEV The level of PRE_SOLVE information desired: -C 0 only final problem dimensions are printed; -C 1 numbers of eliminated rows and columns are printed; -C 2 names of eliminated rows and columns are printed; -C 3 detailed DEBUGGING information is printed. -C ICALL Number of call of the ELVRBL routine (bounds on shadow -C prices are initialized in a first call). -C MAXM Maximum number of constraints. -C MAXN Maximum number of variables. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of constraints. -C N Number of variables (total, i.e. including slacks, -C surplus and artificials). -C NSTRCT Number of structural variables (excluding slacks, -C surplus and artificials). -C LNHIST Length of the PRE_SOLVE history list. -C MXHIST Maximum number of entries in the PRE_SOLVE history list. -C INHIST Integer PRE_SOLVE history information. -C DPHIST Double precision PRE_SOLVE history information. -C ACOEFF Array of nonzero elements for each column. -C B Right hand side of the linear program. -C RANGES Array of constraint ranges. -C C Objective function coefficients. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C LENCOL Lengths of (sparse) columns of matrix A. -C UPBND Array of upper bounds. Note that the upper bound -C is changed when the variable has a lower bound. -C PRLVAR Primal variables of the linear program. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C RWSTAT Array of row types: -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 objective row; -C 5 other free row. -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C RWNAME Array of row names (increasing order sort). -C CLNAME Array of column names (unordered). -C -C *** ON OUTPUT: -C P LOWER bounds on shadow prices (dual variables). -C Q UPPER bounds on shadow prices (dual variables). -C -C -C -C -C *** WORK ARRAYS: -C IROW and RELT are the arrays for temporary handling of rows -C and columns of the constraint matrix. They are primarily -C intended to handle sparse vectors (in packed form) -C but may also be used for storing dense ones. -C IMTMP1 Integer work array of size MAXM. -C LENROW Half-length integer work array of size MAXM. -C -C -C -C -C *** PURPOSE -C This routine computes bounds on shadow prices (dual variables) -C and uses them to compute limits for the reduced costs. Those -C are used to eliminate colulmns (to fix them on their bounds). -C -C -C -C *** SUBROUTINES CALLED -C MYWRT,GETCOL,GETROW,DABS,EMPTYR,REORDA,REORDV -C -C -C *** NOTES -C This routine is given direct access to the matrix A. -C It alters hidden data structures. -C -C -C -C *** REFERENCES: -C Gondzio J. (1994). Presolve analysis of linear programs prior -C to applying an interior point method, Technical Report -C No 1994.3, Department of Management Studies, University -C of Geneva, 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, -C February 1994, revised in December 1994. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: May 17, 1993 -C Last modified: March 29, 1995 -C -C -C -C -C *** BODY OF (ELVRBL) *** -C -C -C -C *** DEBUGGING - IF(MSGLEV.LE.3) GO TO 12 - WRITE(BUFFER,1) - 1 FORMAT(1X,'ELVRBL starts !!!!') - CALL MYWRT(IOERR,BUFFER) - DO 10 J=1,NSTRCT - IF(STAVAR(J).GE.6) GO TO 10 - IF(LENCOL(J).LE.0.OR.LENCOL(J).GT.M) THEN - WRITE(BUFFER,2) J,LENCOL(J) - 2 FORMAT(1X,'col=',I6,' LENCOL(J)=',I6) - CALL MYWRT(IOERR,BUFFER) - STOP - ENDIF - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 5 K=KBEG,KEND - IR=RWNMBS(K) - IF(IR.LE.0.OR.IR.GT.M) THEN - WRITE(BUFFER,3) J,K,IR - 3 FORMAT(1X,'col=',I6,' pos=',I6,' IR=',I6) - CALL MYWRT(IOERR,BUFFER) - STOP - ENDIF - 5 CONTINUE - 10 CONTINUE - WRITE(BUFFER,11) - 11 FORMAT(1X,'ELVRBL analysis O.K. !!!!') - CALL MYWRT(IOERR,BUFFER) - 12 CONTINUE -C -C -C -C -C Initialize. - BIG=1.0D+30 - BIGNEW=1.0D+20 - SMALLA=1.0D-8 - FSBTOL=1.0D-7 - OPTTOL=1.0D-7 - NTIGHT=0 - NFIXED=0 -C -C -C -C Initialize bounds on dual variables (shadow prices). - IF(ICALL.GE.2) GO TO 110 - DO 100 I=1,M - P(I)=-BIG - Q(I)=BIG - IF(RWSTAT(I).EQ.1) GO TO 100 - IF(RANGES(I).LE.BIGNEW) GO TO 100 - IF(RWSTAT(I).EQ.2) P(I)=0.0D0 - IF(RWSTAT(I).EQ.3) Q(I)=0.0D0 - 100 CONTINUE - 110 CONTINUE -C -C -C -C -C -C First main loop begins here. -C Loop over all structural columns of A. -C Eliminate empty columns. -C Tighten bounds on shadow prices for single-element columns. - DO 1000 J=1,NSTRCT - IF(STAVAR(J).GE.6) GO TO 1000 - IF(LENCOL(J).GT.1) GO TO 1000 -C -C Check if an empty column is found. - IF(LENCOL(J).EQ.0) THEN - IF(MSGLEV.LE.2) GO TO 102 - WRITE(BUFFER,101) J,CLNAME(J) - 101 FORMAT(1X,'ELVRBL: Column ',I6,' (name=',A8,') is empty.') - CALL MYWRT(IOERR,BUFFER) - 102 CONTINUE -C - IF(C(J).LT.0.0D0) THEN -C -C Fix variable J on its UPPER bound. - IF(STAVAR(J).EQ.1.OR.STAVAR(J).EQ.3) THEN - X0=UPBND(J) - GO TO 800 - ELSE - GO TO 9010 - ENDIF - ELSE -C -C Fix variable J on its LOWER bound. - IF(STAVAR(J).GE.0) THEN - X0=0.0D0 - GO TO 800 - ELSE - GO TO 9020 - ENDIF - ENDIF - ENDIF -C -C Analyse the constraint with an entry in column J. - KBEG=CLPNTS(J) - IR=RWNMBS(KBEG) - IF(RWSTAT(IR).GE.4) GO TO 1000 -C -C Note of 30.03.95. I am not sure about the need of this line: -C IF(DABS(RANGES(IR)).LE.BIGNEW) GO TO 1000 -C -C Here for an LP constraint. - IF(MSGLEV.LE.2) GO TO 104 - WRITE(BUFFER,103) J,CLNAME(J),STAVAR(J) - 103 FORMAT(1X,'ELVRBL: snglt cl=',I6,' (nm=',A8,' st=',I6,')') - CALL MYWRT(IOERR,BUFFER) - 104 CONTINUE -C -C Compute new bounds on shadow prices P and Q. - IF(STAVAR(J).EQ.1.OR.STAVAR(J).EQ.3) GO TO 1000 - PNEW=-BIG - QNEW=BIG - IF(ACOEFF(KBEG).LT.0.0D0) THEN - PNEW=C(J)/ACOEFF(KBEG) - ELSE - QNEW=C(J)/ACOEFF(KBEG) - ENDIF -C - IF(MSGLEV.LE.2) GO TO 203 - WRITE(BUFFER,201) IR,RWNAME(IR),RWSTAT(IR) - 201 FORMAT(15X,'rw=',I6,' (nm=',A8,' st=',I6,')') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,202) P(IR),Q(IR),PNEW,QNEW - 202 FORMAT(1X,'Pi=',D12.5,' Qi=',D12.5, - X ' Pnew=',D12.5,' Qnew=',D12.5) - CALL MYWRT(IOERR,BUFFER) - 203 CONTINUE -C - IF(PNEW.GT.P(IR)) P(IR)=PNEW - IF(QNEW.LT.Q(IR)) Q(IR)=QNEW -C -C Here if the variable cannot be eliminated. - GO TO 1000 -C -C Eliminate column J. Update RHS. - 800 NFIXED=NFIXED+1 - PRLVAR(J)=X0 - STAVAR(J)=6 - IF(MSGLEV.LE.1) GO TO 802 - WRITE(BUFFER,801) J,CLNAME(J),X0 - 801 FORMAT(1X,'ELVRBL: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 802 CONTINUE -C -C -C -C End of the first main loop. - 1000 CONTINUE -C -C -C -C -C -C Second main loop begins here. -C Loop over all structural columns of A. -C Tighten bounds on shadow prices for all unbounded columns. - IRUN=1 - 2000 NT0=NTIGHT - DO 3000 J=1,NSTRCT - K=STAVAR(J) - IF(K.GE.6) GO TO 3000 - IF(K.EQ.1.OR.K.EQ.3) GO TO 3000 -C -C Here if J is not bounded. - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 -C -C Compute LOWER and UPPER limits of the dual constraint. - PJ=0.0 - QJ=0.0 - PPOSJ=0.0 - PNEGJ=0.0 - NPOS=0 - NNEG=0 - DO 2200 K=KBEG,KEND - IR=RWNMBS(K) - IF(ACOEFF(K).LT.0.0D0) THEN - NNEG=NNEG+1 - PJ=PJ+Q(IR)*ACOEFF(K) - PNEGJ=PNEGJ+Q(IR)*ACOEFF(K) - QJ=QJ+P(IR)*ACOEFF(K) - ELSE - NPOS=NPOS+1 - PJ=PJ+P(IR)*ACOEFF(K) - PPOSJ=PPOSJ+P(IR)*ACOEFF(K) - QJ=QJ+Q(IR)*ACOEFF(K) - ENDIF - 2200 CONTINUE -C -C *** DEBUGGING - IF(MSGLEV.LE.2) GO TO 2210 - WRITE(BUFFER,2201) J,PJ,QJ,C(J) - 2201 FORMAT(1X,'col=',I6,' PJ=',D10.3,' QJ=',D10.3, - X ' Cj=',D10.3) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,2202) PJ,PPOSJ,PNEGJ - 2202 FORMAT(1X,'PJ=',D10.3,'= PPOSJ=',D10.3,' + PNEGJ=',D10.3) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,2203) LENCOL(J),NPOS,NNEG - 2203 FORMAT(1X,'len=',I6,' Npos=',I5,' Nneg=',I5) - CALL MYWRT(IOERR,BUFFER) - 2210 CONTINUE -C -C -C Check if the variable will be FIXED on one of its bounds. -C If so, then do not tighten bounds on shadow prices. - IF(C(J)-PJ.LE.-OPTTOL) GO TO 3000 - IF(C(J)-QJ.GE.OPTTOL) GO TO 3000 -C -C -C -C Check if it is possible to tighten bounds on shadow prices -C refering to rows in which column J has negative entries. - IF(PPOSJ.LE.-BIGNEW) GO TO 2700 - IF(NNEG.EQ.0) GO TO 2700 -C -C Count negative elements with large (infinite) Qj. - NBIG=0 - LBIG=0 - PNEGJ0=0.0D0 - DO 2500 K=KBEG,KEND - IF(ACOEFF(K).LT.0.0D0) THEN - IR=RWNMBS(K) - IF(Q(IR).GE.BIGNEW) THEN - NBIG=NBIG+1 - LBIG=K - ELSE - PNEGJ0=PNEGJ0+Q(IR)*ACOEFF(K) - ENDIF - ENDIF - 2500 CONTINUE -C WRITE(BUFFER,2501) J,NNEG,NBIG -C2501 FORMAT(1X,'col=',I6,' NNEG=',I6,' Nbg=',I6) -C CALL MYWRT(IOERR,BUFFER) -C -C -C Check if bounds can be tightened. - IF(NBIG.GE.2) GO TO 2700 - IF(NBIG.EQ.0) THEN -C -C Bounds for all negative entries can be tightened. - X0=C(J)-PJ - DO 2600 K=KBEG,KEND - IF(ACOEFF(K).LT.0.0D0) THEN - IR=RWNMBS(K) - PNEW=Q(IR)+X0/ACOEFF(K) - IF(PNEW.GE.P(IR)+OPTTOL) THEN - NTIGHT=NTIGHT+1 -C WRITE(BUFFER,2601) J,IR,P(IR),PNEW -C2601 FORMAT(1X,'col=',I6,' row=',I6,' Pi=',D10.3, -C X ' is improved, Pnew=',D10.3) -C CALL MYWRT(0,BUFFER) -C CALL MYWRT(IOERR,BUFFER) - P(IR)=PNEW - ENDIF - ENDIF - 2600 CONTINUE -C - ELSE -C -C Bound for only one entry can be tightened. - X0=C(J)-PPOSJ-PNEGJ0 - IR=RWNMBS(LBIG) - PNEW=X0/ACOEFF(LBIG) - IF(PNEW.GE.P(IR)+OPTTOL) THEN - NTIGHT=NTIGHT+1 -C WRITE(BUFFER,2602) J,IR,P(IR),PNEW -C2602 FORMAT(1X,'col=',I6,' row=',I6,' Pi=',D10.3, -C X ' is improved, Pnew=',D10.3) -C CALL MYWRT(0,BUFFER) -C CALL MYWRT(IOERR,BUFFER) - P(IR)=PNEW - ENDIF -C - ENDIF -C -C -C -C Check if it is possible to tighten bounds on shadow prices -C refering to rows in which column J has positive entries. - 2700 CONTINUE - IF(PNEGJ.LE.-BIGNEW) GO TO 3000 - IF(NPOS.EQ.0) GO TO 3000 -C -C Count positive elements with large (infinite) Pj. - NBIG=0 - LBIG=0 - PPOSJ0=0.0D0 - DO 2800 K=KBEG,KEND - IF(ACOEFF(K).GT.0.0D0) THEN - IR=RWNMBS(K) - IF(P(IR).LE.-BIGNEW) THEN - NBIG=NBIG+1 - LBIG=K - ELSE - PPOSJ0=PPOSJ0+P(IR)*ACOEFF(K) - ENDIF - ENDIF - 2800 CONTINUE -C WRITE(BUFFER,2801) J,NPOS,NBIG -C2801 FORMAT(1X,'col=',I6,' NPOS=',I6,' Nbg=',I6) -C CALL MYWRT(IOERR,BUFFER) -C -C -C Check if bounds can be tightened. - IF(NBIG.GE.2) GO TO 3000 - IF(NBIG.EQ.0) THEN -C -C Bounds for all positive entries can be tightened. - X0=C(J)-PJ - DO 2900 K=KBEG,KEND - IF(ACOEFF(K).GT.0.0D0) THEN - IR=RWNMBS(K) - QNEW=P(IR)+X0/ACOEFF(K) - IF(QNEW.LE.Q(IR)-OPTTOL) THEN - NTIGHT=NTIGHT+1 -C WRITE(BUFFER,2901) J,IR,Q(IR),QNEW -C2901 FORMAT(1X,'col=',I6,' row=',I6,' Qi=',D10.3, -C X ' is improved, Qnew=',D10.3) -C CALL MYWRT(0,BUFFER) -C CALL MYWRT(IOERR,BUFFER) - Q(IR)=QNEW - ENDIF - ENDIF - 2900 CONTINUE -C - ELSE -C -C Bound for only one entry can be tightened. - X0=C(J)-PNEGJ-PPOSJ0 - IR=RWNMBS(LBIG) - QNEW=X0/ACOEFF(LBIG) - IF(QNEW.LE.Q(IR)-OPTTOL) THEN - NTIGHT=NTIGHT+1 -C WRITE(BUFFER,2902) J,IR,Q(IR),QNEW -C2902 FORMAT(1X,'col=',I6,' row=',I6,' Qi=',D10.3, -C X ' is improved, Qnew=',D10.3) -C CALL MYWRT(0,BUFFER) -C CALL MYWRT(IOERR,BUFFER) - Q(IR)=QNEW - ENDIF -C - ENDIF -C -C -C -C End of the second main loop. - 3000 CONTINUE -C -C -C -C Check if the loop should be repeated. -C IF(IRUN.EQ.3) GO TO 4000 -C IF(10*(NTIGHT-NT0).GE.M.OR.IRUN*10*NTIGHT.GE.M) THEN -C IRUN=IRUN+1 -C GO TO 2000 -C ENDIF - IF(IRUN.EQ.10) GO TO 4000 - IF(100*(NTIGHT-NT0).GE.M) THEN - IRUN=IRUN+1 - GO TO 2000 - ENDIF -C -C -C -C -C -C -C Third main loop begins here. -C Loop over all structural columns of A. -C Eliminate variables with strictly positive -C (or strictly negative) reduced costs. -C New option is added here (Oct. 93). Weakly dominated -C columns are identified and eliminated. - 4000 DO 5000 J=1,NSTRCT - IF(STAVAR(J).GE.6) GO TO 5000 - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 -C -C Define LOWER and UPPER costs for variable J. -C Count slacks egligible to move while pushing a variable -C to its bound, MFREE. Count entries in EQUALITY type rows. - PJ=0.0 - QJ=0.0 - MEQ=0 - MFREE=0 - DO 4100 K=KBEG,KEND - IR=RWNMBS(K) - IF(RWSTAT(IR).EQ.1) MEQ=MEQ+1 - IF(ACOEFF(K).LT.0.0D0) THEN - IF(RWSTAT(IR).EQ.2) MFREE=MFREE+1 - PJ=PJ+Q(IR)*ACOEFF(K) - QJ=QJ+P(IR)*ACOEFF(K) - ELSE - IF(RWSTAT(IR).EQ.3) MFREE=MFREE+1 - PJ=PJ+P(IR)*ACOEFF(K) - QJ=QJ+Q(IR)*ACOEFF(K) - ENDIF - 4100 CONTINUE -C - IF(MSGLEV.LE.2) GO TO 4102 - WRITE(BUFFER,4101) J,PJ,QJ,C(J) - 4101 FORMAT(1X,'column=',I6,' PJ=',D10.3,' QJ=',D10.3, - X ' Cj=',D10.3) - CALL MYWRT(IOERR,BUFFER) - 4102 CONTINUE -C -C -C Check if the column is strongly dominated. - IF(C(J)-PJ.LE.-OPTTOL) THEN -C -C Fix variable J on its UPPER bound. - IF(MSGLEV.LE.2) GO TO 4210 - WRITE(BUFFER,4201) J,PJ,QJ,C(J),STAVAR(J) - 4201 FORMAT(1X,'cl=',I6,' PJ=',D10.3,' QJ=',D10.3, - X ' Cj=',D10.3,' st=',I6,' goes to UPbnd.') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,4202) J,C(J)-PJ - 4202 FORMAT(1X,'Strongly dominated cl=',I6,' Cj-Pj=',D10.3) - CALL MYWRT(IOERR,BUFFER) - 4210 CONTINUE - IF(STAVAR(J).EQ.1.OR.STAVAR(J).EQ.3) THEN - X0=UPBND(J) - GO TO 4800 - ELSE - GO TO 9010 - ENDIF - ENDIF -C - IF(C(J)-QJ.GE.OPTTOL) THEN -C -C Fix variable J on its LOWER bound. - IF(MSGLEV.LE.2) GO TO 4310 - WRITE(BUFFER,4301) J,PJ,QJ,C(J),STAVAR(J) - 4301 FORMAT(1X,'cl=',I6,' PJ=',D10.3,' QJ=',D10.3, - X ' Cj=',D10.3,' st=',I6,' goes to LObnd.') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,4302) J,C(J)-QJ - 4302 FORMAT(1X,'Strongly dominated cl=',I6,' Cj-Qj=',D10.3) - CALL MYWRT(IOERR,BUFFER) - 4310 CONTINUE - IF(STAVAR(J).GE.0) THEN - X0=0.0D0 - GO TO 4800 - ELSE - GO TO 9020 - ENDIF - ENDIF -C -C -C Check if the column is weakly dominated. Omit FREE columns, -C columns with entries in EQUALITY rows and singleton columns. - IF(LENCOL(J).LE.1) GO TO 5000 - IF(STAVAR(J).LT.0) GO TO 5000 - IF(MEQ.GE.1) GO TO 5000 -C - IF(MFREE.EQ.0.AND.C(J)-PJ.LE.OPTTOL) THEN -C -C Fix variable J on its UPPER bound. - IF(MSGLEV.LE.2) GO TO 4410 - WRITE(BUFFER,4401) J,PJ,QJ,C(J),STAVAR(J) - 4401 FORMAT(1X,'cl=',I6,' PJ=',D10.3,' QJ=',D10.3, - X ' Cj=',D10.3,' st=',I6,' goes to UPbnd.') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,4402) LENCOL(J),MEQ,MFREE,C(J)-PJ - 4402 FORMAT(1X,'Weak domination, ln=',I6,' meq=',I6, - X ' mfr=',I6,' Cj-Pj=',D10.3) - CALL MYWRT(IOERR,BUFFER) - 4410 CONTINUE - IF(STAVAR(J).EQ.1.OR.STAVAR(J).EQ.3) THEN - X0=UPBND(J) - GO TO 4800 - ELSE -C WRITE(BUFFER,4411) J,UPBND(J) -C4411 FORMAT(1X,'Weak domination, col=',I6,' UP=',D10.3) -C CALL MYWRT(IOERR,BUFFER) - GO TO 5000 - ENDIF - ENDIF -C - IF(MFREE.EQ.LENCOL(J).AND.C(J)-QJ.GE.-OPTTOL) THEN -C -C Fix variable J on its LOWER bound. - IF(MSGLEV.LE.2) GO TO 4510 - WRITE(BUFFER,4501) J,PJ,QJ,C(J),STAVAR(J) - 4501 FORMAT(1X,'cl=',I6,' PJ=',D10.3,' QJ=',D10.3, - X ' Cj=',D10.3,' st=',I6,' goes to LObnd.') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,4502) LENCOL(J),MEQ,MFREE,C(J)-QJ - 4502 FORMAT(1X,'Weak domination, ln=',I6,' meq=',I6, - X ' mfr=',I6,' Cj-Qj=',D10.3) - CALL MYWRT(IOERR,BUFFER) - 4510 CONTINUE - IF(STAVAR(J).GE.0) THEN - X0=0.0D0 - GO TO 4800 - ELSE -C WRITE(BUFFER,4511) J -C4511 FORMAT(1X,'Weak domination, col=',I6,' no LO bnd.') -C CALL MYWRT(IOERR,BUFFER) - GO TO 5000 - ENDIF - ENDIF -C - GO TO 5000 -C -C Eliminate column J. Update RHS. - 4800 NFIXED=NFIXED+1 - PRLVAR(J)=X0 - STAVAR(J)=6 - IF(DABS(X0).LE.FSBTOL) THEN - X0=0.0D0 - GO TO 4900 - ENDIF - DO 4850 K=KBEG,KEND - IR=RWNMBS(K) - B(IR)=B(IR)-X0*ACOEFF(K) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - 4850 CONTINUE - 4900 CONTINUE - IF(MSGLEV.LE.1) GO TO 4902 - WRITE(BUFFER,4901) J,CLNAME(J),X0 - 4901 FORMAT(1X,'ELVRBL: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 4902 CONTINUE -C -C -C -C End of the third main loop. - 5000 CONTINUE -C -C -C -C -C Here if a successful run has been completed. - IF(MSGLEV.LE.0) GO TO 5110 - WRITE(BUFFER,5105) NFIXED - 5105 FORMAT(1X,'ELVRBL: Variables eliminated: ',I9) -C CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,5106) NTIGHT - 5106 FORMAT(1X,' Bounds on shadow prices:',I9) -C CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - 5110 CONTINUE -C -C -C -C -C -C Zero RWHEAD and LENROW arrays. - IF(NFIXED.EQ.0) GO TO 5900 - DO 5200 I=1,M - RWHEAD(I)=0 - LENROW(I)=0 - 5200 CONTINUE -C -C Set the row linked lists. -C Count nonzero elements in all rows of A. - DO 5300 J=1,N -C -C Omit FIXED variables. - IF(STAVAR(J).GE.6) GO TO 5300 - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 5250 K=KBEG,KEND - I=RWNMBS(K) - RWLINK(K)=RWHEAD(I) - CLNMBS(K)=J - RWHEAD(I)=K - LENROW(I)=LENROW(I)+1 - 5250 CONTINUE - 5300 CONTINUE -C -C -C Check if there are inequality type rows to be eliminated. -C Check if the eliminated rows were not violated. - DO 5800 I=1,M - IF(DABS(B(I)).LE.FSBTOL) B(I)=0.0D0 - K=RWHEAD(I) - IF(RWSTAT(I).EQ.1) THEN -C -C Here for EQUALITY constraint. - IF(K.NE.0) GO TO 5800 - IF(DABS(B(I)).GT.FSBTOL) GO TO 9030 - GO TO 5800 - ENDIF - IF(LENROW(I).GE.2) GO TO 5800 - IF(RWSTAT(I).EQ.2) THEN -C -C Here for GREATER OR EQUAL type constraint. - IF(B(I).GT.FSBTOL) GO TO 9030 - RWHEAD(I)=-RWHEAD(I) - J=CLNMBS(K) - STAVAR(J)=14 - GO TO 5800 - ENDIF - IF(RWSTAT(I).EQ.3) THEN -C -C Here for LESS OR EQUAL type constraint. - IF(B(I).LT.-FSBTOL) GO TO 9030 - RWHEAD(I)=-RWHEAD(I) - J=CLNMBS(K) - STAVAR(J)=14 - GO TO 5800 - ENDIF - 5800 CONTINUE - 5900 CONTINUE -C -C -C -C Determine the permutation that puts all empty rows -C at the end of the list. -C - IRUN=3 - IF(MSGLEV.LE.1) IRUN=4 - CALL EMPTYR(MAXM,M,MNEW,IRUN, - X RWHEAD,STAROW,PERM,INVP,IOERR) -C -C -C Reorder the rows of the LP constraint matrix according to -C the permutation resulting from the analysis of EMPTYR. -C Reorder LENROW array accordingly. - IF(MNEW.LT.M) THEN -C - CALL REORDA(MAXM,MAXN,MAXNZA,M,N, - X CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X PERM,INVP,IMTMP1,IROW,RELT, - X RWNAME,STAROW,RWSTAT,RANGES,B,IOERR) -C -C Reorder bounds on shadow prices P and Q. - CALL REORDV(MAXM,M, - X PERM,INVP,P,RELT,IOERR) - CALL REORDV(MAXM,M, - X PERM,INVP,Q,RELT,IOERR) -C -C Set the new number of rows of the constraint matrix. - M=MNEW -C - ENDIF -C -C - RETURN -C - 9010 WRITE(BUFFER,9011) J,CLNAME(J) - 9011 FORMAT(1X,'ELVRBL: Var. ',I6,' (name=',A8, - X ') has no UPPER bound.') - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9012) - 9012 FORMAT(1X,'ELVRBL: Primal is unbounded (or dual infeasible).') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9020 WRITE(BUFFER,9021) J,CLNAME(J) - 9021 FORMAT(1X,'ELVRBL: Var. ',I6,' (name=',A8, - X ') has no LOWER bound.') - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9022) - 9022 FORMAT(1X,'ELVRBL: Primal is unbounded (or dual infeasible).') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9030 WRITE(BUFFER,9031) I,RWNAME(I),B(I) - 9031 FORMAT(1X,'ELVRBL: Constraint ',I6,' (name=',A8, - X ') is violated, B=',D12.6) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9032) - 9032 FORMAT(1X,'ELVRBL: Problem is infeasible.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C -C -C -C *** LAST CARD OF (ELVRBL) *** - END //GO.SYSIN DD hopdm.src/elvrbl.f echo hopdm.src/emptyr.f 1>&2 sed >hopdm.src/emptyr.f <<'//GO.SYSIN DD hopdm.src/emptyr.f' 's/^-//' -C********************************************************** -C **** EMPTYR ... REMOVE EMPTY ROWS FROM A **** -C********************************************************** -C - SUBROUTINE EMPTYR(MAXM,MOLD,MNEW,IRUN, - X RWHEAD,STAROW,PERM,INVP,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXM,MOLD,MNEW,IRUN,IOERR - INTEGER*4 RWHEAD(MAXM) -C -C *** The following arrays can be half-length integer. - INTEGER*2 STAROW(MAXM),PERM(MAXM),INVP(MAXM) -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,IX,K,NEMPTY,NROWOK - CHARACTER*100 BUFFER -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXM Maximum row dimension of the LP constraint matrix. -C MOLD Number of all rows of the LP constraint matrix. -C IRUN Number of the run of the EMPTYR routine. -C RWHEAD Headers to the row linked lists of matrix A. -C STAROW Array of row status: -C 0 row is to be removed (it indicates a free row); -C 1 row is not to be removed. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C MNEW Number of non-empty rows of the LP constraint matrix. -C PERM Permutation that moves empty rows into the end of list. -C INVP Inverse permutation. -C -C -C *** SUBROUTINES CALLED: -C MYWRT -C -C -C *** PURPOSE: -C This routine reorders the rows of the LP constraint -C in order to put the empty ones at the end of the list. -C -C -C *** NOTES: -C -C -C *** REFERENCES: -C Gondzio J. (1991). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization (to appear). -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: April 14, 1993 -C -C -C -C *** BODY OF (EMPTYR) *** -C -C -C -C Set up initial permutations. -C Check if there are empty rows in LP constraint matrix. -C Zero their row status (STAROW array) to mark that they -C have to be removed. - DO 100 I=1,MOLD -C WRITE(BUFFER,101) I,STAROW(I),RWHEAD(I) -C 101 FORMAT(1X,'EMPTYR: i=',I5,' strw=',I6,' rwhd=',I6) -C CALL MYWRT(IOERR,BUFFER) - K=RWHEAD(I) - IF(K.LE.0) THEN - STAROW(I)=0 - RWHEAD(I)=-K -C WRITE(BUFFER,102) I -C 102 FORMAT(1X,'EMPTYR: Row to eliminate found i=',I6) -C CALL MYWRT(IOERR,BUFFER) - ENDIF - 100 CONTINUE -C -C -C Determine the permutation that puts all empty rows -C at the end of the list. - NEMPTY=0 - NROWOK=0 - DO 200 I=1,MOLD - K=STAROW(I) - IF(K.EQ.0) THEN -C WRITE(BUFFER,201) I,MOLD-NEMPTY -C 201 FORMAT(1X,'EMPTYR: Row i=',I6,' is put to ',I6) -C CALL MYWRT(IOERR,BUFFER) - INVP(I)=MOLD-NEMPTY - NEMPTY=NEMPTY+1 - ELSE - NROWOK=NROWOK+1 - INVP(I)=NROWOK - ENDIF - 200 CONTINUE -C -C - DO 300 I=1,MOLD - IX=INVP(I) - PERM(IX)=I - 300 CONTINUE -C -C -C - MNEW=MOLD-NEMPTY - IF(IRUN.EQ.1) NEMPTY=NEMPTY-1 - IF(IRUN.LE.2) THEN - IF(NEMPTY.GT.0) THEN - WRITE(BUFFER,501) NEMPTY - 501 FORMAT(1X,'EMPTYR:',I9,' empty rows found in A.') - CALL MYWRT(IOERR,BUFFER) - ENDIF - ENDIF - IF(IRUN.EQ.3) THEN - IF(NEMPTY.GT.0) THEN - WRITE(BUFFER,502) NEMPTY - 502 FORMAT(1X,'EMPTYR: Rows eliminated from A',3X,I8) - CALL MYWRT(IOERR,BUFFER) - ENDIF - ENDIF -C - RETURN -C -C *** LAST CARD OF (EMPTYR) *** - END //GO.SYSIN DD hopdm.src/emptyr.f echo hopdm.src/errwrt.f 1>&2 sed >hopdm.src/errwrt.f <<'//GO.SYSIN DD hopdm.src/errwrt.f' 's/^-//' -C************************************************** -C ** ERRWRT ... WRITE AN ERROR MESSAGE ** -C************************************************** -C - SUBROUTINE ERRWRT(IOLOG,BUFFER) -C -C -C *** PARAMETERS - INTEGER*4 IOLOG - CHARACTER*100 BUFFER -C -C -C *** PARAMETER DESCRIPTION -C IOLOG Output unit number where the message is to be written. -C BUFFER Message to be written. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: November 5, 1992 -C -C -C *** BODY OF (ERRWRT) *** -C - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOLOG,BUFFER) - RETURN -C -C *** LAST CARD OF (ERRWRT) *** - END //GO.SYSIN DD hopdm.src/errwrt.f echo hopdm.src/factor.f 1>&2 sed >hopdm.src/factor.f <<'//GO.SYSIN DD hopdm.src/factor.f' 's/^-//' -C******************************************************************** -C *** FACTOR ... CHOLESKY FACATORIZATION OF A*THETA*Atransp *** -C******************************************************************** -C - SUBROUTINE FACTOR(MAXM,MAXN,MAXNZA,MAXNZL,M, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK, - X ITEMP1,RTEMP1, - X HEADER,LINKFD,LINKBK, - X THETA,STAVAR, - X LCOEFF,LDIAG,LDSQRT,LCLPTS,LRWNBS,MKSQRT,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXM,MAXN,MAXNZA,MAXNZL,M,LIWORK,LRWORK,MKSQRT,IOERR - INTEGER*4 ITEMP1(MAXN) - DOUBLE PRECISION RTEMP1(MAXM) - INTEGER*2 HEADER(MAXM+1),LINKFD(MAXM+1),LINKBK(MAXM+1) - DOUBLE PRECISION THETA(MAXN) - INTEGER*2 STAVAR(MAXN) -C -C *** DATA STRUCTURES FOR CHOLESKY FACTOR - DOUBLE PRECISION LCOEFF(*) - DOUBLE PRECISION LDIAG(MAXM),LDSQRT(MAXM) - INTEGER*4 LCLPTS(MAXM+1) - INTEGER*2 LRWNBS(MAXNZL) -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(LIWORK),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(LRWORK) -C -C -C -C *** LOCAL VARIABLES -C -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C ITEMP1 Integer work array. -C RTEMP1 Double precision work array. -C HEADER Header of the doubly linked lists. -C LINKFD Forward linked lists. -C LINKBK Backward linked lists. -C THETA Diagonal weight matrix. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k free variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicate the position of the original variable. -C MKSQRT Parameter indicating if square roots of LDIAG are to be -C computed: -C 0 no square roots necessary; -C 1 compute square roots of diagonal matrix. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C LCOEFF Off-diagonal nonzero coefficients of Cholesky matrix. -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C LDIAG Diagonal elements of Cholesky factor. -C LDSQRT Square roots of the diagonal elements of Cholesky factor. -C -C -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real work array containing almost all real -C LP problem data. -C IWORK Integer work array containing almost all integer -C LP problem data. -C RMAP Map of RWORK. -C IMAP Map of IWORK. -C -C Map of IWORK array: -C IMAP(1) Points to CLPNTS array. -C IMAP(2) Points to RWNMBS array. -C IMAP(3) Points to RWHEAD array. -C IMAP(4) Points to RWLINK array. -C IMAP(5) Points to CLNMBS array. -C IMAP(6) Points to LENCOL array. -C IMAP(7) Points to the first empty cell of IWORK array. -C -C Map of RWORK array: -C RMAP(1) Points to ACOEFF array. -C RMAP(2) Points to COBJ array. -C RMAP(3) Points to RHS array. -C RMAP(4) Points to the first empty cell of RWORK array. -C -C -C -C -C -C *** SUBROUTINES CALLED: -C LDAAT,NUMFCT -C -C -C *** PURPOSE: -C This routine computes Cholesky decomposition -C L*D*Ltransp of A*THETA*Atransp. -C -C It does this in the following two steps: -C (i) construction of A*THETA*Atransp matrix and packing -C it in a data structures for the Cholesky factor -C (fill-in positions are zeroed). -C (ii) computing the Cholesky decomposition. -C -C -C -C *** NOTES: -C This routine is an interface between IPMLO library for -C linear optimization with interior point methods and the -C library of routines for handling the Cholesky decomposition -C of a sparse positive definite systems. -C -C -C *** REFERENCES: -C Gondzio J. (1991). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization (to appear). -C Gondzio J., Tachat D. (1992). The design and application -C of IPMLO - a FORTRAN library for linear optimization -C with interior point methods, Technical Report No 108, -C LAMSADE, University of Paris Dauphine, 75775 Paris Cedex 16, -C France, January 1992, revised in November 1992. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: May 19, 1991 -C Last modified: May 12, 1993 -C -C -C -C *** BODY OF (FACTOR) *** -C -C -C Load the A*THETA*Atransp matrix into the data structures -C for Cholesky factor L (zero all fill-in positions). -C - CALL LDAAT(RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)), - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)), - X THETA,STAVAR,MAXNZL,MAXM,MAXN,MAXNZA,M, - X LCOEFF,LCLPTS,LRWNBS,LDIAG,RTEMP1,IOERR) -C -C -C Decompose the A*THETA*Atransp matrix. -C - CALL NUMFCT(LCOEFF,LCLPTS,LRWNBS,LDIAG,LDSQRT, - X MAXNZL,MAXM,M,MKSQRT, - X HEADER,LINKFD,LINKBK,ITEMP1,RTEMP1,IOERR) -C -C - RETURN -C -C *** LAST CARD OF (FACTOR) *** - END //GO.SYSIN DD hopdm.src/factor.f echo hopdm.src/fdaggr.f 1>&2 sed >hopdm.src/fdaggr.f <<'//GO.SYSIN DD hopdm.src/fdaggr.f' 's/^-//' -C************************************************ -C *** FDAGGR ... FIND AGGREGATE VARIABLES *** -C************************************************ -C - SUBROUTINE FDAGGR(IOERR,MSGLEV,LEVPRS, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X RWORK,IWORK,RMAP,IMAP,IROW,RELT, - X IMTMP1,RMTMP1,INTMP1,RNTMP1,RNTMP2,RNTMP3, - X B,RANGES,C,LOBND,UPBND,BNDBIG, - X ACOEFF,CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X P,Q,PRLVAR,STAVAR,RWSTAT,STAROW,RWNAME,CLNAME, - X IAGGR,MARKER,LENROW) -C -C -C -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(*),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(*) -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real work array that contains real LP problem data. -C IWORK Integer work array that contains integer LP problem data. -C RMAP Map of RWORK array. -C IMAP Map of IWORK array. -C -C -C -C -C *** PARAMETERS - INTEGER*4 IOERR,MSGLEV,LEVPRS - INTEGER*4 MAXM,MAXN,MAXNZA,M,N,NSTRCT - INTEGER*4 LNHIST,MXHIST,IROW(MAXN),IMTMP1(MAXM),INTMP1(MAXN) - INTEGER*2 INHIST(MXHIST) - DOUBLE PRECISION DPHIST(MXHIST) - DOUBLE PRECISION RELT(MAXN),RMTMP1(MAXM) - DOUBLE PRECISION RNTMP1(MAXN),RNTMP2(MAXN),RNTMP3(MAXN) - DOUBLE PRECISION ACOEFF(MAXNZA),B(MAXM),RANGES(MAXM) - DOUBLE PRECISION C(MAXN),LOBND(MAXN),UPBND(MAXN),BNDBIG - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM+1),RWLINK(MAXNZA) - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) - DOUBLE PRECISION P(MAXM),Q(MAXM),PRLVAR(MAXN) - CHARACTER*8 RWNAME(MAXM),CLNAME(MAXN) - INTEGER*2 STAVAR(MAXN),STAROW(MAXM),RWSTAT(MAXM) - INTEGER*2 IAGGR(MAXN),LENROW(MAXM),MARKER(MAXM) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 NAGGR,NELIM,NEL0,NFIXED,NFREE,NIDEN,NTIGHT,NT0,N1 - INTEGER*4 I,IHEAD,IKX,IPOS,IR,IRUN,J,J1,JCOL,KSTAT,KROW - INTEGER*4 K,K1,KBEG,KEND,K2,K2BEG,K2END,KOK,KOUT,KRWBEG - INTEGER*4 LROW,LIMIT,MNEW,NNEG,NPOS,NNEGBG,NPOSBG,KNEGBG,KPOSBG - DOUBLE PRECISION ALPHA,BIG,BIGNEW,BNDNEW,BNDJLO,BNDJUP,DP,X0 - DOUBLE PRECISION RNRM,RHS0,BLOWER,BUPPER,FSBTOL,BNDTOL,SMALLA - CHARACTER*100 BUFFER - CHARACTER*2 RTYPE -C -C *** LOCAL VARIABLES USED BY THE ONE-ROW SIMPLEX - INTEGER*4 NMAX,NX,NXSTR,ROWST - DOUBLE PRECISION COEFF(100),X(100),COBJ(100),UPPER(100) - DOUBLE PRECISION RDCOST(100),RHS,PI,QI,DUAL -C -C -C -C -C *** PARAMETERS DESCRIPTION -C -C *** ON INPUT: -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C MSGLEV The level of PRE_SOLVE information desired: -C 0 only final problem dimensions are printed; -C 1 numbers of eliminated rows and columns are printed; -C 2 names of eliminated rows and columns are printed; -C 3 detailed DEBUGGING information is printed. -C LEVPRS The level of PRE_SOLVE desired: -C 0 only splitting dense columns; -C 1 incomplete analysis (no tightening UPPER bounds); -C 2 maximum analysis possible. -C MAXM Maximum number of constraints. -C MAXN Maximum number of variables. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of constraints. -C N Number of variables (total, i.e. including slacks, -C surplus and artificials). -C NSTRCT Number of structural variables (excluding slacks, -C surplus and artificials). -C LNHIST Length of the PRE_SOLVE history list. -C MXHIST Maximum number of entries in the PRE_SOLVE history list. -C INHIST Integer PRE_SOLVE history information. -C DPHIST Double precision PRE_SOLVE history information. -C ACOEFF Array of nonzero elements for each column. -C B Right hand side of the linear program. -C RANGES Array of constraint ranges. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C LENCOL Lengths of (sparse) columns of matrix A. -C LOBND Array of lower bounds. -C UPBND Array of upper bounds. Note that the upper bound -C is changed when the variable has a lower bound. -C BNDBIG Value of an unacceptably large implicit bound. -C P LOWER bounds on shadow prices (dual variables). -C Q UPPER bounds on shadow prices (dual variables). -C PRLVAR Primal variables of the linear program. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C RWSTAT Array of row types: -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 objective row; -C 5 other free row. -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C RWNAME Array of row names (increasing order sort). -C CLNAME Array of column names (unordered). -C LENROW Lengths of (sparse) rows of matrix A. -C -C *** ON OUTPUT: -C -C -C -C -C *** WORK ARRAYS: -C IROW and RELT are the arrays for temporary handling of rows -C and columns of the constraint matrix. They are primarily -C intended to handle sparse vectors (in packed form) -C but may also be used for storing dense ones. -C IMTMP1 Integer work array of size MAXM. -C INTMP1 Positions of pivot elements in aggregate columns. -C RMTMP1 Nonzero elements of the analysed column. -C RNTMP1 LOWER bounds for aggregate variables. -C RNTMP2 UPPER bounds for aggregate variables. -C RNTMP3 Linear combination of an aggregate variable. -C IAGGR Linked lists of aggregate variables. -C MARKER Marker for rows that define aggregate variables -C (such rows cannot be removed). -C -C -C -C -C *** PURPOSE -C This routine finds variables that have identical structure. -C It then builds an aggregate column and checks if such a column -C can be eliminated. -C -C -C -C *** SUBROUTINES CALLED -C MYWRT,DABS,EMPTYR,REORDA,REORDI,REORDV,SMPLX -C -C -C *** NOTES: -C -C -C -C *** REFERENCES: -C Gondzio J. (1994). Presolve analysis of linear programs prior -C to applying an interior point method, Technical Report -C No 1994.3, Department of Management Studies, University -C of Geneva, 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, -C February 1994, revised in December 1994. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: January 29, 1993 -C Last modified: March 29, 1995 -C -C -C -C -C *** BODY OF (FDAGGR) *** -C -C -C -C Initialize. - BIG=1.0D+30 - BIGNEW=1.0D+20 - FSBTOL=5.0D-8 - BNDTOL=1.0D-5 - SMALLA=1.0D-8 - NELIM=0 - NFIXED=0 - NTIGHT=0 -C -C -C -C -C Zero MARKER, LENROW and RMTMP1 arrays. - DO 100 I=1,M - MARKER(I)=0 - LENROW(I)=0 - RMTMP1(I)=0.0D0 - 100 CONTINUE -C -C Zero IAGGR and INTMP1 arrays. -C Count nonzero elements in all rows of A. -C Count FREE and still active structural variables. -C Define LOWER and UPPER bounds for aggregate columns. - NFREE=0 - N1=0 - DO 160 J=1,NSTRCT - IAGGR(J)=0 - INTMP1(J)=0 - KSTAT=STAVAR(J) - IF(KSTAT.GE.6) GO TO 160 - N1=N1+1 - IF(KSTAT.LT.0) NFREE=NFREE+1 - RNTMP1(J)=0.0D0 - RNTMP2(J)=BIG - IF(KSTAT.EQ.1.OR.KSTAT.EQ.3) RNTMP2(J)=UPBND(J) - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 140 K=KBEG,KEND - IR=RWNMBS(K) - LENROW(IR)=LENROW(IR)+1 - 140 CONTINUE - 160 CONTINUE - NFREE=NFREE/2 -C -C -C -C -C -C -C First main loop begins here. -C Loop over all (active) structural columns of A. -C -C Build linked lists of aggregate columns. -C Define LOWER and UPPER bounds for aggregate columns. -C Count AGGREGATE variables. - NAGGR=0 - DO 1000 J=1,NSTRCT - IF(STAVAR(J).GE.6) GO TO 1000 - IF(LENCOL(J).EQ.0) GO TO 1000 - IF(IAGGR(J).GT.0) GO TO 1000 -C -C -C Save nonzero elements of column J in RMTMP1 array. -C Determine the shortest row with an entry in column J. -C Equality-type rows are prefered if ties are to be broken. - KROW=0 - LROW=NSTRCT+1 - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 380 K=KBEG,KEND - IR=RWNMBS(K) - RMTMP1(IR)=ACOEFF(K) - IF(LENROW(IR)-LROW) 360,340,380 - 340 IF(RWSTAT(IR).NE.1) GO TO 380 - 360 LROW=LENROW(IR) - KROW=IR - KOK=K - 380 CONTINUE -C -C Save position of the pivot element in INTMP1 array. - INTMP1(J)=KOK - IF(KROW.EQ.0) GO TO 940 -C -C Analyse all columns that have entries in row KROW. -C Look for a column with identical sparsity structure as column J. - NIDEN=1 - IHEAD=J - BLOWER=RNTMP1(J) - BUPPER=RNTMP2(J) - IPOS=RWHEAD(KROW) - IF(RWSTAT(KROW).GE.2) IPOS=RWLINK(IPOS) - 400 IF(IPOS.EQ.0) GO TO 810 - JCOL=CLNMBS(IPOS) - IF(LENCOL(JCOL).NE.LENCOL(J)) GO TO 800 - IF(STAVAR(JCOL).GE.6) GO TO 800 - IF(IAGGR(J).GT.0) GO TO 800 - IF(JCOL.LE.J) GO TO 800 -C -C -C Here if two columns J and JCOL have the same length. - K2BEG=CLPNTS(JCOL) - K2END=K2BEG+LENCOL(JCOL)-1 -C -C -C -C Check if columns J and JCOL are linearly dependent. - IR=RWNMBS(K2BEG) - ALPHA=RMTMP1(IR)/ACOEFF(K2BEG) - DO 500 K2=K2BEG+1,K2END - IR=RWNMBS(K2) - DP=DABS(RMTMP1(IR)/ACOEFF(K2)-ALPHA) - IF(DP.GE.SMALLA) GO TO 800 - 500 CONTINUE -C -C -C Here if two columns J and JCOL are linearly dependent. - IF(MSGLEV.LE.2) GO TO 510 - WRITE(BUFFER,501) CLNAME(J),CLNAME(JCOL) - 501 FORMAT(1X,'FDAGGR: LP variables: ', - X A8,' and ',A8,' are linearly dependent.') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,502) J,C(J),STAVAR(J),LENCOL(J) - 502 FORMAT(1X,' var=',I6,' Cj=',D14.8,' st=',I6,' ln=',I6) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,503) JCOL,C(JCOL),STAVAR(JCOL),LENCOL(JCOL) - 503 FORMAT(1X,'and var=',I6,' Cj=',D14.8,' st=',I6,' ln=',I6) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,504) J,JCOL,ALPHA - 504 FORMAT(1X,'FDAGGR: J=',I6,' JCOL=',I6,' ALPHA=',D14.8) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,505) KROW,RWSTAT(KROW),LROW - 505 FORMAT(1X,' row=',I5,' rwstat=',I5,' len=',I5) - CALL MYWRT(IOERR,BUFFER) - 510 CONTINUE -C -C -C Save information on the aggregate column. -C Mark row that defines aggregate variable. -C Add column JCOL to the linked list. -C Update LOWER and UPPER bounds of the aggregate variable. -C Save the linear dependency of columns in RNTMP3 array. - NIDEN=NIDEN+1 - RNTMP3(JCOL)=1.0D0/ALPHA - IAGGR(JCOL)=IHEAD - IHEAD=JCOL - KSTAT=STAVAR(JCOL) - BNDJUP=BIG - IF(KSTAT.EQ.1.OR.KSTAT.EQ.3) BNDJUP=UPBND(JCOL) - DP=ACOEFF(IPOS)/ACOEFF(KOK) - IF(DP.LT.0.0D0) THEN - BLOWER=BLOWER+BNDJUP*DP - ELSE - BUPPER=BUPPER+BNDJUP*DP - ENDIF -C -C -C - 800 IPOS=RWLINK(IPOS) - GO TO 400 -C -C -C Save LOWER and UPPER bounds of the aggregate variable. -C Close the linked list (to allow wrap around). - 810 IF(NIDEN.GE.2) THEN - NAGGR=NAGGR+1 - IAGGR(J)=-IHEAD - RNTMP3(J)=1.0D0 - MARKER(KROW)=MARKER(KROW)+1 - ENDIF - RNTMP1(J)=BLOWER - RNTMP2(J)=BUPPER -C -C -C Restore zero value of RMTMP1 array. - 940 DO 960 K=KBEG,KEND - IR=RWNMBS(K) - RMTMP1(IR)=0.0D0 - 960 CONTINUE -C -C -C *** Debugging. - IF(NIDEN.LE.1) GO TO 970 - IF(MSGLEV.LE.2) GO TO 970 - WRITE(BUFFER,961) J,LENCOL(J),NIDEN - 961 FORMAT(1X,'FDAGGR: Aggr. var=',I6,' ln=',I6,' NIDEN=',I6) - CALL MYWRT(IOERR,BUFFER) -C WRITE(BUFFER,962) P(KROW),Q(KROW) -C 962 FORMAT(1X,' P=',D14.8,' Q=',D14.8) -C CALL MYWRT(IOERR,BUFFER) -C WRITE(BUFFER,963) BLOWER,BUPPER -C 963 FORMAT(1X,' LO bnd=',D14.8,' UP bnd=',D14.8) -C CALL MYWRT(IOERR,BUFFER) - 970 CONTINUE -C -C -C -C -C -C -C End of the first main loop. - 1000 CONTINUE -C -C Check if RMTMP1 array is zero. - DO 1010 I=1,M - IF(DABS(RMTMP1(I)).GE.SMALLA) THEN - WRITE(BUFFER,1011) I,RMTMP1(I) - 1011 FORMAT(1X,'FDAGGR ERROR: RMTMP1(',I6,')=',D14.8) - CALL ERRWRT(IOERR,BUFFER) - STOP - ENDIF - 1010 CONTINUE -C -C -C Check if there exist aggregate variables. - IF(NAGGR.EQ.0) GO TO 6000 -C -C -C -C -C -C -C Compute norms of the LP constraints. - DO 1050 I=1,M - RMTMP1(I)=1.0D-4+DABS(B(I)) - 1050 CONTINUE - DO 1080 J=1,NSTRCT - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 1060 K=KBEG,KEND - I=RWNMBS(K) - IF(DABS(ACOEFF(K)).GT.RMTMP1(I)) RMTMP1(I)=DABS(ACOEFF(K)) - 1060 CONTINUE - 1080 CONTINUE - DO 1090 I=1,M - RNRM=SMALLA*RMTMP1(I) - IF(RNRM.LE.FSBTOL) RNRM=FSBTOL - IF(RNRM.GE.1.0D-6) RNRM=1.0D-6 - IF(DABS(B(I)).LE.RNRM) B(I)=0.0D0 -C IF(RMTMP1(I).LE.1.0E-15) GO TO 1090 -C IF(RMTMP1(I).LE.1.0E-2) THEN -C WRITE(BUFFER,1091) I,RMTMP1(I) -C1091 FORMAT(1X,' FDAGGR: row=',I6,' has norm=',D10.3) -C CALL MYWRT(IOERR,BUFFER) -C ENDIF - 1090 CONTINUE -C -C -C -C -C -C -C Second main loop begins here. -C Loop over all (yet uneliminated) LP constraints. -C Eliminate redundant constraints. - IRUN=1 - 1200 NT0=NTIGHT - NEL0=NELIM - DO 2000 I=1,M - IF(RWHEAD(I).LE.0) GO TO 2000 - KRWBEG=RWHEAD(I) - IPOS=KRWBEG - IF(RWSTAT(I).GE.2) IPOS=RWLINK(KRWBEG) -C -C Compute LOWER and UPPER limits of the LP constraint. -C Loop over nonzero entries of row I. - BLOWER=0.0D0 - BUPPER=0.0D0 - 1300 IF(IPOS.EQ.0) GO TO 1400 - J=CLNMBS(IPOS) - K=STAVAR(J) - IF(K.GE.6) GO TO 1360 - IF(IAGGR(J)) 1340,1340,1360 - 1340 BNDJLO=RNTMP1(J) - BNDJUP=RNTMP2(J) - IF(ACOEFF(IPOS).LT.0.0D0) THEN - BLOWER=BLOWER+BNDJUP*ACOEFF(IPOS) - BUPPER=BUPPER+BNDJLO*ACOEFF(IPOS) - ELSE - BLOWER=BLOWER+BNDJLO*ACOEFF(IPOS) - BUPPER=BUPPER+BNDJUP*ACOEFF(IPOS) - ENDIF - 1360 IPOS=RWLINK(IPOS) - GO TO 1300 -C - 1400 CONTINUE - RNRM=SMALLA*(RMTMP1(I)+DABS(B(I))) - IF(RNRM.LE.FSBTOL) RNRM=FSBTOL - IF(RNRM.GE.1.0D-6) RNRM=1.0D-6 - IF(DABS(BLOWER-B(I)).LE.RNRM) BLOWER=B(I) - IF(DABS(BUPPER-B(I)).LE.RNRM) BUPPER=B(I) -C RTYPE='EQ' -C IF(RWSTAT(I).EQ.2) RTYPE='GE' -C IF(RWSTAT(I).EQ.3) RTYPE='LE' -C WRITE(BUFFER,1401) I,RTYPE,BLOWER,BUPPER,B(I) -C1401 FORMAT(1X,'row=',I6,' type=',A2, -C X ' BLO=',D10.3,' BUP=',D10.3,' RHS=',D10.3) -C CALL MYWRT(IOERR,BUFFER) -C -C -C - IF(RWSTAT(I).EQ.1) THEN -C -C Here for EQUALITY type constraint. - RTYPE='EQ' - IF(BLOWER-B(I).GT.-FSBTOL) THEN - IF(BLOWER-B(I).GT.FSBTOL) GO TO 9010 - LIMIT=0 - GO TO 1500 - ENDIF - IF(BUPPER-B(I).LT.FSBTOL) THEN - IF(BUPPER-B(I).LT.-FSBTOL) GO TO 9010 - LIMIT=1 - GO TO 1500 - ENDIF - GO TO 2000 - ENDIF -C -C -C - IF(RWSTAT(I).EQ.2) THEN -C -C Here for GREATER OR EQUAL type constraint. - RTYPE='GE' - IF(BUPPER-B(I).LT.FSBTOL) THEN - IF(BUPPER-B(I).LT.-FSBTOL) GO TO 9010 - LIMIT=1 - GO TO 1500 - ENDIF - IF(BLOWER-B(I).GT.-FSBTOL) THEN - LIMIT=-1 - GO TO 1500 - ENDIF - ENDIF -C -C -C - IF(RWSTAT(I).EQ.3) THEN -C -C Here for LESS OR EQUAL type constraint. - RTYPE='LE' - IF(BLOWER-B(I).GT.-FSBTOL) THEN - IF(BLOWER-B(I).GT.FSBTOL) GO TO 9010 - LIMIT=0 - GO TO 1500 - ENDIF - IF(BUPPER-B(I).LT.FSBTOL) THEN - LIMIT=-1 - GO TO 1500 - ENDIF - ENDIF -C -C -C - GO TO 2000 -C -C -C -C Here to eliminate the LP constraint. -C Do not eliminate the row if it defines an aggregate. - 1500 IF(MARKER(I).GT.0) THEN -C WRITE(BUFFER,1501) I,MARKER(I) -C1501 FORMAT(1X,'FDAGGR: Row ',I6, -C X ' cannot be eliminated, MARKER=',I3) -C CALL MYWRT(IOERR,BUFFER) -C WRITE(BUFFER,1502) I,RTYPE,BLOWER,BUPPER,B(I) -C1502 FORMAT(1X,'row=',I6,' type=',A2, -C X ' BLO=',D10.3,' BUP=',D10.3,' RHS=',D10.3) -C CALL MYWRT(IOERR,BUFFER) - IF(LIMIT.EQ.-1) GO TO 2000 - GO TO 1580 - ENDIF - NELIM=NELIM+1 - RWHEAD(I)=-RWHEAD(I) -C -C *** DEBUGGING - IF(MSGLEV.LE.1) GO TO 1504 - WRITE(BUFFER,1503) I,RWNAME(I),RTYPE - 1503 FORMAT(1X,'FDAGGR: Row ',I6,' (name=',A8, - X ' type=',A2,') is eliminated.') - CALL MYWRT(IOERR,BUFFER) - 1504 CONTINUE - IF(MSGLEV.LE.2) GO TO 1510 - WRITE(BUFFER,1505) I,RTYPE,BLOWER,BUPPER,B(I) - 1505 FORMAT(1X,'row=',I6,' type=',A2, - X ' BLO=',D10.3,' BUP=',D10.3,' RHS=',D10.3) - CALL MYWRT(IOERR,BUFFER) - 1510 CONTINUE -C - IF(LIMIT.EQ.-1) THEN - NFIXED=NFIXED+1 - J=CLNMBS(KRWBEG) - PRLVAR(J)=0.0D0 - STAVAR(J)=14 - GO TO 2000 - ENDIF -C -C Here to eliminate the constraint and fix variables. -C Loop over nonzero entries of row I. - 1580 IPOS=KRWBEG - IF(RWSTAT(I).GE.2) IPOS=RWLINK(IPOS) - 1600 IF(IPOS.EQ.0) GO TO 1800 - J=CLNMBS(IPOS) - IF(STAVAR(J).GE.6) GO TO 1750 - IF(IAGGR(J)) 1640,1680,1750 -C -C Here for an aggregate variable. - 1640 IF(ACOEFF(IPOS).LT.0.0D0) THEN - IF(LIMIT.EQ.0) RNTMP1(J)=RNTMP2(J) - IF(LIMIT.EQ.1) RNTMP2(J)=RNTMP1(J) - ELSE - IF(LIMIT.EQ.0) RNTMP2(J)=RNTMP1(J) - IF(LIMIT.EQ.1) RNTMP1(J)=RNTMP2(J) - ENDIF - IF(MSGLEV.LE.1) GO TO 1642 - WRITE(BUFFER,1641) J,RNTMP1(J) - 1641 FORMAT(1X,'FDAGGR: Variable ',I6, - X ' (aggregate) is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 1642 CONTINUE - GO TO 1750 -C -C Here for a standard LP variable. - 1680 IF(ACOEFF(IPOS).LT.0.0D0) THEN - IF(LIMIT.EQ.0) X0=UPBND(J) - IF(LIMIT.EQ.1) X0=0.0D0 - ELSE - IF(LIMIT.EQ.0) X0=0.0D0 - IF(LIMIT.EQ.1) X0=UPBND(J) - ENDIF -C -C Fix and eliminate column J. Omit already FIXED variables. -C Update RHS array. - NFIXED=NFIXED+1 - IF(DABS(X0).LE.FSBTOL) X0=0.0D0 - PRLVAR(J)=X0 - STAVAR(J)=6 - IF(DABS(X0).LE.FSBTOL) GO TO 1720 - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 1700 K=KBEG,KEND - IR=RWNMBS(K) - B(IR)=B(IR)-X0*ACOEFF(K) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - 1700 CONTINUE - 1720 CONTINUE - IF(MSGLEV.LE.1) GO TO 1722 - WRITE(BUFFER,1721) J,CLNAME(J),X0 - 1721 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 1722 CONTINUE -C - 1750 IPOS=RWLINK(IPOS) - GO TO 1600 -C -C -C Remove slack variable of an inequality-type constraint. - 1800 IF(MARKER(I).GT.0) GO TO 2000 - IF(RWSTAT(I).EQ.1) GO TO 2000 - NFIXED=NFIXED+1 - J=CLNMBS(KRWBEG) - PRLVAR(J)=0.0D0 - STAVAR(J)=14 -C -C -C -C -C -C End of the second main loop. - 2000 CONTINUE -C -C -C -C -C -C -C Third main loop begins here. -C Loop over all (yet uneliminated) LP constraints. -C Tighten bounds on variables. -C NNEG Number of negative entries in a given row. -C NPOS Number of positive entries in a given row. -C NNEGBG Number of negative entries with an infinite UP bound -C and positive entries with an infinite LO bound. -C NPOSBG Number of positive entries with an infinite UP bound. -C and negative entries with an infinite LO bound. - DO 3000 I=1,M - IF(RWHEAD(I).LE.0) GO TO 3000 - RHS0=B(I) - RTYPE='EQ' - IF(RWSTAT(I).EQ.2) RTYPE='GE' - IF(RWSTAT(I).EQ.3) RTYPE='LE' -C -C -C Compute LOWER and UPPER limits of the LP constraint. - KRWBEG=RWHEAD(I) - IF(RWSTAT(I).GE.2) KRWBEG=RWLINK(KRWBEG) - BLOWER=0.0D0 - BUPPER=0.0D0 - NPOS=0 - NNEG=0 - NPOSBG=0 - NNEGBG=0 -C -C -C -C Loop over nonzero entries of row I. -C After this loop: -C if NNEGBG > 0, then BLOWER = - Inf, -C if NPOSBG > 0, then BUPPER = + Inf. - IPOS=KRWBEG - 2100 IF(IPOS.EQ.0) GO TO 2200 - J=CLNMBS(IPOS) - K=STAVAR(J) - IF(K.GE.6) GO TO 2160 - IF(IAGGR(J)) 2120,2140,2160 -C -C Here for an aggregate variable: RNTMP1(j) <= Xj <= RNTMP2(j). - 2120 BNDJLO=RNTMP1(J) - BNDJUP=RNTMP2(J) - IF(ACOEFF(IPOS).LT.0.0D0) THEN - NNEG=NNEG+1 - IF(BNDJUP.GT.BIGNEW) THEN - NNEGBG=NNEGBG+1 - KNEGBG=IPOS - ELSE - BLOWER=BLOWER+BNDJUP*ACOEFF(IPOS) - ENDIF - IF(BNDJLO.LT.-BIGNEW) THEN - NPOSBG=NPOSBG+1 - KPOSBG=IPOS - ELSE - BUPPER=BUPPER+BNDJLO*ACOEFF(IPOS) - ENDIF - ELSE - NPOS=NPOS+1 - IF(BNDJUP.GT.BIGNEW) THEN - NPOSBG=NPOSBG+1 - KPOSBG=IPOS - ELSE - BUPPER=BUPPER+BNDJUP*ACOEFF(IPOS) - ENDIF - IF(BNDJLO.LT.-BIGNEW) THEN - NNEGBG=NNEGBG+1 - KNEGBG=IPOS - ELSE - BLOWER=BLOWER+BNDJLO*ACOEFF(IPOS) - ENDIF - ENDIF - GO TO 2160 -C -C Here for a standard LP variable: 0 <= Xj <= RNTMP2(j). - 2140 BNDJUP=RNTMP2(J) - IF(ACOEFF(IPOS).LT.0.0D0) THEN - NNEG=NNEG+1 - IF(BNDJUP.GT.BIGNEW) THEN - NNEGBG=NNEGBG+1 - KNEGBG=IPOS - ELSE - BLOWER=BLOWER+BNDJUP*ACOEFF(IPOS) - ENDIF - ELSE - NPOS=NPOS+1 - IF(BNDJUP.GT.BIGNEW) THEN - NPOSBG=NPOSBG+1 - KPOSBG=IPOS - ELSE - BUPPER=BUPPER+BNDJUP*ACOEFF(IPOS) - ENDIF - ENDIF - 2160 IPOS=RWLINK(IPOS) - GO TO 2100 -C -C -C - 2200 CONTINUE - RNRM=SMALLA*(RMTMP1(I)+DABS(B(I))) - IF(RNRM.LE.FSBTOL) RNRM=FSBTOL - IF(RNRM.GE.1.0D-6) RNRM=1.0D-6 - IF(DABS(BLOWER-B(I)).LE.RNRM) BLOWER=B(I) - IF(DABS(BUPPER-B(I)).LE.RNRM) BUPPER=B(I) -C -C *** DEBUGGING - IF(MSGLEV.LE.2) GO TO 2210 - WRITE(BUFFER,2201) I,RTYPE,BLOWER,BUPPER,B(I) - 2201 FORMAT(1X,'Row=',I6,' type=',A2, - X ' BLO=',D10.3,' BUP=',D10.3,' RHS=',D10.3) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,2202) NPOS,NNEG,NPOSBG,NNEGBG - 2202 FORMAT(1X,' Npos=',I5,' Nneg=',I5, - X ' Nposbg=',I5,' Nnegbg=',I5) - CALL MYWRT(IOERR,BUFFER) - 2210 CONTINUE -C -C -C - IF(RWSTAT(I).EQ.1.OR.RWSTAT(I).EQ.3) THEN -C -C Here for EQUALITY type or LESS OR EQUAL type constraint. - IF(BLOWER-RHS0.GT.FSBTOL.AND.NNEGBG.EQ.0) GO TO 9020 - IF(NNEGBG.GE.1) GO TO 2400 -C -C -C Here if there are no negative entries with BIG Uj -C and there are no positive entries with BIG Lj, -C i.e. BLOWER is finite. -C -C Loop over nonzero entries of row I. - BLOWER=RHS0-BLOWER - IPOS=KRWBEG - 2300 IF(IPOS.EQ.0) GO TO 2380 - J=CLNMBS(IPOS) - K=STAVAR(J) - IF(K.GE.6) GO TO 2360 - IF(IAGGR(J).GT.0) GO TO 2360 - IF(ACOEFF(IPOS).GT.0.0D0) THEN -C -C Implicit UPPER bound can be defined for each variable -C refering to POSITIVE entry of row I. - BNDJUP=RNTMP2(J) - BNDNEW=RNTMP1(J)+BLOWER/ACOEFF(IPOS) - IF(BNDNEW.GE.BNDJUP-BNDTOL) GO TO 2360 -C IF(BNDNEW.GE.BNDBIG) GO TO 2360 -C IF(BNDNEW.GE.BNDBIG) THEN -C IF(IAGGR(J).EQ.0) GO TO 2360 -C ENDIF - IF(BNDNEW.GE.BNDBIG) THEN - IF((K.EQ.0.OR.K.EQ.2).AND. - X IAGGR(J).EQ.0) GO TO 2360 - ENDIF - IF(LEVPRS.LE.1) GO TO 2360 - NTIGHT=NTIGHT+1 - RNTMP2(J)=BNDNEW - IF(IAGGR(J).EQ.0) THEN - UPBND(J)=BNDNEW - IF(K.NE.1.AND.K.NE.3) STAVAR(J)=STAVAR(J)+1 - ENDIF -C - IF(MSGLEV.LE.1) GO TO 2304 -C WRITE(BUFFER,2301) J,STAVAR(J),BNDJUP,BNDNEW -C2301 FORMAT(1X,'cl=',I6,' st=',I6,' oldUPj=',D16.8, -C X ' newUPj=',D16.8) -C CALL MYWRT(IOERR,BUFFER) - IF(IAGGR(J).EQ.0) THEN - WRITE(BUFFER,2302) J,CLNAME(J),BNDNEW - 2302 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') has new UPPER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - ELSE - WRITE(BUFFER,2303) J,BNDNEW - 2303 FORMAT(1X,'FDAGGR: Variable ',I6, - X ' (aggregate) has new UPPER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - ENDIF - 2304 CONTINUE -C -C Reinitialize bounds on shadow prices. - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 2305 IKX=KBEG,KEND - IR=RWNMBS(IKX) - P(IR)=-BIG - Q(IR)=BIG - IF(RANGES(IR).LE.BIGNEW) GO TO 2305 - IF(RWSTAT(IR).EQ.2) P(IR)=0.0D0 - IF(RWSTAT(IR).EQ.3) Q(IR)=0.0D0 - 2305 CONTINUE -C - IF(BNDNEW.LE.RNTMP1(J)+FSBTOL) THEN -C -C Fix variable J on its LOWER bound. - IF(IAGGR(J)) 2306,2310,2360 -C -C Here for an aggregate variable. - 2306 RNTMP2(J)=RNTMP1(J) - IF(MSGLEV.LE.1) GO TO 2309 - WRITE(BUFFER,2308) J,RNTMP1(J) - 2308 FORMAT(1X,'FDAGGR: Variable ',I6, - X ' (aggregate) is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2309 CONTINUE - GO TO 2360 -C -C Here for a standard LP variable. - 2310 NFIXED=NFIXED+1 - X0=0.0D0 - PRLVAR(J)=X0 - STAVAR(J)=6 - IF(MSGLEV.LE.1) GO TO 2312 - WRITE(BUFFER,2311) J,CLNAME(J),X0 - 2311 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2312 CONTINUE - GO TO 2360 - ENDIF -C - ELSE -C -C Implicit LOWER bound can be defined for each variable -C refering to NEGATIVE entry of row I. - BNDJUP=RNTMP2(J) - BNDNEW=BNDJUP+BLOWER/ACOEFF(IPOS) - IF(BNDNEW.LE.RNTMP1(J)+BNDTOL) GO TO 2360 - IF(IAGGR(J)) 2320,2330,2360 -C -C Here for an aggregate variable. - 2320 RNTMP1(J)=BNDNEW - IF(MSGLEV.LE.1) GO TO 2329 - WRITE(BUFFER,2328) J,RNTMP1(J) - 2328 FORMAT(1X,'FDAGGR: Variable ',I6, - X ' (aggregate) has new LOWER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2329 CONTINUE - GO TO 2360 -C -C Here for a standard LP variable. - 2330 NTIGHT=NTIGHT+1 - LOBND(J)=LOBND(J)+BNDNEW - UPBND(J)=UPBND(J)-BNDNEW - RNTMP2(J)=UPBND(J) - STAVAR(J)=3 -C -C Save the new LOWER bound in a PRE_SOLVE history list. - IF(LNHIST.GE.MXHIST) GO TO 9200 - LNHIST=LNHIST+1 - INHIST(LNHIST)=-J - DPHIST(LNHIST)=BNDNEW -C -C Modify RHS (take account of the new LOWER bound on Xj). - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 2340 IKX=KBEG,KEND - IR=RWNMBS(IKX) - B(IR)=B(IR)-BNDNEW*ACOEFF(IKX) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - 2340 CONTINUE -C -C *** DEBUGGING - IF(MSGLEV.LE.2) GO TO 2342 - WRITE(BUFFER,2341) J,STAVAR(J),BNDNEW - 2341 FORMAT(1X,'cl=',I6,' st=',I6,' oldLOj=0.0D0', - X ' newLOj=',D16.8) - CALL MYWRT(IOERR,BUFFER) - 2342 CONTINUE - IF(MSGLEV.LE.1) GO TO 2344 - WRITE(BUFFER,2343) J,CLNAME(J),BNDNEW - 2343 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') has new LOWER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2344 CONTINUE -C - ENDIF - 2360 IPOS=RWLINK(IPOS) - GO TO 2300 -C - 2380 CONTINUE - BLOWER=RHS0-BLOWER - GO TO 2500 -C -C -C Here if there exists at least one negative entry with BIG Uj -C or there exists at least one positive entry with BIG Lj. -C If only one such an entry exists, then its -big LOWER bound or -C big UPPER bound can be improved. KNEGBG indicates its position. - 2400 IF(NNEGBG.GE.2) GO TO 2500 -C - J=CLNMBS(KNEGBG) - K=STAVAR(J) - IF(K.GE.6) GO TO 2500 - BNDNEW=(RHS0-BLOWER)/ACOEFF(KNEGBG) - IF(IAGGR(J)) 2440,2410,2500 -C -C Here for a standard LP variable (it must have been negative -C entry with big Uj). Variable's LOWER bound can be improved. - 2410 IF(BNDNEW.LE.BNDTOL) GO TO 2500 - NTIGHT=NTIGHT+1 - LOBND(J)=LOBND(J)+BNDNEW - STAVAR(J)=2 -C -C Save the new LOWER bound in a PRE_SOLVE history list. - IF(LNHIST.GE.MXHIST) GO TO 9200 - LNHIST=LNHIST+1 - INHIST(LNHIST)=-J - DPHIST(LNHIST)=BNDNEW -C -C Modify RHS (take account of the new LOWER bound on Xj). - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 2420 IKX=KBEG,KEND - IR=RWNMBS(IKX) - B(IR)=B(IR)-BNDNEW*ACOEFF(IKX) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - 2420 CONTINUE -C -C *** DEBUGGING - IF(MSGLEV.LE.2) GO TO 2422 - WRITE(BUFFER,2421) J,STAVAR(J),BNDNEW - 2421 FORMAT(1X,'BIG Uj, cl=',I6,' st=',I6,' oldLOj=0.0D0', - X ' newLOj=',D16.8) - CALL MYWRT(IOERR,BUFFER) - 2422 CONTINUE - IF(MSGLEV.LE.1) GO TO 2424 - WRITE(BUFFER,2423) J,CLNAME(J),BNDNEW - 2423 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') has new LOWER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2424 CONTINUE - GO TO 2500 -C -C Here for an aggregate variable. Depending on its entry sign -C (+ or -) its UPPER or LOWER bound can be improved, respectively. - 2440 IF(ACOEFF(KNEGBG).LT.0.0D0) THEN - IF(BNDNEW.LE.RNTMP1(J)+BNDTOL) GO TO 2500 - RNTMP1(J)=BNDNEW - IF(MSGLEV.LE.1) GO TO 2442 - WRITE(BUFFER,2441) J,BNDNEW - 2441 FORMAT(1X,'FDAGGR: Variable ',I6, - X ' (aggregate) has new LOWER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2442 CONTINUE - ELSE - IF(BNDNEW.GE.RNTMP2(J)-BNDTOL) GO TO 2500 - RNTMP2(J)=BNDNEW - IF(MSGLEV.LE.1) GO TO 2444 - WRITE(BUFFER,2443) J,BNDNEW - 2443 FORMAT(1X,'FDAGGR: Variable ',I6, - X ' (aggregate) has new UPPER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2444 CONTINUE - ENDIF -C - ENDIF -C -C -C - 2500 CONTINUE - IF(RWSTAT(I).EQ.1.OR.RWSTAT(I).EQ.2) THEN -C -C Here for EQUALITY type or GREATER OR EQUAL type constraint. - IF(BUPPER-RHS0.LT.-FSBTOL.AND.NPOSBG.EQ.0) GO TO 9020 - IF(NPOSBG.GE.1) GO TO 2700 -C -C -C Here if there are no positive entries with BIG Uj -C and there are no negative entries with BIG Lj, -C i.e. BUPPER is finite. -C -C Loop over nonzero entries of row I. - BUPPER=RHS0-BUPPER - IPOS=KRWBEG - 2600 IF(IPOS.EQ.0) GO TO 2680 - J=CLNMBS(IPOS) - K=STAVAR(J) - IF(K.GE.6) GO TO 2660 - IF(IAGGR(J).GT.0) GO TO 2660 - IF(ACOEFF(IPOS).LT.0.0D0) THEN -C -C Implicit UPPER bound can be defined for each variable -C refering to NEGATIVE entry of row I. - BNDJUP=RNTMP2(J) - BNDNEW=RNTMP1(J)+BUPPER/ACOEFF(IPOS) - IF(BNDNEW.GE.BNDJUP-BNDTOL) GO TO 2660 -C IF(BNDNEW.GE.BNDBIG) GO TO 2660 -C IF(BNDNEW.GE.BNDBIG) THEN -C IF(IAGGR(J).EQ.0) GO TO 2660 -C ENDIF - IF(BNDNEW.GE.BNDBIG) THEN - IF((K.EQ.0.OR.K.EQ.2).AND. - X IAGGR(J).EQ.0) GO TO 2660 - ENDIF - IF(LEVPRS.LE.1) GO TO 2660 - NTIGHT=NTIGHT+1 - RNTMP2(J)=BNDNEW - IF(IAGGR(J).EQ.0) THEN - UPBND(J)=BNDNEW - IF(K.NE.1.AND.K.NE.3) STAVAR(J)=STAVAR(J)+1 - ENDIF -C - IF(MSGLEV.LE.1) GO TO 2604 -C WRITE(BUFFER,2601) J,STAVAR(J),BNDJUP,BNDNEW -C2601 FORMAT(1X,'cl=',I6,' st=',I6,' oldUPj=',D16.8, -C X ' newUPj=',D16.8) -C CALL MYWRT(IOERR,BUFFER) - IF(IAGGR(J).EQ.0) THEN - WRITE(BUFFER,2602) J,CLNAME(J),BNDNEW - 2602 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') has new UPPER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - ELSE - WRITE(BUFFER,2603) J,BNDNEW - 2603 FORMAT(1X,'FDAGGR: Variable ',I6, - X ' (aggregate) has new UPPER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - ENDIF - 2604 CONTINUE -C -C Reinitialize bounds on shadow prices. - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 2605 IKX=KBEG,KEND - IR=RWNMBS(IKX) - P(IR)=-BIG - Q(IR)=BIG - IF(RANGES(IR).LE.BIGNEW) GO TO 2605 - IF(RWSTAT(IR).EQ.2) P(IR)=0.0D0 - IF(RWSTAT(IR).EQ.3) Q(IR)=0.0D0 - 2605 CONTINUE -C - IF(BNDNEW.LE.RNTMP1(J)+FSBTOL) THEN -C -C Fix variable J on its LOWER bound. - IF(IAGGR(J)) 2606,2610,2660 -C -C Here for an aggregate variable. - 2606 RNTMP2(J)=RNTMP1(J) - IF(MSGLEV.LE.1) GO TO 2609 - WRITE(BUFFER,2608) J,RNTMP1(J) - 2608 FORMAT(1X,'FDAGGR: Variable ',I6, - X ' (aggregate) is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2609 CONTINUE - GO TO 2660 -C -C Here for a standard LP variable. - 2610 NFIXED=NFIXED+1 - X0=0.0D0 - PRLVAR(J)=X0 - STAVAR(J)=6 - IF(MSGLEV.LE.1) GO TO 2612 - WRITE(BUFFER,2611) J,CLNAME(J),X0 - 2611 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2612 CONTINUE - GO TO 2660 - ENDIF -C - ELSE -C -C Implicit LOWER bound can be defined for each variable -C refering to POSITIVE entry of row I. - BNDJUP=RNTMP2(J) - BNDNEW=BNDJUP+BUPPER/ACOEFF(IPOS) - IF(BNDNEW.LE.RNTMP1(J)+BNDTOL) GO TO 2660 - IF(IAGGR(J)) 2620,2630,2660 -C -C Here for an aggregate variable. - 2620 RNTMP1(J)=BNDNEW - IF(MSGLEV.LE.1) GO TO 2629 - WRITE(BUFFER,2628) J,RNTMP1(J) - 2628 FORMAT(1X,'FDAGGR: Variable ',I6, - X ' (aggregate) has new LOWER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2629 CONTINUE - GO TO 2660 -C -C Here for a standard LP variable. - 2630 NTIGHT=NTIGHT+1 - LOBND(J)=LOBND(J)+BNDNEW - UPBND(J)=UPBND(J)-BNDNEW - RNTMP2(J)=UPBND(J) - STAVAR(J)=3 -C -C Save the new LOWER bound in a PRE_SOLVE history list. - IF(LNHIST.GE.MXHIST) GO TO 9200 - LNHIST=LNHIST+1 - INHIST(LNHIST)=-J - DPHIST(LNHIST)=BNDNEW -C -C Modify RHS (take account of the new LOWER bound on Xj). - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 2640 IKX=KBEG,KEND - IR=RWNMBS(IKX) - B(IR)=B(IR)-BNDNEW*ACOEFF(IKX) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - 2640 CONTINUE -C -C *** DEBUGGING - IF(MSGLEV.LE.2) GO TO 2642 - WRITE(BUFFER,2641) J,STAVAR(J),BNDNEW - 2641 FORMAT(1X,'cl=',I6,' st=',I6,' oldLOj=0.0D0', - X ' newLOj=',D16.8) - CALL MYWRT(IOERR,BUFFER) - 2642 CONTINUE - IF(MSGLEV.LE.1) GO TO 2644 - WRITE(BUFFER,2643) J,CLNAME(J),BNDNEW - 2643 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') has new LOWER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2644 CONTINUE -C - ENDIF - 2660 IPOS=RWLINK(IPOS) - GO TO 2600 -C - 2680 CONTINUE - BUPPER=RHS0-BUPPER - GO TO 3000 -C -C -C Here if there exists at least one positive entry with BIG Uj -C or there exists at least one negative entry with BIG Lj. -C If only one such an entry exists, then its -big LOWER bound or -C big UPPER bound can be improved. KPOSBG indicates its position. - 2700 IF(NPOSBG.GE.2) GO TO 3000 -C - J=CLNMBS(KPOSBG) - K=STAVAR(J) - IF(K.GE.6) GO TO 3000 - BNDNEW=(RHS0-BUPPER)/ACOEFF(KPOSBG) - IF(IAGGR(J)) 2740,2710,3000 -C -C Here for a standard LP variable (it must have been positive -C entry with big Uj). Variable's LOWER bound can be improved. - 2710 IF(BNDNEW.LE.BNDTOL) GO TO 3000 - NTIGHT=NTIGHT+1 - LOBND(J)=LOBND(J)+BNDNEW - STAVAR(J)=2 -C -C Save the new LOWER bound in a PRE_SOLVE history list. - IF(LNHIST.GE.MXHIST) GO TO 9200 - LNHIST=LNHIST+1 - INHIST(LNHIST)=-J - DPHIST(LNHIST)=BNDNEW -C -C Modify RHS (take account of the new LOWER bound on Xj). - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 2720 IKX=KBEG,KEND - IR=RWNMBS(IKX) - B(IR)=B(IR)-BNDNEW*ACOEFF(IKX) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - 2720 CONTINUE -C -C *** DEBUGGING - IF(MSGLEV.LE.2) GO TO 2722 - WRITE(BUFFER,2721) J,STAVAR(J),BNDNEW - 2721 FORMAT(1X,'BIG Uj, cl=',I6,' st=',I6,' oldLOj=0.0D0', - X ' newLOj=',D16.8) - CALL MYWRT(IOERR,BUFFER) - 2722 CONTINUE - IF(MSGLEV.LE.1) GO TO 2724 - WRITE(BUFFER,2723) J,CLNAME(J),BNDNEW - 2723 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') has new LOWER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2724 CONTINUE - GO TO 3000 -C -C Here for an aggregate variable. Depending on its entry sign -C (+ or -) its LOWER or UPPER bound can be improved, respectively. - 2740 IF(ACOEFF(KPOSBG).GT.0.0D0) THEN - IF(BNDNEW.LE.RNTMP1(J)+BNDTOL) GO TO 3000 - RNTMP1(J)=BNDNEW - IF(MSGLEV.LE.1) GO TO 2742 - WRITE(BUFFER,2741) J,BNDNEW - 2741 FORMAT(1X,'FDAGGR: Variable ',I6, - X ' (aggregate) has new LOWER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2742 CONTINUE - ELSE - IF(BNDNEW.GE.RNTMP2(J)-BNDTOL) GO TO 3000 - RNTMP2(J)=BNDNEW - IF(MSGLEV.LE.1) GO TO 2744 - WRITE(BUFFER,2743) J,BNDNEW - 2743 FORMAT(1X,'FDAGGR: Variable ',I6, - X ' (aggregate) has new UPPER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 2744 CONTINUE - ENDIF -C - ENDIF -C -C -C -C -C -C End of the third main loop. - 3000 CONTINUE -C -C -C -C Check if 2000 and 3000 loops should be repeated. - IF(NELIM.GT.NEL0) THEN - IRUN=IRUN+1 - GO TO 1200 - ENDIF - IF(100*(NTIGHT-NT0).GE.N1) THEN - IRUN=IRUN+1 - IF(IRUN.GE.6) GO TO 3100 - GO TO 1200 - ELSE - GO TO 3100 - ENDIF -C -C -C -C -C -C -C Analyse all aggregate columns. - 3100 CONTINUE -C WRITE(BUFFER,3101) -C3101 FORMAT(1X,'FDAGGR: Summary on aggregation and elimination.') -C CALL MYWRT(IOERR,BUFFER) -C -C - NFREE=0 - DO 4000 J=1,N - KSTAT=STAVAR(J) - IF(KSTAT.GE.6) GO TO 4000 - IF(J.GT.NSTRCT) GO TO 4000 -C -C -C -C Check if new variables' bounds are OK. - IF(KSTAT.EQ.1.OR.KSTAT.EQ.3) THEN - IF(UPBND(J).GE.1.0D+10) THEN - WRITE(BUFFER,3111) J,STAVAR(J),LOBND(J),UPBND(J) - 3111 FORMAT(1X,'cl=',I6,' st=',I2,' L=',D10.3,' U=',D10.3) - CALL MYWRT(IOERR,BUFFER) - ENDIF - ENDIF - IF(KSTAT.EQ.2.OR.KSTAT.EQ.3) THEN - IF(DABS(LOBND(J)).GE.1.0D+10) THEN - WRITE(BUFFER,3112) J,STAVAR(J),LOBND(J),UPBND(J) - 3112 FORMAT(1X,'cl=',I6,' st=',I2,' L=',D10.3,' U=',D10.3) - CALL MYWRT(IOERR,BUFFER) - ENDIF - ENDIF -C - IF(IAGGR(J).GE.0) GO TO 4000 -C -C -C -C Check if an aggregate can be eliminated. -C It can in two cases: -C 1. when it is FIXED (i.e. RNTMP1(J) = RNTMP2(J)); -C 2. when it is an isolated row of the LP problem; -C 3. when it is a bounded FREE variable. -C Count the number of entries in an aggregate. -C Count the number of positive entries in an aggregate. - NIDEN=0 - NPOS=0 - JCOL=-IAGGR(J) - 3210 IF(JCOL.LE.0) GO TO 3220 - NIDEN=NIDEN+1 - IF(RNTMP3(JCOL).GE.SMALLA) NPOS=NPOS+1 - JCOL=IAGGR(JCOL) - GO TO 3210 -C - 3220 KOK=INTMP1(J) - KROW=RWNMBS(KOK) - IF(RNTMP2(J).GE.RNTMP1(J)+FSBTOL.AND. - X (LENROW(KROW).GT.NIDEN.OR.LENCOL(J).GT.1)) GO TO 3300 -C -C -C Here if an aggregate can be eliminated. -C Define a one-row linear program. - NXSTR=0 - JCOL=-IAGGR(J) - 3230 IF(JCOL.LE.0) GO TO 3240 - NXSTR=NXSTR+1 - COEFF(NXSTR)=RNTMP3(JCOL) - COBJ(NXSTR)=C(JCOL) - KSTAT=STAVAR(JCOL) - BNDJUP=BIG - IF(KSTAT.EQ.1.OR.KSTAT.EQ.3) BNDJUP=UPBND(JCOL) - UPPER(NXSTR)=BNDJUP - JCOL=IAGGR(JCOL) - GO TO 3230 -C - 3240 NMAX=100 - IF(NXSTR.GE.NMAX-1) GO TO 3400 - PI=P(KROW) - QI=Q(KROW) - ROWST=RWSTAT(KROW) - RHS=B(KROW) - IF(RNTMP2(J).LE.RNTMP1(J)+FSBTOL) THEN - ROWST=1 - RHS=RNTMP1(J) - ELSE - DO 3245 I=1,NXSTR - COEFF(I)=COEFF(I)*ACOEFF(KOK) - 3245 CONTINUE - ENDIF -C -C Solve the one-row LP problem. - CALL SMPLX(IOERR,MSGLEV,NMAX,NX,NXSTR,ROWST, - X COEFF,X,COBJ,UPPER,RDCOST,RHS,P,Q,DUAL) -C -C Desaggregate optimal solution of the one-row LP problem. -C Fix all columns that belong to the aggregate. - NXSTR=0 - JCOL=-IAGGR(J) - X0=0.0D0 - 3250 IF(JCOL.LE.0) GO TO 3260 - NXSTR=NXSTR+1 - NFIXED=NFIXED+1 - PRLVAR(JCOL)=X(NXSTR) - STAVAR(JCOL)=6 - IF(MSGLEV.LE.1) GO TO 3252 - WRITE(BUFFER,3251) JCOL,CLNAME(JCOL),X(NXSTR) - 3251 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 3252 CONTINUE - X0=X0+X(NXSTR)*COEFF(NXSTR) - K=JCOL - JCOL=IAGGR(JCOL) - IAGGR(K)=0 - GO TO 3250 -C -C Update RHS after aggregate elimination. - 3260 IF(RNTMP2(J).GT.RNTMP1(J)+FSBTOL) X0=X0/ACOEFF(KOK) - IF(DABS(X0).LE.SMALLA) GO TO 3280 - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 3270 K=KBEG,KEND - IR=RWNMBS(K) - B(IR)=B(IR)-X0*ACOEFF(K) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - 3270 CONTINUE - 3280 CONTINUE -C -C Check if a row defining the aggregate can be eliminated. - IF(LENROW(KROW).NE.NXSTR) GO TO 4000 - NELIM=NELIM+1 - RWHEAD(KROW)=-RWHEAD(KROW) - IF(MSGLEV.LE.1) GO TO 3282 - RTYPE='EQ' - IF(RWSTAT(KROW).EQ.2) RTYPE='GE' - IF(RWSTAT(KROW).EQ.3) RTYPE='LE' - WRITE(BUFFER,3281) KROW,RWNAME(KROW),RTYPE - 3281 FORMAT(1X,'FDAGGR: Row ',I6,' (name=',A8, - X ' type=',A2,') is eliminated.') - CALL MYWRT(IOERR,BUFFER) - 3282 CONTINUE -C - GO TO 4000 -C -C -C -C Check if a split FREE variable has been bounded. - 3300 IHEAD=-IAGGR(J) - IF(IAGGR(IHEAD).NE.J) GO TO 3400 - IF(-STAVAR(IHEAD).NE.J) GO TO 3400 - IF(RNTMP1(J).LE.-BIGNEW.AND. - X RNTMP2(J).GE.BIGNEW) GO TO 4000 - IF(MSGLEV.LE.2) GO TO 3302 - WRITE(BUFFER,3301) J,RNTMP1(J),RNTMP2(J) - 3301 FORMAT(1X,'FREE var=',I6,' Lbnd=',D10.3,' Ubnd=',D10.3) - CALL MYWRT(IOERR,BUFFER) - 3302 CONTINUE -C -C Check if a variable has a finite LOWER bound. - IF(RNTMP1(J).LE.-BIGNEW) GO TO 3340 - IF(MSGLEV.LE.2) GO TO 3312 - WRITE(BUFFER,3311) J - 3311 FORMAT(1X,'FDAGGR: LO bnd on a FREE variable ',I6) - CALL MYWRT(IOERR,BUFFER) - 3312 CONTINUE - JCOL=J - 3310 KSTAT=STAVAR(JCOL) - KBEG=CLPNTS(JCOL) - KEND=KBEG+LENCOL(JCOL)-1 - DO 3315 K=KBEG,KEND - IR=RWNMBS(K) - B(IR)=B(IR)-RNTMP1(JCOL)*ACOEFF(K) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - 3315 CONTINUE - STAVAR(JCOL)=2 - LOBND(JCOL)=RNTMP1(JCOL) - IAGGR(JCOL)=0 -C -C Save the new LOWER bound in a PRE_SOLVE history list. - IF(LNHIST.GE.MXHIST) GO TO 9200 - LNHIST=LNHIST+1 - INHIST(LNHIST)=-JCOL - DPHIST(LNHIST)=RNTMP1(JCOL) -C -C Check if a variable has also an UPPER bound. - RNTMP2(JCOL)=RNTMP2(JCOL)-RNTMP1(JCOL) - IF(RNTMP2(JCOL).LE.BIGNEW) THEN - STAVAR(JCOL)=3 - UPBND(JCOL)=RNTMP2(JCOL) -C -C Reinitialize bounds on shadow prices. - KBEG=CLPNTS(JCOL) - KEND=KBEG+LENCOL(JCOL)-1 - DO 3320 IKX=KBEG,KEND - IR=RWNMBS(IKX) - P(IR)=-BIG - Q(IR)=BIG - IF(RANGES(IR).LE.BIGNEW) GO TO 3320 - IF(RWSTAT(IR).EQ.2) P(IR)=0.0D0 - IF(RWSTAT(IR).EQ.3) Q(IR)=0.0D0 - 3320 CONTINUE - ENDIF -C -C Fix the brother of a split variable. - JCOL=-KSTAT - X0=0.0D0 - PRLVAR(JCOL)=X0 - STAVAR(JCOL)=6 - IAGGR(JCOL)=0 - NFIXED=NFIXED+1 - IF(MSGLEV.LE.1) GO TO 3322 - WRITE(BUFFER,3321) JCOL,CLNAME(JCOL),X0 - 3321 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 3322 CONTINUE - GO TO 4000 -C -C Here if a split variable has infinite LOWER bound -C and a finite UPPER bound. - 3340 CONTINUE - IF(MSGLEV.LE.2) GO TO 3342 - WRITE(BUFFER,3341) J - 3341 FORMAT(1X,'FDAGGR: UP bnd on a FREE variable ',I6) - CALL MYWRT(IOERR,BUFFER) - 3342 CONTINUE -C -C UP bnd on x1 can be handled as LO bnd on x2. - JCOL=-KSTAT - RNTMP1(JCOL)=-RNTMP2(J) - RNTMP2(JCOL)=-RNTMP1(J) - GO TO 3310 -C -C -C -C Here for a general analysis of an aggregate. -C Fix columns with strictly positive (or strictly negative) -C reduced costs. Analyse every pair of columns from an aggregate. -C J1 and JCOL are the column numbers. - 3400 J1=-IAGGR(J) - 3410 IF(J1.LE.0) GO TO 3900 - K1=STAVAR(J1) - IF(K1.GE.6) GO TO 3880 - IF(K1.LT.0) GO TO 3880 - JCOL=IAGGR(J1) - 3420 IF(JCOL.LE.0) GO TO 3880 - KSTAT=STAVAR(JCOL) - IF(KSTAT.GE.6) GO TO 3870 - IF(KSTAT.LT.0) GO TO 3870 -C -C ALPHA here is the inverse of what we used in 500 loop. -C A(jcol) = ALPHA * A(j1). - ALPHA=RNTMP3(JCOL)/RNTMP3(J1) - DP=C(JCOL)-ALPHA*C(J1) -C WRITE(BUFFER,3421) J1,JCOL,ALPHA -C3421 FORMAT(1X,'Pair of cl: J1=',I6,' J2=',I6,' A=',D14.8) -C CALL MYWRT(IOERR,BUFFER) -C - IF(DABS(DP).LE.SMALLA) THEN -C -C Two cols J1 and JCOL are identical subject to a scaling factor. -C Two actions are possible: -C if ALPHA > 0, then aggregation; -C if ALPHA < 0, then a new split FREE variable is found; - IF(ALPHA.LE.0.0D0) GO TO 3460 -C -C Linearly dependent variables are found. -C -C IF(MSGLEV.LE.2) GO TO 3440 -C WRITE(BUFFER,3431) CLNAME(J1),CLNAME(JCOL) -C3431 FORMAT(1X,'FDAGGR: LP variables: ', -C X A8,' and ',A8,' are lin dep. 3431') -C CALL MYWRT(IOERR,BUFFER) -C WRITE(BUFFER,3432) J1,C(J1),STAVAR(J1), -C X LENCOL(J1),UPBND(J1) -C3432 FORMAT(1X,' var=',I6,' Cj=',D14.8,' st=',I6, -C X ' ln=',I6,' Uj=',D14.8) -C CALL MYWRT(IOERR,BUFFER) -C WRITE(BUFFER,3433) JCOL,C(JCOL),STAVAR(JCOL), -C X LENCOL(JCOL),UPBND(JCOL) -C3433 FORMAT(1X,'and var=',I6,' Cj=',D14.8,' st=',I6, -C X ' ln=',I6,' Uj=',D14.8) -C CALL MYWRT(IOERR,BUFFER) -C WRITE(BUFFER,3434) J1,JCOL,ALPHA,DP -C3434 FORMAT(1X,'FDAGGR: J1=',I6,' JCOL=',I6,' ALPHA=', -C X D14.8,' DP=',D14.8) -C CALL MYWRT(IOERR,BUFFER) -C3440 CONTINUE -C - IF(MSGLEV.LE.1) GO TO 3442 - WRITE(BUFFER,3441) CLNAME(J1),CLNAME(JCOL) - 3441 FORMAT(1X,'FDAGGR: Variable=',A8, - X ' becomes a weighted sum of ',A8,' and itself.') - CALL MYWRT(IOERR,BUFFER) - 3442 CONTINUE - NFIXED=NFIXED+1 - X0=0.0D0 - PRLVAR(JCOL)=X0 - STAVAR(JCOL)=6 - IF(MSGLEV.LE.1) GO TO 3452 - WRITE(BUFFER,3451) JCOL,CLNAME(JCOL),X0 - 3451 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 3452 CONTINUE - BNDJUP=UPBND(J1)+ALPHA*UPBND(JCOL) - STAVAR(J1)=2 - UPBND(J1)=BNDJUP - IF(BNDJUP.LE.BIGNEW) THEN - STAVAR(J1)=3 -C -C Reinitialize bounds on shadow prices. - KBEG=CLPNTS(J1) - KEND=KBEG+LENCOL(J1)-1 - DO 3450 IKX=KBEG,KEND - IR=RWNMBS(IKX) - P(IR)=-BIG - Q(IR)=BIG - IF(RANGES(IR).LE.BIGNEW) GO TO 3450 - IF(RWSTAT(IR).EQ.2) P(IR)=0.0D0 - IF(RWSTAT(IR).EQ.3) Q(IR)=0.0D0 - 3450 CONTINUE - ENDIF - GO TO 3870 -C -C Split FREE variable is found. -C We should check if none of them is bounded. - 3460 IF(K1.EQ.1.OR.K1.EQ.3.OR. - X KSTAT.EQ.1.OR.KSTAT.EQ.3) THEN -C WRITE(BUFFER,3461) J1,C(J1),STAVAR(J1), -C X LENCOL(J1),UPBND(J1) -C3461 FORMAT(1X,'3461,var=',I6,' Cj=',D14.8,' st=',I6, -C X ' ln=',I6,' Uj=',D14.8) -C CALL MYWRT(IOERR,BUFFER) -C WRITE(BUFFER,3462) JCOL,C(JCOL),STAVAR(JCOL), -C X LENCOL(JCOL),UPBND(JCOL) -C3462 FORMAT(1X,' and var=',I6,' Cj=',D14.8,' st=',I6, -C X ' ln=',I6,' Uj=',D14.8) -C CALL MYWRT(IOERR,BUFFER) - GO TO 3480 - ENDIF - NFREE=NFREE+1 - IF(MSGLEV.LE.1) GO TO 3464 - WRITE(BUFFER,3463) CLNAME(J1),CLNAME(JCOL) - 3463 FORMAT(1X,'FDAGGR: LP variables: ', - X A8,' and ',A8,' are split FREE variable.') - CALL MYWRT(IOERR,BUFFER) - 3464 CONTINUE - STAVAR(J1)=-JCOL - STAVAR(JCOL)=-J1 - C(JCOL)=-C(JCOL)/ALPHA - KBEG=CLPNTS(JCOL) - KEND=KBEG+LENCOL(JCOL)-1 - DO 3470 K=KBEG,KEND - ACOEFF(K)=-ACOEFF(K)/ALPHA - 3470 CONTINUE -C -C Save column scaling factor in a PRE_SOLVE history list. -C At the moment we ignore this. - GO TO 3880 -C -C Linearly dependent variables are found. -C Even for negative ALPHA, aggregation can be done if at least -C one variable has a finite UPPER bound. - 3480 CONTINUE - WRITE(BUFFER,3481) J1,JCOL - 3481 FORMAT(1X,'3481F, aggr J1=',I6,' JCOL=',I6) - CALL MYWRT(IOERR,BUFFER) - GO TO 3870 -C -C -C - ENDIF -C - IF(K1.EQ.1.OR.K1.EQ.3) GO TO 3540 -C -C Here if variable J1 is unbounded. -C This means that its reduced cost must be nonnegative. We thus -C might be able to determine the sign of the reduced cost for -C variable JCOL and, consequently, eliminate it. -C - IF(DP.GE.SMALLA.AND.ALPHA.GE.0.0D0) THEN -C -C Fix variable JCOL on its LOWER bound. - NFIXED=NFIXED+1 - X0=0.0D0 - PRLVAR(JCOL)=X0 - STAVAR(JCOL)=6 - IF(MSGLEV.LE.1) GO TO 3502 - WRITE(BUFFER,3501) JCOL,CLNAME(JCOL),X0 - 3501 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 3502 CONTINUE - GO TO 3870 - ENDIF -C - IF(DP.LE.-SMALLA.AND.ALPHA.LE.0.0D0) THEN -C -C Fix variable JCOL on its UPPER bound (if it has one). - IF(KSTAT.NE.1.AND.KSTAT.NE.3) GO TO 3540 - NFIXED=NFIXED+1 - X0=UPBND(JCOL) - PRLVAR(JCOL)=X0 - STAVAR(JCOL)=6 - KBEG=CLPNTS(JCOL) - KEND=KBEG+LENCOL(JCOL)-1 - DO 3510 K=KBEG,KEND - IR=RWNMBS(K) - B(IR)=B(IR)-X0*ACOEFF(K) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - 3510 CONTINUE - IF(MSGLEV.LE.1) GO TO 3512 - WRITE(BUFFER,3511) JCOL,CLNAME(JCOL),X0 - 3511 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 3512 CONTINUE - GO TO 3870 - ENDIF -C - 3540 IF(KSTAT.EQ.1.OR.KSTAT.EQ.3) GO TO 3870 -C -C Here if variable JCOL is unbounded. -C This means that its reduced cost must be nonnegative. We thus -C might be able to determine the sign of the reduced cost for -C variable J1 and, consequently, eliminate it. -C - IF(DP.LE.-SMALLA.AND.ALPHA.GE.0.0D0) THEN -C -C Fix variable J1 on its LOWER bound. - NFIXED=NFIXED+1 - X0=0.0D0 - PRLVAR(J1)=X0 - STAVAR(J1)=6 - IF(MSGLEV.LE.1) GO TO 3562 - WRITE(BUFFER,3561) J1,CLNAME(J1),X0 - 3561 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 3562 CONTINUE - GO TO 3880 - ENDIF -C - IF(DP.LE.-SMALLA.AND.ALPHA.LE.0.0D0) THEN -C -C Fix variable J1 on its UPPER bound (if it has one). - IF(K1.NE.1.AND.K1.NE.3) GO TO 3870 - NFIXED=NFIXED+1 - X0=UPBND(J1) - PRLVAR(J1)=X0 - STAVAR(J1)=6 - KBEG=CLPNTS(J1) - KEND=KBEG+LENCOL(J1)-1 - DO 3570 K=KBEG,KEND - IR=RWNMBS(K) - B(IR)=B(IR)-X0*ACOEFF(K) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - 3570 CONTINUE - IF(MSGLEV.LE.1) GO TO 3572 - WRITE(BUFFER,3571) J1,CLNAME(J1),X0 - 3571 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 3572 CONTINUE - GO TO 3880 - ENDIF -C -C -C - 3870 JCOL=IAGGR(JCOL) - GO TO 3420 -C - 3880 J1=IAGGR(J1) - GO TO 3410 -C -C -C -C Here to tighten bounds on variables entering an aggregate. - 3900 IF(NIDEN.GT.NPOS) GO TO 4000 -C IF(RNTMP1(J).LE.-BIGNEW.AND. -C X RNTMP2(J).GE.BIGNEW) GO TO 4000 - IF(RNTMP2(J).GE.BIGNEW) GO TO 4000 - IF(MSGLEV.LE.2) GO TO 3903 - WRITE(BUFFER,3901) J,RNTMP1(J),RNTMP2(J) - 3901 FORMAT(1X,'Bnd aggr J=',I6,' Lbnd=',D10.3,' Ubnd=',D10.3) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,3902) J,NIDEN,NPOS - 3902 FORMAT(1X,'Bnd aggr J=',I6,' NIDEN=',I6,' NPOS=',I6) - CALL MYWRT(IOERR,BUFFER) - 3903 CONTINUE -C - JCOL=-IAGGR(J) - 3910 IF(JCOL.LE.0) GO TO 4000 - KSTAT=STAVAR(JCOL) - IF(KSTAT.GE.6) GO TO 3990 - IF(KSTAT.LT.0) GO TO 3990 -C -C Implicit UPPER bound can be defined for each variable -C refering to POSITIVE entry of an aggredate. - BNDJUP=BIGNEW - IF(KSTAT.EQ.1.OR.KSTAT.EQ.3) BNDJUP=UPBND(JCOL) - BNDNEW=RNTMP2(J)/RNTMP3(JCOL) - IF(BNDNEW.GE.BNDJUP-BNDTOL) GO TO 3990 -C IF(BNDNEW.GE.BNDBIG) GO TO 3990 - IF(BNDNEW.GE.BNDBIG) THEN - IF(KSTAT.EQ.0.OR.KSTAT.EQ.2) GO TO 3990 - ENDIF - IF(LEVPRS.LE.1) GO TO 3990 - NTIGHT=NTIGHT+1 - UPBND(JCOL)=BNDNEW - IF(KSTAT.NE.1.AND.KSTAT.NE.3) STAVAR(JCOL)=STAVAR(JCOL)+1 -C -C Reinitialize bounds on shadow prices. - KBEG=CLPNTS(JCOL) - KEND=KBEG+LENCOL(JCOL)-1 - DO 3920 IKX=KBEG,KEND - IR=RWNMBS(IKX) - P(IR)=-BIG - Q(IR)=BIG - IF(RANGES(IR).LE.BIGNEW) GO TO 3920 - IF(RWSTAT(IR).EQ.2) P(IR)=0.0D0 - IF(RWSTAT(IR).EQ.3) Q(IR)=0.0D0 - 3920 CONTINUE -C - IF(MSGLEV.LE.1) GO TO 3924 -C WRITE(BUFFER,3921) JCOL,STAVAR(JCOL),BNDJUP,BNDNEW -C3921 FORMAT(1X,'cl=',I6,' st=',I6,' oldUPj=',D16.8, -C X ' newUPj=',D16.8) -C CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,3922) JCOL,CLNAME(JCOL),BNDNEW - 3922 FORMAT(1X,'FDAGGR: Variable ',I6,' (name=',A8, - X ') has new UPPER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 3924 CONTINUE -C -C - 3990 JCOL=IAGGR(JCOL) - GO TO 3910 -C -C -C -C - 4000 CONTINUE -C -C -C -C -C -C Check if there are inequality type rows to be eliminated. -C Check if the eliminated rows were not violated. - FSBTOL=1.0D-7 - DO 4100 I=1,M - IF(DABS(B(I)).LE.FSBTOL) B(I)=0.0D0 - K=RWHEAD(I) -C WRITE(BUFFER,4101) I,RWSTAT(I),LENROW(I),K -C4101 FORMAT(1X,'row=',I6,' st=',I2,' ln=',I6,' K=',I8) -C CALL MYWRT(IOERR,BUFFER) - IF(RWSTAT(I).EQ.1) THEN -C -C Here for EQUALITY constraint. - IF(K.GT.0) GO TO 4100 - IF(DABS(B(I)).GT.FSBTOL) GO TO 9030 - GO TO 4100 - ENDIF - IF(LENROW(I).GE.1) GO TO 4100 - IF(RWSTAT(I).EQ.2) THEN -C -C Here for GREATER OR EQUAL type constraint. - IF(B(I).GT.FSBTOL) GO TO 9030 - IF(K.LE.0) GO TO 4100 - NELIM=NELIM+1 - RWHEAD(I)=-RWHEAD(I) - J=CLNMBS(K) - PRLVAR(J)=0.0D0 - STAVAR(J)=14 - NFIXED=NFIXED+1 - GO TO 4100 - ENDIF - IF(RWSTAT(I).EQ.3) THEN -C -C Here for LESS OR EQUAL type constraint. - IF(B(I).LT.-FSBTOL) GO TO 9030 - IF(K.LE.0) GO TO 4100 - NELIM=NELIM+1 - RWHEAD(I)=-RWHEAD(I) - J=CLNMBS(K) - PRLVAR(J)=0.0D0 - STAVAR(J)=14 - NFIXED=NFIXED+1 - GO TO 4100 - ENDIF - 4100 CONTINUE -C -C -C -C -C -C -C Determine the permutation that puts all empty and inactive -C rows at the end of the list. -C - I=3 - IF(MSGLEV.LE.1) I=4 - CALL EMPTYR(MAXM,M,MNEW,I, - X RWHEAD,STAROW,LENROW,MARKER,IOERR) -C -C -C Reorder the rows of the LP constraint matrix according to -C the permutation resulting from the analysis of EMPTYR. - IF(MNEW.LT.M.OR.NFIXED.GT.0) THEN -C - CALL REORDA(MAXM,MAXN,MAXNZA,M,N, - X CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X LENROW,MARKER,IMTMP1,IROW,RELT, - X RWNAME,STAROW,RWSTAT,RANGES,B,IOERR) -C -C Reorder bounds on shadow prices P and Q. - CALL REORDV(MAXM,M, - X LENROW,MARKER,P,RELT,IOERR) - CALL REORDV(MAXM,M, - X LENROW,MARKER,Q,RELT,IOERR) -C -C Reorder elements within each column of the LP constraint -C matrix in such a way that those of the active part of A -C are at the beginning of the lists. The column lengths will -C later be decreased to forget inactive part of matrix A. -C Set the new row linked lists of nonzero elements of matrix A. -C Recall that CLPNTS(j) indicates the first entry of column j. -C Zero RWHEAD and LENROW arrays. - DO 4220 I=1,M - RWHEAD(I)=0 - LENROW(I)=0 - 4220 CONTINUE -C -C Reorder nonzero elements within each column. - DO 4280 J=1,N - IF(STAVAR(J).GE.6) GO TO 4280 - KBEG=CLPNTS(J)-1 - KOK=0 - KOUT=0 - DO 4240 IKX=1,LENCOL(J) - K=KBEG+IKX - I=RWNMBS(K) - IF(I.LE.MNEW) THEN - KOK=KOK+1 - IROW(KOK)=RWNMBS(K) - RELT(KOK)=ACOEFF(K) - ELSE - IPOS=LENCOL(J)-KOUT - KOUT=KOUT+1 - IROW(IPOS)=RWNMBS(K) - RELT(IPOS)=ACOEFF(K) - ENDIF - 4240 CONTINUE - LENCOL(J)=KOK -C -C Set the row linked lists. -C Count nonzero elements in all rows of A. - DO 4260 IKX=1,LENCOL(J) - K=KBEG+IKX - I=IROW(IKX) - RWNMBS(K)=I - ACOEFF(K)=RELT(IKX) - RWLINK(K)=RWHEAD(I) - RWHEAD(I)=K - LENROW(I)=LENROW(I)+1 - 4260 CONTINUE - 4280 CONTINUE -C -C Set the new number of rows of the constraint matrix. -C Observe that row linked lists are OK. - M=MNEW -C - ENDIF -C -C -C -C -C -C -C Here if a successful run of the loop has been completed. - IF(MSGLEV.LE.0) GO TO 5010 - WRITE(BUFFER,5001) NELIM - 5001 FORMAT(1X,'FDAGGR: Constraints eliminated: ',I9) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,5002) NFIXED - 5002 FORMAT(1X,' Variables eliminated: ',I9) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,5003) NTIGHT - 5003 FORMAT(1X,' Variable bounds improved:',I8) - CALL MYWRT(IOERR,BUFFER) - 5010 CONTINUE -C -C -C - 6000 CONTINUE -C - RETURN -C -C - 9010 WRITE(BUFFER,9011) RWNAME(I),RTYPE,BLOWER,BUPPER,B(I) - 9011 FORMAT(1X,'FDAGGR: Row=',A8,' type=',A2, - X ' BLO=',D10.3,' BUP=',D10.3,' RHS=',D10.3) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9012) - 9012 FORMAT(1X,'FDAGGR: Problem is infeasible.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9020 WRITE(BUFFER,9021) RWNAME(I),RTYPE,BLOWER,BUPPER,RHS0 - 9021 FORMAT(1X,'FDAGGR: Row=',A8,' type=',A2, - X ' BLO=',D10.3,' BUP=',D10.3,' RHS0=',D10.3) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9022) - 9022 FORMAT(1X,'FDAGGR: Problem is infeasible.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9030 WRITE(BUFFER,9031) I,RWNAME(I),B(I) - 9031 FORMAT(1X,'FDAGGR: Constraint ',I6,' (name=',A8, - X ') is violated, B=',D12.6) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9032) - 9032 FORMAT(1X,'FDAGGR: Problem is infeasible.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9200 WRITE(BUFFER,9201) - 9201 FORMAT(1X,'FDAGGR: Please increase space for PRE_SOLVE ', - X 'history list.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C -C *** LAST CARD OF (FDAGGR) *** - END //GO.SYSIN DD hopdm.src/fdaggr.f echo hopdm.src/fdiden.f 1>&2 sed >hopdm.src/fdiden.f <<'//GO.SYSIN DD hopdm.src/fdiden.f' 's/^-//' -C************************************************************* -C *** FDIDEN ... FIND VARIABLES OF IDENTICAL STRUCTURE *** -C************************************************************* -C - SUBROUTINE FDIDEN(IOERR,MSGLEV, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X B,C,LOBND,UPBND, - X ACOEFF,CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X P,Q,PRLVAR,STAVAR,RWSTAT,CLNAME,RANGES, - X MARKER,LENROW,RMTMP1) -C -C -C -C -C -C *** PARAMETERS - INTEGER*4 IOERR,MSGLEV,MAXM,MAXN,MAXNZA,M,N,NSTRCT - INTEGER*4 LNHIST,MXHIST - INTEGER*2 INHIST(MXHIST) - DOUBLE PRECISION DPHIST(MXHIST) - DOUBLE PRECISION ACOEFF(MAXNZA),B(MAXM) - DOUBLE PRECISION C(MAXN),LOBND(MAXN),UPBND(MAXN),RMTMP1(MAXM) - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM+1),RWLINK(MAXNZA) - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) - DOUBLE PRECISION P(MAXM),Q(MAXM),PRLVAR(MAXN),RANGES(MAXM) - CHARACTER*8 CLNAME(MAXN) - INTEGER*2 STAVAR(MAXN),RWSTAT(MAXM) - INTEGER*2 LENROW(MAXM),MARKER(MAXM) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 KSTAT,LROW,KROW,NFIXED,NFREE - INTEGER*4 K,KBEG,KEND,K2,K2BEG,K2END,KBEG0,KEND0 - INTEGER*4 I,IKX,IR,IPOS,J,JCOL,J1,J2 - DOUBLE PRECISION ALPHA,BIG,BIGNEW,FSBTOL,SMALLA - DOUBLE PRECISION DP,X0,BNDL1,BNDU1,BNDU2 - CHARACTER*100 BUFFER -C -C -C -C -C *** PARAMETERS DESCRIPTION -C -C *** ON INPUT: -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C MSGLEV The level of PRE_SOLVE information desired: -C 0 only final problem dimensions are printed; -C 1 numbers of eliminated rows and columns are printed; -C 2 names of eliminated rows and columns are printed; -C 3 detailed DEBUGGING information is printed. -C MAXM Maximum number of constraints. -C MAXN Maximum number of variables. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of constraints. -C N Number of variables (total, i.e. including slacks, -C surplus and artificials). -C NSTRCT Number of structural variables (excluding slacks, -C surplus and artificials). -C LNHIST Length of the PRE_SOLVE history list. -C MXHIST Maximum number of entries in the PRE_SOLVE history list. -C INHIST Integer PRE_SOLVE history information. -C DPHIST Double precision PRE_SOLVE history information. -C ACOEFF Array of nonzero elements for each column. -C B Right hand side of the linear program. -C C Objective function coefficients. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C LENCOL Lengths of (sparse) columns of matrix A. -C LOBND Array of lower bounds. -C UPBND Array of upper bounds. Note that the upper bound -C is changed when the variable has a lower bound. -C P LOWER bounds on shadow prices (dual variables). -C Q UPPER bounds on shadow prices (dual variables). -C PRLVAR Primal variables of the linear program. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C RWSTAT Array of row types: -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 objective row; -C 5 other free row. -C CLNAME Array of column names. -C RANGES Array of constraint ranges. -C -C *** ON OUTPUT: -C -C -C -C -C *** WORK ARRAYS: -C MARKER Half-length integer work array of size MAXM. -C LENROW Integer work array of size MAXM. -C RMTMP1 Nonzero elements of the analysed column. -C -C -C -C -C *** PURPOSE -C This routine finds variables that have identical structure. -C Different actions are possible if such variables are found: -C - they may define a splitting of a hidden FREE variable (such -C variables, if not treated in a special way, might cause -C serious stability problems in an interior point algorithm); -C - they may be aggregated (and one variable is FIXED on its -C bound). -C -C -C -C *** SUBROUTINES CALLED -C MYWRT,DABS -C -C -C *** NOTES -C This routine is given direct access to the matrix A. -C It alters hidden data structures. -C -C -C -C *** REFERENCES: -C Gondzio J. (1994). Presolve analysis of linear programs prior -C to applying an interior point method, Technical Report -C No 1994.3, Department of Management Studies, University -C of Geneva, 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, -C February 1994, revised in December 1994. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: January 31, 1993 -C Last modified: March 29, 1995 -C -C -C -C -C *** BODY OF (FDIDEN) *** -C -C -C -C Initialize. - BIG=1.0D+30 - BIGNEW=1.0D+20 - FSBTOL=1.0D-8 - SMALLA=1.0D-8 - NFIXED=0 - NFREE=0 -C -C -C -C -C Zero LENROW and RMTMP1 arrays. - DO 100 I=1,M - LENROW(I)=0 - RMTMP1(I)=0.0D0 - 100 CONTINUE -C -C Count nonzero elements in all rows of A. - DO 300 J=1,NSTRCT - IF(STAVAR(J).GE.6) GO TO 300 - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 200 K=KBEG,KEND - IR=RWNMBS(K) - LENROW(IR)=LENROW(IR)+1 - 200 CONTINUE - 300 CONTINUE -C -C -C -C -C -C -C Main loop begins here. -C Loop over all structural columns of A. - DO 1000 J=1,NSTRCT - IF(STAVAR(J).GE.6) GO TO 1000 - IF(STAVAR(J).LT.0) GO TO 1000 - IF(LENCOL(J).EQ.0) GO TO 1000 -C -C Save nonzero elements of column J in RMTMP1 array. -C Determine the shortest row with an entry in column J. -C Equality-type rows are prefered if ties are to be broken. - KROW=0 - LROW=NSTRCT+1 - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 380 K=KBEG,KEND - IR=RWNMBS(K) - RMTMP1(IR)=ACOEFF(K) - IF(LENROW(IR)-LROW) 360,340,380 - 340 IF(RWSTAT(IR).NE.1) GO TO 380 - 360 LROW=LENROW(IR) - KROW=IR - 380 CONTINUE - IF(KROW.EQ.0) GO TO 940 -C -C Analyse all columns that have entries in row KROW. -C Look for a column with identical sparsity structure as column J. - IPOS=RWHEAD(KROW) - 400 IF(IPOS.EQ.0) GO TO 810 - JCOL=CLNMBS(IPOS) - IF(LENCOL(JCOL).NE.LENCOL(J)) GO TO 800 - IF(STAVAR(JCOL).LT.0) GO TO 800 - IF(STAVAR(JCOL).GE.6) GO TO 800 - IF(JCOL.LE.J) GO TO 800 - IF(JCOL.GT.NSTRCT) GO TO 800 -C -C Here if two columns J and JCOL have the same length. - K2BEG=CLPNTS(JCOL) - K2END=K2BEG+LENCOL(JCOL)-1 -C -C -C -C Check if columns J and JCOL differ with the sign only. - IR=RWNMBS(K2BEG) - ALPHA=RMTMP1(IR)/ACOEFF(K2BEG) - DO 500 K2=K2BEG+1,K2END - IR=RWNMBS(K2) - DP=DABS(ACOEFF(K)+ACOEFF(K2)) - DP=DABS(RMTMP1(IR)/ACOEFF(K2)-ALPHA) - IF(DP.GE.SMALLA) GO TO 800 - 500 CONTINUE - IF(DABS(ALPHA+1.0D0).GE.SMALLA) GO TO 600 -C -C Here if two columns J and JCOL differ with the sign only. - IF(MSGLEV.LE.2) GO TO 505 - WRITE(BUFFER,501) CLNAME(J),CLNAME(JCOL) - 501 FORMAT(1X,'FDIDEN: LP variables: ', - X A8,' and ',A8,' differ with the sign only.') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,502) J,C(J),STAVAR(J) - 502 FORMAT(1X,'FDIDEN: var=',I6,' Cj=',D14.6,' stavar=',I6) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,503) JCOL,C(JCOL),STAVAR(JCOL) - 503 FORMAT(1X,' and var=',I6,' Cj=',D14.6,' stavar=',I6) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,504) KROW,RWSTAT(KROW),LROW - 504 FORMAT(1X,' row=',I5,' rwstat=',I5,' len=',I5) - CALL MYWRT(IOERR,BUFFER) - 505 CONTINUE -C -C -C Columns J and JCOL differ with the sign only. -C If the objective coefficients C1 and C2 differ with the sign -C only and variables have no UPPER bound, then columns J and JCOL -C are splitting of some FREE variable. If at least one of variables -C have an UPPER bound, then they may be aggregated and replaced -C with a single variable. - DP=C(J)+C(JCOL) - IF(DABS(DP).GE.SMALLA) GO TO 600 -C -C Here if the objective coefficients C1 and C2 differ with the sign. - KSTAT=STAVAR(J) - BNDU1=BIG - IF(KSTAT.EQ.1.OR.KSTAT.EQ.3) BNDU1=UPBND(J) - KSTAT=STAVAR(JCOL) - BNDU2=BIG - IF(KSTAT.EQ.1.OR.KSTAT.EQ.3) BNDU2=UPBND(JCOL) - IF(BNDU1.LE.BIGNEW) GO TO 520 - IF(BNDU2.LE.BIGNEW) GO TO 520 -C -C Hidden FREE variable is found. - NFREE=NFREE+1 - IF(MSGLEV.LE.1) GO TO 512 - WRITE(BUFFER,511) CLNAME(J),CLNAME(JCOL) - 511 FORMAT(1X,'FDIDEN: LP variables: ', - X A8,' and ',A8,' are split FREE variable.') - CALL MYWRT(IOERR,BUFFER) - 512 CONTINUE - STAVAR(J)=-JCOL - STAVAR(JCOL)=-J - GO TO 810 -C -C J2 becomes an aggregate column and J1 becomes FIXED. - 520 IF(BNDU1.LE.BNDU2) THEN - J1=J - J2=JCOL - ELSE - J1=JCOL - J2=J - ENDIF -C -C Determine bounds and status of the aggregate variable. - BNDL1=-UPBND(J1) - BNDU1=UPBND(J1)+UPBND(J2) - KSTAT=STAVAR(J2) - STAVAR(J2)=0 - UPBND(J2)=BIG - IF(DABS(BNDL1).LE.FSBTOL) THEN - BNDL1=0.0D0 - ELSE - K2BEG=CLPNTS(J2) - K2END=K2BEG+LENCOL(J2)-1 - DO 540 K2=K2BEG,K2END - IR=RWNMBS(K2) - B(IR)=B(IR)-BNDL1*ACOEFF(K2) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - 540 CONTINUE - STAVAR(J2)=2 - ENDIF - IF(KSTAT.LE.1) THEN - LOBND(J2)=BNDL1 - ELSE - STAVAR(J2)=2 - LOBND(J2)=LOBND(J2)+BNDL1 - ENDIF -C -C Save the new LOWER bound in a PRE_SOLVE history list. - IF(LNHIST.GE.MXHIST) GO TO 9200 - LNHIST=LNHIST+1 - INHIST(LNHIST)=-J2 - DPHIST(LNHIST)=BNDL1 -C - IF(BNDU1.LE.BIGNEW) THEN - STAVAR(J2)=STAVAR(J2)+1 - UPBND(J2)=BNDU1 -C -C Reinitialize bounds on shadow prices. - KBEG0=CLPNTS(J2) - KEND0=KBEG0+LENCOL(J2)-1 - DO 560 IKX=KBEG0,KEND0 - IR=RWNMBS(IKX) - P(IR)=-BIG - Q(IR)=BIG - IF(RANGES(IR).LE.BIGNEW) GO TO 560 - IF(RWSTAT(IR).EQ.2) P(IR)=0.0D0 - IF(RWSTAT(IR).EQ.3) Q(IR)=0.0D0 - 560 CONTINUE - ENDIF - IF(MSGLEV.LE.1) GO TO 562 - WRITE(BUFFER,561) CLNAME(J2),CLNAME(J1) - 561 FORMAT(1X,'FDIDEN: Variable=',A8, - X ' becomes a diff. of variable=',A8,' and itself.') - CALL MYWRT(IOERR,BUFFER) - 562 CONTINUE - GO TO 720 -C -C -C -C Check if columns J and JCOL are identical. - 600 IF(DABS(ALPHA-1.0D0).GE.SMALLA) GO TO 800 -C -C Here if two columns J and JCOL are identical. - IF(MSGLEV.LE.2) GO TO 705 - WRITE(BUFFER,701) CLNAME(J),CLNAME(JCOL) - 701 FORMAT(1X,'FDIDEN: LP variables: ', - X A8,' and ',A8,' are identical.') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,702) J,C(J),STAVAR(J) - 702 FORMAT(1X,'FDIDEN: var=',I6,' Cj=',D14.6,' stavar=',I6) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,703) JCOL,C(JCOL),STAVAR(JCOL) - 703 FORMAT(1X,' and var=',I6,' Cj=',D14.6,' stavar=',I6) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,704) KROW,RWSTAT(KROW),LROW - 704 FORMAT(1X,' row=',I5,' rwstat=',I5,' len=',I5) - CALL MYWRT(IOERR,BUFFER) - 705 CONTINUE -C -C -C Identical columns are found. -C If the objective coefficients C1 and C2 are the same, then column -C aggregation is possible. If they are different, however, then it -C may be possible to fix one of variables. - DP=C(J)-C(JCOL) - IF(DABS(DP).LE.SMALLA) THEN -C -C Here if the objective coefficients C1 and C2 are the same. - KSTAT=STAVAR(J) - BNDU1=BIG - IF(KSTAT.EQ.1.OR.KSTAT.EQ.3) BNDU1=UPBND(J) - KSTAT=STAVAR(JCOL) - BNDU2=BIG - IF(KSTAT.EQ.1.OR.KSTAT.EQ.3) BNDU2=UPBND(JCOL) -C -C J2 becomes an aggregate column and J1 becomes FIXED. - J1=JCOL - J2=J -C -C Determine an UPPER bound and status of the aggregate variable. - STAVAR(J2)=0 - UPBND(J2)=BIG - BNDL1=LOBND(J2) - IF(DABS(BNDL1).LE.FSBTOL) THEN - BNDL1=0.0D0 - ELSE - STAVAR(J2)=2 - ENDIF - BNDU1=BNDU1+BNDU2 - IF(BNDU1.LE.BIGNEW) THEN - STAVAR(J2)=STAVAR(J2)+1 - UPBND(J2)=BNDU1 -C -C Reinitialize bounds on shadow prices. - KBEG0=CLPNTS(J2) - KEND0=KBEG0+LENCOL(J2)-1 - DO 710 IKX=KBEG0,KEND0 - IR=RWNMBS(IKX) - P(IR)=-BIG - Q(IR)=BIG - IF(RANGES(IR).LE.BIGNEW) GO TO 710 - IF(RWSTAT(IR).EQ.2) P(IR)=0.0D0 - IF(RWSTAT(IR).EQ.3) Q(IR)=0.0D0 - 710 CONTINUE - ENDIF - IF(MSGLEV.LE.1) GO TO 712 - WRITE(BUFFER,711) CLNAME(J2),CLNAME(J1) - 711 FORMAT(1X,'FDIDEN: Variable=',A8, - X ' becomes a sum of variable=',A8,' and itself.') - CALL MYWRT(IOERR,BUFFER) - 712 CONTINUE - GO TO 720 - ENDIF -C -C Here if the objective coefficients C1 and C2 are different. - IF(DP.GE.SMALLA) THEN - J1=J - J2=JCOL - ENDIF - IF(DP.LE.-SMALLA) THEN - J1=JCOL - J2=J - ENDIF - KSTAT=STAVAR(J2) - IF(KSTAT.EQ.1.OR.KSTAT.EQ.3) GO TO 800 -C -C FIX variable J1 on its LOWER bound. - 720 X0=0.0D0 - IF(MSGLEV.LE.1) GO TO 722 - WRITE(BUFFER,721) J1,CLNAME(J1),X0 - 721 FORMAT(1X,'FDIDEN: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 722 CONTINUE - IF(STAVAR(J1).NE.1.AND.STAVAR(J1).NE.3) THEN -C -C Reinitialize bounds on shadow prices. -C WRITE(BUFFER,741) J1,CLNAME(J1),STAVAR(J1) -C 741 FORMAT(1X,'FDIDEN: Variable ',I6,' (name=',A8, -C X ' st=',I6,')') -C CALL MYWRT(IOERR,BUFFER) - KBEG0=CLPNTS(J1) - KEND0=KBEG0+LENCOL(J1)-1 - DO 740 IKX=KBEG0,KEND0 - IR=RWNMBS(IKX) - P(IR)=-BIG - Q(IR)=BIG - IF(RANGES(IR).LE.BIGNEW) GO TO 740 - IF(RWSTAT(IR).EQ.2) P(IR)=0.0D0 - IF(RWSTAT(IR).EQ.3) Q(IR)=0.0D0 - 740 CONTINUE - ENDIF - NFIXED=NFIXED+1 - PRLVAR(J1)=X0 - STAVAR(J1)=6 - IF(J1.EQ.J) GO TO 810 - IF(STAVAR(J).LT.0) GO TO 810 -C - 800 IPOS=RWLINK(IPOS) - GO TO 400 - 810 CONTINUE -C -C -C Restore zero value of RMTMP1 array. - 940 DO 960 K=KBEG,KEND - IR=RWNMBS(K) - RMTMP1(IR)=0.0D0 - 960 CONTINUE -C -C -C -C End of main loop. - 1000 CONTINUE -C -C -C -C -C -C -C Check if RMTMP1 array is zero. - DO 1100 I=1,M - IF(DABS(RMTMP1(I)).GE.SMALLA) THEN - WRITE(BUFFER,1101) I,RMTMP1(I) - 1101 FORMAT(1X,'FDIDEN ERROR: RMTMP1(',I6,')=',D14.8) - CALL ERRWRT(IOERR,BUFFER) - STOP - ENDIF - 1100 CONTINUE -C -C -C -C -C -C -C Here if a successful run has been completed. - IF(MSGLEV.LE.0) GO TO 1110 - WRITE(BUFFER,1105) NFIXED - 1105 FORMAT(1X,'FDIDEN: Variables eliminated: ',I9) -C CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,1106) NFREE - 1106 FORMAT(1X,' Split FREE variables: ',I9) -C CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - 1110 CONTINUE -C -C -C -C -C -C Zero RWHEAD and LENROW arrays. - IF(NFIXED.EQ.0) GO TO 1400 - DO 1200 I=1,M - RWHEAD(I)=0 - LENROW(I)=0 - 1200 CONTINUE -C -C Set the row linked lists. -C Count nonzero elements in all rows of A. - DO 1300 J=1,N -C -C Omit FIXED variables. - IF(STAVAR(J).GE.6) GO TO 1300 - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 1250 K=KBEG,KEND - I=RWNMBS(K) - RWLINK(K)=RWHEAD(I) - CLNMBS(K)=J - RWHEAD(I)=K - LENROW(I)=LENROW(I)+1 - 1250 CONTINUE - 1300 CONTINUE - 1400 CONTINUE -C -C -C -C -C -C - RETURN -C -C - 9200 WRITE(BUFFER,9201) - 9201 FORMAT(1X,'FDIDEN: Please increase space for PRE_SOLVE ', - X 'history list.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C -C -C *** LAST CARD OF (FDIDEN) *** - END //GO.SYSIN DD hopdm.src/fdiden.f echo hopdm.src/fsaty.f 1>&2 sed >hopdm.src/fsaty.f <<'//GO.SYSIN DD hopdm.src/fsaty.f' 's/^-//' -C******************************************************** -C **** FSATY ... FAST (sparse)Atransp * (dense)Y **** -C******************************************************** -C - SUBROUTINE FSATY(MAXM,MAXN,MAXNZA,Y,M,X,N, - X ACOEFF,CLPNTS,RWNMBS,LENCOL,VUSED,IOERR) -C -C *** PARAMETERS - INTEGER*4 MAXM,MAXN,MAXNZA,M,N,IOERR - DOUBLE PRECISION X(N),Y(M),ACOEFF(MAXNZA) - INTEGER*4 CLPNTS(MAXN+1) - INTEGER*2 RWNMBS(MAXNZA),LENCOL(MAXN) - LOGICAL VUSED(MAXN) -C -C *** LOCAL VARIABLES - INTEGER*4 IR,J,K,KBEG,KEND -C -C -C *** PURPOSE -C This routine computes the product of a sparse matrix Atransp -C and a dense vector Y and saves the result in a dense vector X. -C It is given direct access to matrix A. -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of rows of the LP constraint matrix. -C N Number of columns of the LP constraint matrix. -C Y Dense vector of dimension M. -C ACOEFF Nonzero elements of matrix A. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C LENCOL Lengths of columns of matrix A. -C VUSED An indicator if a variable is active in the optimization -C process: -C .TRUE. active variable; -C .FALSE. FIXED variable. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C X Dense vector of dimension N (X = Atransp * Y). -C -C -C *** SUBROUTINES CALLED: -C NONE -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: December 3, 1993 -C -C -C *** BODY OF (FSATY) *** -C - DO 200 J=1,N - X(J)=0.0 - IF(.NOT.VUSED(J)) GO TO 200 - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 100 K=KBEG,KEND - IR=RWNMBS(K) - X(J)=X(J)+Y(IR)*ACOEFF(K) - 100 CONTINUE - 200 CONTINUE - RETURN -C -C *** LAST CARD OF (FSATY) *** - END //GO.SYSIN DD hopdm.src/fsaty.f echo hopdm.src/fsax.f 1>&2 sed >hopdm.src/fsax.f <<'//GO.SYSIN DD hopdm.src/fsax.f' 's/^-//' -C******************************************************** -C **** FSAX ... FAST (sparse)A * (dense)X **** -C******************************************************** -C - SUBROUTINE FSAX(MAXM,MAXN,MAXNZA,X,N,Y,M, - X ACOEFF,CLPNTS,RWNMBS,LENCOL,VUSED,IOERR) -C -C *** PARAMETERS - INTEGER*4 MAXM,MAXN,MAXNZA,M,N,IOERR - DOUBLE PRECISION X(N),Y(M),ACOEFF(MAXNZA) - INTEGER*4 CLPNTS(MAXN+1) - INTEGER*2 RWNMBS(MAXNZA),LENCOL(MAXN) - LOGICAL VUSED(MAXN) -C -C *** LOCAL VARIABLES - INTEGER*4 IR,J,K,KBEG,KEND -C -C -C *** PURPOSE -C This routine computes the product of a sparse matrix A and -C a dense vector X and saves the result in a dense vector Y. -C It is given direct access to matrix A. -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of rows of the LP constraint matrix. -C N Number of columns of the LP constraint matrix. -C X Dense vector of dimension N. -C ACOEFF Nonzero elements of matrix A. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C LENCOL Lengths of columns of matrix A. -C VUSED An indicator if a variable is active in the optimization -C process: -C .TRUE. active variable; -C .FALSE. FIXED variable. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C Y Dense vector of dimension M (Y = A * X). -C -C -C *** SUBROUTINES CALLED: -C NONE -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: December 3, 1993 -C -C -C *** BODY OF (FSAX) *** -C - DO 100 IR=1,M - Y(IR)=0.0D0 - 100 CONTINUE - DO 300 J=1,N - IF(.NOT.VUSED(J)) GO TO 300 - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 200 K=KBEG,KEND - IR=RWNMBS(K) - Y(IR)=Y(IR)+X(J)*ACOEFF(K) - 200 CONTINUE - 300 CONTINUE - RETURN -C -C *** LAST CARD OF (FSAX) *** - END //GO.SYSIN DD hopdm.src/fsax.f echo hopdm.src/ftime.c 1>&2 sed >hopdm.src/ftime.c <<'//GO.SYSIN DD hopdm.src/ftime.c' 's/^-//' -#include "time.h" -#include "sys/types.h" -#include "sys/times.h" -#include "limits.h" - -#ifndef CLK_TCK -#define CLK_TCK 60 -#endif - - void -#ifdef KR_headers -fdate_(buf, len) char *buf; long len; -#else -fdate_(char *buf, long len) -#endif -{ - char *b; - clock_t t; - - t = time(0); - b = ctime(&t); - while(--len >= 0) - *buf++ = *b++; - } - - float -#ifdef KR_headers -dtime_(tar) float *tar; -#else -dtime_(float *tar) -#endif -{ - struct tms tm; - static struct tms tm0; - clock_t rv, t; - static clock_t t0; - static float clk_tck; - - t = times(&tm); - rv = t - t0; - if (!t0) - clk_tck = CLK_TCK; - t0 = t; - tar[0] = (tm.tms_utime - tm0.tms_utime) / clk_tck; - tar[1] = (tm.tms_stime - tm0.tms_stime) / clk_tck; - tm0 = tm; - return rv / clk_tck; - } //GO.SYSIN DD hopdm.src/ftime.c echo hopdm.src/genqmd.f 1>&2 sed >hopdm.src/genqmd.f <<'//GO.SYSIN DD hopdm.src/genqmd.f' 's/^-//' -C----- SUBROUTINE GENQMD -C**************************************************************** -C**************************************************************** -C********** GENQMD ..... QUOT MIN DEGREE ORDERING ********* -C**************************************************************** -C**************************************************************** -C -C PURPOSE - THIS ROUTINE IMPLEMENTS THE MINIMUM DEGREE -C ALGORITHM. IT MAKES USE OF THE IMPLICIT REPRESENT- -C ATION OF THE ELIMINATION GRAPHS BY QUOTIENT GRAPHS, -C AND THE NOTION OF INDISTINGUISHABLE NODES. -C CAUTION - THE ADJACENCY VECTOR ADJNCY WILL BE -C DESTROYED. -C -C INPUT PARAMETERS - -C NEQNS - NUMBER OF EQUATIONS. -C (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE. -C -C OUTPUT PARAMETERS - -C PERM - THE MINIMUM DEGREE ORDERING. -C INVP - THE INVERSE OF PERM. -C -C WORKING PARAMETERS - -C DEG - THE DEGREE VECTOR. DEG(I) IS NEGATIVE MEANS -C NODE I HAS BEEN NUMBERED. -C MARKER - A MARKER VECTOR, WHERE MARKER(I) IS -C NEGATIVE MEANS NODE I HAS BEEN MERGED WITH -C ANOTHER NODE AND THUS CAN BE IGNORED. -C RCHSET - VECTOR USED FOR THE REACHABLE SET. -C NBRHD - VECTOR USED FOR THE NEIGHBORHOOD SET. -C QSIZE - VECTOR USED TO STORE THE SIZE OF -C INDISTINGUISHABLE SUPERNODES. -C QLINK - VECTOR TO STORE INDISTINGUISHABLE NODES, -C I, QLINK(I), QLINK(QLINK(I)) ... ARE THE -C MEMBERS OF THE SUPERNODE REPRESENTED BY I. -C -C PROGRAM SUBROUTINES - -C QMDRCH, QMDQT, QMDUPD. -C -C**************************************************************** -C -C - SUBROUTINE GENQMD ( NEQNS, XADJ, ADJNCY, PERM, INVP, DEG, - 1 MARKER, RCHSET, NBRHD, QSIZE, QLINK, - 1 NOFSUB ) -C -C**************************************************************** -C - INTEGER ADJNCY(1), PERM(1), INVP(1), DEG(1), MARKER(1), - 1 RCHSET(1), NBRHD(1), QSIZE(1), QLINK(1) - INTEGER XADJ(1), INODE, IP, IRCH, J, MINDEG, NDEG, - 1 NEQNS, NHDSZE, NODE, NOFSUB, NP, NUM, NUMP1, - 1 NXNODE, RCHSZE, SEARCH, THRESH -C -C**************************************************************** -C -C ----------------------------------------------------- -C INITIALIZE DEGREE VECTOR AND OTHER WORKING VARIABLES. -C ----------------------------------------------------- - MINDEG = NEQNS - NOFSUB = 0 - DO 100 NODE = 1, NEQNS - PERM(NODE) = NODE - INVP(NODE) = NODE - MARKER(NODE) = 0 - QSIZE(NODE) = 1 - QLINK(NODE) = 0 - NDEG = XADJ(NODE+1) - XADJ(NODE) - DEG(NODE) = NDEG - IF ( NDEG .LT. MINDEG ) MINDEG = NDEG - 100 CONTINUE - NUM = 0 -C ----------------------------------------------------- -C PERFORM THRESHOLD SEARCH TO GET A NODE OF MIN DEGREE. -C VARIABLE SEARCH POINTS TO WHERE SEARCH SHOULD START. -C ----------------------------------------------------- - 200 SEARCH = 1 - THRESH = MINDEG - MINDEG = NEQNS - 300 NUMP1 = NUM + 1 - IF ( NUMP1 .GT. SEARCH ) SEARCH = NUMP1 - DO 400 J = SEARCH, NEQNS - NODE = PERM(J) - IF ( MARKER(NODE) .LT. 0 ) GOTO 400 - NDEG = DEG(NODE) - IF ( NDEG .LE. THRESH ) GO TO 500 - IF ( NDEG .LT. MINDEG ) MINDEG = NDEG - 400 CONTINUE - GO TO 200 -C --------------------------------------------------- -C NODE HAS MINIMUM DEGREE. FIND ITS REACHABLE SETS BY -C CALLING QMDRCH. -C --------------------------------------------------- - 500 SEARCH = J - NOFSUB = NOFSUB + DEG(NODE) - MARKER(NODE) = 1 - CALL QMDRCH (NODE, XADJ, ADJNCY, DEG, MARKER, - 1 RCHSZE, RCHSET, NHDSZE, NBRHD ) -C ------------------------------------------------ -C ELIMINATE ALL NODES INDISTINGUISHABLE FROM NODE. -C THEY ARE GIVEN BY NODE, QLINK(NODE), .... -C ------------------------------------------------ - NXNODE = NODE - 600 NUM = NUM + 1 - NP = INVP(NXNODE) - IP = PERM(NUM) - PERM(NP) = IP - INVP(IP) = NP - PERM(NUM) = NXNODE - INVP(NXNODE) = NUM - DEG(NXNODE) = - 1 - NXNODE = QLINK(NXNODE) - IF (NXNODE .GT. 0) GOTO 600 -C - IF ( RCHSZE .LE. 0 ) GO TO 800 -C ------------------------------------------------ -C UPDATE THE DEGREES OF THE NODES IN THE REACHABLE -C SET AND IDENTIFY INDISTINGUISHABLE NODES. -C ------------------------------------------------ - CALL QMDUPD ( XADJ, ADJNCY, RCHSZE, RCHSET, DEG, - 1 QSIZE, QLINK, MARKER, RCHSET(RCHSZE+1), - 1 NBRHD(NHDSZE+1) ) -C ------------------------------------------- -C RESET MARKER VALUE OF NODES IN REACH SET. -C UPDATE THRESHOLD VALUE FOR CYCLIC SEARCH. -C ALSO CALL QMDQT TO FORM NEW QUOTIENT GRAPH. -C ------------------------------------------- - MARKER(NODE) = 0 - DO 700 IRCH = 1, RCHSZE - INODE = RCHSET(IRCH) - IF ( MARKER(INODE) .LT. 0 ) GOTO 700 - MARKER(INODE) = 0 - NDEG = DEG(INODE) - IF ( NDEG .LT. MINDEG ) MINDEG = NDEG - IF ( NDEG .GT. THRESH ) GOTO 700 - MINDEG = THRESH - THRESH = NDEG - SEARCH = INVP(INODE) - 700 CONTINUE - IF ( NHDSZE .GT. 0 ) CALL QMDQT ( NODE, XADJ, - 1 ADJNCY, MARKER, RCHSZE, RCHSET, NBRHD ) - 800 IF ( NUM .LT. NEQNS ) GO TO 300 - RETURN - END -C----- SUBROUTINE QMDQT -C************************************************************* -C************************************************************* -C******* QMDQT ..... QUOT MIN DEG QUOT TRANSFORM ******* -C************************************************************* -C************************************************************* -C -C PURPOSE - THIS SUBROUTINE PERFORMS THE QUOTIENT GRAPH -C TRANSFORMATION AFTER A NODE HAS BEEN ELIMINATED. -C -C INPUT PARAMETERS - -C ROOT - THE NODE JUST ELIMINATED. IT BECOMES THE -C REPRESENTATIVE OF THE NEW SUPERNODE. -C (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE. -C (RCHSZE, RCHSET) - THE REACHABLE SET OF ROOT IN THE -C OLD QUOTIENT GRAPH. -C NBRHD - THE NEIGHBORHOOD SET WHICH WILL BE MERGED -C WITH ROOT TO FORM THE NEW SUPERNODE. -C MARKER - THE MARKER VECTOR. -C -C UPDATED PARAMETER - -C ADJNCY - BECOMES THE ADJNCY OF THE QUOTIENT GRAPH. -C -C************************************************************* -C - SUBROUTINE QMDQT ( ROOT, XADJ, ADJNCY, MARKER, - 1 RCHSZE, RCHSET, NBRHD ) -C -C************************************************************* -C - INTEGER ADJNCY(1), MARKER(1), RCHSET(1), NBRHD(1) - INTEGER XADJ(1), INHD, IRCH, J, JSTRT, JSTOP, LINK, - 1 NABOR, NODE, RCHSZE, ROOT -C -C************************************************************* -C - IRCH = 0 - INHD = 0 - NODE = ROOT - 100 JSTRT = XADJ(NODE) - JSTOP = XADJ(NODE+1) - 2 - IF ( JSTOP .LT. JSTRT ) GO TO 300 -C ------------------------------------------------ -C PLACE REACH NODES INTO THE ADJACENT LIST OF NODE -C ------------------------------------------------ - DO 200 J = JSTRT, JSTOP - IRCH = IRCH + 1 - ADJNCY(J) = RCHSET(IRCH) - IF ( IRCH .GE. RCHSZE ) GOTO 400 - 200 CONTINUE -C ---------------------------------------------- -C LINK TO OTHER SPACE PROVIDED BY THE NBRHD SET. -C ---------------------------------------------- - 300 LINK = ADJNCY(JSTOP+1) - NODE = - LINK - IF ( LINK .LT. 0 ) GOTO 100 - INHD = INHD + 1 - NODE = NBRHD(INHD) - ADJNCY(JSTOP+1) = - NODE - GO TO 100 -C ------------------------------------------------------- -C ALL REACHABLE NODES HAVE BEEN SAVED. END THE ADJ LIST. -C ADD ROOT TO THE NBR LIST OF EACH NODE IN THE REACH SET. -C ------------------------------------------------------- - 400 ADJNCY(J+1) = 0 - DO 600 IRCH = 1, RCHSZE - NODE = RCHSET(IRCH) - IF ( MARKER(NODE) .LT. 0 ) GOTO 600 - JSTRT = XADJ(NODE) - JSTOP = XADJ(NODE+1) - 1 - DO 500 J = JSTRT, JSTOP - NABOR = ADJNCY(J) - IF ( MARKER(NABOR) .GE. 0 ) GO TO 500 - ADJNCY(J) = ROOT - GOTO 600 - 500 CONTINUE - 600 CONTINUE - RETURN - END -C----- SUBROUTINE QMDUPD -C**************************************************************** -C**************************************************************** -C********** QMDUPD ..... QUOT MIN DEG UPDATE *********** -C**************************************************************** -C**************************************************************** -C -C PURPOSE - THIS ROUTINE PERFORMS DEGREE UPDATE FOR A SET -C OF NODES IN THE MINIMUM DEGREE ALGORITHM. -C -C INPUT PARAMETERS - -C (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE. -C (NLIST, LIST) - THE LIST OF NODES WHOSE DEGREE HAS TO -C BE UPDATED. -C -C UPDATED PARAMETERS - -C DEG - THE DEGREE VECTOR. -C QSIZE - SIZE OF INDISTINGUISHABLE SUPERNODES. -C QLINK - LINKED LIST FOR INDISTINGUISHABLE NODES. -C MARKER - USED TO MARK THOSE NODES IN REACH/NBRHD SETS. -C -C WORKING PARAMETERS - -C RCHSET - THE REACHABLE SET. -C NBRHD - THE NEIGHBORHOOD SET. -C -C PROGRAM SUBROUTINES - -C QMDMRG. -C -C**************************************************************** -C - SUBROUTINE QMDUPD ( XADJ, ADJNCY, NLIST, LIST, DEG, - 1 QSIZE, QLINK, MARKER, RCHSET, NBRHD ) -C -C**************************************************************** -C - INTEGER ADJNCY(1), LIST(1), DEG(1), MARKER(1), - 1 RCHSET(1), NBRHD(1), QSIZE(1), QLINK(1) - INTEGER XADJ(1), DEG0, DEG1, IL, INHD, INODE, IRCH, - 1 J, JSTRT, JSTOP, MARK, NABOR, NHDSZE, NLIST, - 1 NODE, RCHSZE -C -C**************************************************************** -C -C ------------------------------------------------ -C FIND ALL ELIMINATED SUPERNODES THAT ARE ADJACENT -C TO SOME NODES IN THE GIVEN LIST. PUT THEM INTO -C (NHDSZE, NBRHD). DEG0 CONTAINS THE NUMBER OF -C NODES IN THE LIST. -C ------------------------------------------------ - IF ( NLIST .LE. 0 ) RETURN - DEG0 = 0 - NHDSZE = 0 - DO 200 IL = 1, NLIST - NODE = LIST(IL) - DEG0 = DEG0 + QSIZE(NODE) - JSTRT = XADJ(NODE) - JSTOP = XADJ(NODE+1) - 1 - DO 100 J = JSTRT, JSTOP - NABOR = ADJNCY(J) - IF ( MARKER(NABOR) .NE. 0 .OR. - 1 DEG(NABOR) .GE. 0 ) GO TO 100 - MARKER(NABOR) = - 1 - NHDSZE = NHDSZE + 1 - NBRHD(NHDSZE) = NABOR - 100 CONTINUE - 200 CONTINUE -C -------------------------------------------- -C MERGE INDISTINGUISHABLE NODES IN THE LIST BY -C CALLING THE SUBROUTINE QMDMRG. -C -------------------------------------------- - IF ( NHDSZE .GT. 0 ) - 1 CALL QMDMRG ( XADJ, ADJNCY, DEG, QSIZE, QLINK, - 1 MARKER, DEG0, NHDSZE, NBRHD, RCHSET, - 1 NBRHD(NHDSZE+1) ) -C ---------------------------------------------------- -C FIND THE NEW DEGREES OF THE NODES THAT HAVE NOT BEEN -C MERGED. -C ---------------------------------------------------- - DO 600 IL = 1, NLIST - NODE = LIST(IL) - MARK = MARKER(NODE) - IF ( MARK .GT. 1 .OR. MARK .LT. 0 ) GO TO 600 - MARKER(NODE) = 2 - CALL QMDRCH ( NODE, XADJ, ADJNCY, DEG, MARKER, - 1 RCHSZE, RCHSET, NHDSZE, NBRHD ) - DEG1 = DEG0 - IF ( RCHSZE .LE. 0 ) GO TO 400 - DO 300 IRCH = 1, RCHSZE - INODE = RCHSET(IRCH) - DEG1 = DEG1 + QSIZE(INODE) - MARKER(INODE) = 0 - 300 CONTINUE - 400 DEG(NODE) = DEG1 - 1 - IF ( NHDSZE .LE. 0 ) GO TO 600 - DO 500 INHD = 1, NHDSZE - INODE = NBRHD(INHD) - MARKER(INODE) = 0 - 500 CONTINUE - 600 CONTINUE - RETURN - END -C----- SUBROUTINE QMDRCH -C*************************************************************** -C*************************************************************** -C********* QMDRCH ..... QUOT MIN DEG REACH SET ********** -C*************************************************************** -C*************************************************************** -C -C PURPOSE - THIS SUBROUTINE DETERMINES THE REACHABLE SET OF -C A NODE THROUGH A GIVEN SUBSET. THE ADJACENCY STRUCTURE -C IS ASSUMED TO BE STORED IN A QUOTIENT GRAPH FORMAT. -C -C INPUT PARAMETERS - -C ROOT - THE GIVEN NODE NOT IN THE SUBSET. -C (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE PAIR. -C DEG - THE DEGREE VECTOR. DEG(I) LT 0 MEANS THE NODE -C BELONGS TO THE GIVEN SUBSET. -C -C OUTPUT PARAMETERS - -C (RCHSZE, RCHSET) - THE REACHABLE SET. -C (NHDSZE, NBRHD) - THE NEIGHBORHOOD SET. -C -C UPDATED PARAMETERS - -C MARKER - THE MARKER VECTOR FOR REACH AND NBRHD SETS. -C GT 0 MEANS THE NODE IS IN REACH SET. -C LT 0 MEANS THE NODE HAS BEEN MERGED WITH -C OTHERS IN THE QUOTIENT OR IT IS IN NBRHD SET. -C -C*************************************************************** -C - SUBROUTINE QMDRCH ( ROOT, XADJ, ADJNCY, DEG, MARKER, - 1 RCHSZE, RCHSET, NHDSZE, NBRHD ) -C -C*************************************************************** -C - INTEGER ADJNCY(1), DEG(1), MARKER(1), - 1 RCHSET(1), NBRHD(1) - INTEGER XADJ(1), I, ISTRT, ISTOP, J, JSTRT, JSTOP, - 1 NABOR, NHDSZE, NODE, RCHSZE, ROOT -C -C*************************************************************** -C -C ----------------------------------------- -C LOOP THROUGH THE NEIGHBORS OF ROOT IN THE -C QUOTIENT GRAPH. -C ----------------------------------------- - NHDSZE = 0 - RCHSZE = 0 - ISTRT = XADJ(ROOT) - ISTOP = XADJ(ROOT+1) - 1 - IF ( ISTOP .LT. ISTRT ) RETURN - DO 600 I = ISTRT, ISTOP - NABOR = ADJNCY(I) - IF ( NABOR .EQ. 0 ) RETURN - IF ( MARKER(NABOR) .NE. 0 ) GO TO 600 - IF ( DEG(NABOR) .LT. 0 ) GO TO 200 -C ------------------------------------- -C INCLUDE NABOR INTO THE REACHABLE SET. -C ------------------------------------- - RCHSZE = RCHSZE + 1 - RCHSET(RCHSZE) = NABOR - MARKER(NABOR) = 1 - GO TO 600 -C ------------------------------------- -C NABOR HAS BEEN ELIMINATED. FIND NODES -C REACHABLE FROM IT. -C ------------------------------------- - 200 MARKER(NABOR) = -1 - NHDSZE = NHDSZE + 1 - NBRHD(NHDSZE) = NABOR - 300 JSTRT = XADJ(NABOR) - JSTOP = XADJ(NABOR+1) - 1 - DO 500 J = JSTRT, JSTOP - NODE = ADJNCY(J) - NABOR = - NODE - IF (NODE) 300, 600, 400 - 400 IF ( MARKER(NODE) .NE. 0 ) GO TO 500 - RCHSZE = RCHSZE + 1 - RCHSET(RCHSZE) = NODE - MARKER(NODE) = 1 - 500 CONTINUE - 600 CONTINUE - RETURN - END -C----- SUBROUTINE QMDMRG -C**************************************************************** -C**************************************************************** -C********** QMDMRG ..... QUOT MIN DEG MERGE *********** -C**************************************************************** -C**************************************************************** -C -C PURPOSE - THIS ROUTINE MERGES INDISTINGUISHABLE NODES IN -C THE MINIMUM DEGREE ORDERING ALGORITHM. -C IT ALSO COMPUTES THE NEW DEGREES OF THESE -C NEW SUPERNODES. -C -C INPUT PARAMETERS - -C (XADJ, ADJNCY) - THE ADJACENCY STRUCTURE. -C DEG0 - THE NUMBER OF NODES IN THE GIVEN SET. -C (NHDSZE, NBRHD) - THE SET OF ELIMINATED SUPERNODES -C ADJACENT TO SOME NODES IN THE SET. -C -C UPDATED PARAMETERS - -C DEG - THE DEGREE VECTOR. -C QSIZE - SIZE OF INDISTINGUISHABLE NODES. -C QLINK - LINKED LIST FOR INDISTINGUISHABLE NODES. -C MARKER - THE GIVEN SET IS GIVEN BY THOSE NODES WITH -C MARKER VALUE SET TO 1. THOSE NODES WITH DEGREE -C UPDATED WILL HAVE MARKER VALUE SET TO 2. -C -C WORKING PARAMETERS - -C RCHSET - THE REACHABLE SET. -C OVRLP - TEMP VECTOR TO STORE THE INTERSECTION OF TWO -C REACHABLE SETS. -C -C**************************************************************** -C - SUBROUTINE QMDMRG ( XADJ, ADJNCY, DEG, QSIZE, QLINK, - 1 MARKER, DEG0, NHDSZE, NBRHD, RCHSET, - 1 OVRLP ) -C -C**************************************************************** -C - INTEGER ADJNCY(1), DEG(1), QSIZE(1), QLINK(1), - 1 MARKER(1), RCHSET(1), NBRHD(1), OVRLP(1) - INTEGER XADJ(1), DEG0, DEG1, HEAD, INHD, IOV, IRCH, - 1 J, JSTRT, JSTOP, LINK, LNODE, MARK, MRGSZE, - 1 NABOR, NHDSZE, NODE, NOVRLP, RCHSZE, ROOT -C -C**************************************************************** -C -C ------------------ -C INITIALIZATION ... -C ------------------ - IF ( NHDSZE .LE. 0 ) RETURN - DO 100 INHD = 1, NHDSZE - ROOT = NBRHD(INHD) - MARKER(ROOT) = 0 - 100 CONTINUE -C ------------------------------------------------- -C LOOP THROUGH EACH ELIMINATED SUPERNODE IN THE SET -C (NHDSZE, NBRHD). -C ------------------------------------------------- - DO 1400 INHD = 1, NHDSZE - ROOT = NBRHD(INHD) - MARKER(ROOT) = - 1 - RCHSZE = 0 - NOVRLP = 0 - DEG1 = 0 - 200 JSTRT = XADJ(ROOT) - JSTOP = XADJ(ROOT+1) - 1 -C ---------------------------------------------- -C DETERMINE THE REACHABLE SET AND ITS INTERSECT- -C ION WITH THE INPUT REACHABLE SET. -C ---------------------------------------------- - DO 600 J = JSTRT, JSTOP - NABOR = ADJNCY(J) - ROOT = - NABOR - IF (NABOR) 200, 700, 300 -C - 300 MARK = MARKER(NABOR) - IF ( MARK ) 600, 400, 500 - 400 RCHSZE = RCHSZE + 1 - RCHSET(RCHSZE) = NABOR - DEG1 = DEG1 + QSIZE(NABOR) - MARKER(NABOR) = 1 - GOTO 600 - 500 IF ( MARK .GT. 1 ) GOTO 600 - NOVRLP = NOVRLP + 1 - OVRLP(NOVRLP) = NABOR - MARKER(NABOR) = 2 - 600 CONTINUE -C -------------------------------------------- -C FROM THE OVERLAPPED SET, DETERMINE THE NODES -C THAT CAN BE MERGED TOGETHER. -C -------------------------------------------- - 700 HEAD = 0 - MRGSZE = 0 - DO 1100 IOV = 1, NOVRLP - NODE = OVRLP(IOV) - JSTRT = XADJ(NODE) - JSTOP = XADJ(NODE+1) - 1 - DO 800 J = JSTRT, JSTOP - NABOR = ADJNCY(J) - IF ( MARKER(NABOR) .NE. 0 ) GOTO 800 - MARKER(NODE) = 1 - GOTO 1100 - 800 CONTINUE -C ----------------------------------------- -C NODE BELONGS TO THE NEW MERGED SUPERNODE. -C UPDATE THE VECTORS QLINK AND QSIZE. -C ----------------------------------------- - MRGSZE = MRGSZE + QSIZE(NODE) - MARKER(NODE) = - 1 - LNODE = NODE - 900 LINK = QLINK(LNODE) - IF ( LINK .LE. 0 ) GOTO 1000 - LNODE = LINK - GOTO 900 - 1000 QLINK(LNODE) = HEAD - HEAD = NODE - 1100 CONTINUE - IF ( HEAD .LE. 0 ) GOTO 1200 - QSIZE(HEAD) = MRGSZE - DEG(HEAD) = DEG0 + DEG1 - 1 - MARKER(HEAD) = 2 -C -------------------- -C RESET MARKER VALUES. -C -------------------- - 1200 ROOT = NBRHD(INHD) - MARKER(ROOT) = 0 - IF ( RCHSZE .LE. 0 ) GOTO 1400 - DO 1300 IRCH = 1, RCHSZE - NODE = RCHSET(IRCH) - MARKER(NODE) = 0 - 1300 CONTINUE - 1400 CONTINUE - RETURN - END //GO.SYSIN DD hopdm.src/genqmd.f echo hopdm.src/getcol.f 1>&2 sed >hopdm.src/getcol.f <<'//GO.SYSIN DD hopdm.src/getcol.f' 's/^-//' -C************************************************************** -C **** GETCOL ... GET THE J-th COLUMN OF MATRIX A **** -C************************************************************** -C - SUBROUTINE GETCOL(J,RWORK,IWORK,RMAP,IMAP, - X IROW,RELT,COLLEN,MAXN,IOERR) -C -C -C -C *** PARAMETERS - INTEGER*4 J,MAXN,COLLEN,IOERR - INTEGER*4 IROW(MAXN) - DOUBLE PRECISION RELT(MAXN) - INTEGER*4 IWORK(*),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(*) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 MI1,MI2,MI6,MR1 -C -C -C -C *** PARAMETERS DESCRIPTION -C ON INPUT: -C J Index of the column to be created. -C RWORK Real work array that contain almost all real -C LP problem data. -C IWORK Integer work array that contain almost all integer -C LP problem data. -C RMAP Map of RWORK. -C IMAP Map of IWORK. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C ON OUTPUT: -C IROW Row indices of nonzero entries of the column to be created. -C RELT Nonzero entries of the column to be created. -C COLLEN Number of nonzero entries of the column to be created. -C -C -C -C *** SUBROUTINES CALLED -C XGTCOL -C -C -C *** NOTES -C -C Map of IWORK array: -C IMAP(1) Points to CLPNTS array. -C IMAP(2) Points to RWNMBS array. -C IMAP(3) Points to RWHEAD array. -C IMAP(4) Points to RWLINK array. -C IMAP(5) Points to CLNMBS array. -C IMAP(6) Points to LENCOL array. -C IMAP(7) Points to the first empty cell of IWORK array. -C -C Map of RWORK array: -C RMAP(1) Points to ACOEFF array. -C RMAP(2) Points to COBJ array. -C RMAP(3) Points to RHS array. -C RMAP(4) Points to the first empty cell of RWORK array. -C -C -C -C *** REFERENCES: -C Gondzio J., Tachat D. (1992). The design and application -C of IPMLO - a FORTRAN library for linear optimization -C with interior point methods, Technical Report No 108, -C LAMSADE, University of Paris Dauphine, 75775 Paris Cedex 16, -C France, January 1992, revised in November 1992. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: March 21, 1992 -C -C -C -C -C *** BODY OF (GETCOL) *** -C -C -C Set pointers to the arrays in the hidden data structures. -C IMAP(1) Points to CLPNTS array. -C IMAP(2) Points to RWNMBS array. -C IMAP(6) Points to LENCOL array. -C RMAP(1) Points to ACOEFF array. - MI1=IMAP(1) - MI2=IMAP(2) - MI6=IMAP(6) - MR1=RMAP(1) -C -C Call the lower level routine. -C SUBROUTINE XGTCOL(J,ACOEFF, -C X CLPNTS,RWNMBS,LENCOL, -C X IROW,RELT,COLLEN,IOERR) -C - CALL XGTCOL(J,RWORK(MR1), - X IWORK(MI1),IWORK(MI2),IWORK(MI6), - X IROW,RELT,COLLEN,IOERR) -C - RETURN -C -C *** LAST CARD OF (GETCOL) *** - END //GO.SYSIN DD hopdm.src/getcol.f echo hopdm.src/getdat.f 1>&2 sed >hopdm.src/getdat.f <<'//GO.SYSIN DD hopdm.src/getdat.f' 's/^-//' - SUBROUTINE GETDAT( IYEAR, IMONTH, IDAY) - INTEGER*2 IYEAR, IMONTH, IDAY -C -C GETDAT - Get the Current System Time -C -C*****Purpose: -C Subroutine GETDAT returns the current system date in the -C INTEGER*2 output variables IYEAR, IMONTH and IDAY ( the -C year, month and day, respectively ), by calling the Lahey -C Fortran subroutine DATE. -C -C*****Subprograms called: -C Fortran-supplied - ICHAR, DATE. - INTRINSIC ICHAR -C*****History: -C Written by Krzysztof C. Kiwiel, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, 01-447 Warsaw. -C Date last modified: January 16, 1987. -C -C*****Body of subroutine GETDAT: - CHARACTER*8 DAT -C DATE sets DAT='MM:DD:YY'. - CALL DATE( DAT) -C In ASCII 48=ICHAR('0'). - IMONTH=10*(ICHAR( DAT(1:1))-48)+ICHAR( DAT(2:2))-48 - IDAY =10*(ICHAR( DAT(4:4))-48)+ICHAR( DAT(5:5))-48 - IYEAR =10*(ICHAR( DAT(7:7))-48)+ICHAR( DAT(8:8))-48+1900 - RETURN -C*****Last card of subroutine GETDAT********************************** - END //GO.SYSIN DD hopdm.src/getdat.f echo hopdm.src/getdim.f 1>&2 sed >hopdm.src/getdim.f <<'//GO.SYSIN DD hopdm.src/getdim.f' 's/^-//' -C************************************************************** -C *** GETDIM ... DETERMINE CURRENT PROBLEM DIMENSIONS *** -C************************************************************** -C - SUBROUTINE GETDIM(IOERR, - X MAXM,MAXN,M,N,NSTRCT, - X M1,N1,NZ1,B,C,LENCOL,STAVAR) -C -C -C -C *** PARAMETERS - INTEGER*4 IOERR,MAXM,MAXN,M,N,NSTRCT,M1,N1,NZ1 - DOUBLE PRECISION B(MAXM),C(MAXN) - INTEGER*2 LENCOL(MAXN),STAVAR(MAXN) -C -C *** LOCAL VARIABLES - INTEGER*4 J,K -C -C *** PARAMETERS DESCRIPTION -C -C *** ON INPUT: -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C MAXM Maximum number of constraints. -C MAXN Maximum number of variables. -C M Number of constraints. -C N Number of variables (total, i.e. including slacks, -C surplus and artificials). -C NSTRCT Number of structural variables (excluding slacks, -C surplus and artificials). -C B Right hand side of the linear program. -C C Objective function coefficients. -C LENCOL Lengths of (sparse) columns of matrix A. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C -C *** ON OUTPUT: -C M1 Number of constraints. -C N1 Number of structural variables. -C MZ1 Number of nonzeros of the LP constraint matrix. -C -C -C -C -C *** PURPOSE -C This routine determines current dimension of the problem. -C -C *** SUBROUTINES CALLED -C -C *** NOTES -C -C *** REFERENCES: -C Gondzio J. (1994). Analysis of linear programs prior to applying -C the interior point method, Technical Report, -C Department of Management Studies, University of Geneva, -C 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, February 1994. -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: January 9, 1994 -C -C -C -C -C *** BODY OF (GETDIM) *** -C -C Determine current dimensions of the problem. - M1=M - N1=0 - NZ1=0 - DO 100 J=1,NSTRCT - IF(STAVAR(J).GE.6) GO TO 100 - IF(STAVAR(J).LT.0) THEN - K=-STAVAR(J) - IF(J.GE.K) GO TO 100 - ENDIF - N1=N1+1 - NZ1=NZ1+LENCOL(J) - 100 CONTINUE -C - RETURN -C -C *** LAST CARD OF (GETDIM) *** - END //GO.SYSIN DD hopdm.src/getdim.f echo hopdm.src/getrow.f 1>&2 sed >hopdm.src/getrow.f <<'//GO.SYSIN DD hopdm.src/getrow.f' 's/^-//' -C************************************************************** -C **** GETROW ... GET THE I-th ROW OF MATRIX A **** -C************************************************************** -C - SUBROUTINE GETROW(I,RWORK,IWORK,RMAP,IMAP, - X JCOL,RELT,ROWLEN,MAXN,IOERR) -C -C -C -C *** PARAMETERS - INTEGER*4 I,MAXN,ROWLEN,IOERR - INTEGER*4 JCOL(MAXN) - DOUBLE PRECISION RELT(MAXN) - INTEGER*4 IWORK(*),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(*) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 MI3,MI4,MI5,MR1 -C -C -C -C *** PARAMETERS DESCRIPTION -C ON INPUT: -C I Index of the row to be created. -C RWORK Real work array that contain almost all real -C LP problem data. -C IWORK Integer work array that contain almost all integer -C LP problem data. -C RMAP Map of RWORK. -C IMAP Map of IWORK. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C ON OUTPUT: -C JCOL Column indices of nonzero entries of the row to be created. -C RELT Nonzero entries of the row to be created. -C ROWLEN Number of nonzero entries of the row to be created. -C -C -C -C *** SUBROUTINES CALLED -C XGTROW -C -C -C *** NOTES -C -C Map of IWORK array: -C IMAP(1) Points to CLPNTS array. -C IMAP(2) Points to RWNMBS array. -C IMAP(3) Points to RWHEAD array. -C IMAP(4) Points to RWLINK array. -C IMAP(5) Points to CLNMBS array. -C IMAP(6) Points to LENCOL array. -C IMAP(7) Points to the first empty cell of IWORK array. -C -C Map of RWORK array: -C RMAP(1) Points to ACOEFF array. -C RMAP(2) Points to COBJ array. -C RMAP(3) Points to RHS array. -C RMAP(4) Points to the first empty cell of RWORK array. -C -C -C -C *** REFERENCES: -C Gondzio J., Tachat D. (1992). The design and application -C of IPMLO - a FORTRAN library for linear optimization -C with interior point methods, Technical Report No 108, -C LAMSADE, University of Paris Dauphine, 75775 Paris Cedex 16, -C France, January 1992, revised in November 1992. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: March 21, 1992 -C -C -C -C -C *** BODY OF (GETROW) *** -C -C -C Set pointers to the arrays in the hidden data structures. -C IMAP(3) Points to RWHEAD array. -C IMAP(4) Points to RWLINK array. -C IMAP(5) Points to CLNMBS array. -C RMAP(1) Points to ACOEFF array. - MI3=IMAP(3) - MI4=IMAP(4) - MI5=IMAP(5) - MR1=RMAP(1) -C -C Call the lower level routine. -C SUBROUTINE XGTROW(I,ACOEFF, -C X RWHEAD,RWLINK,CLNMBS, -C X JCOL,RELT,ROWLEN,IOERR) -C - CALL XGTROW(I,RWORK(MR1), - X IWORK(MI3),IWORK(MI4),IWORK(MI5), - X JCOL,RELT,ROWLEN,IOERR) -C - RETURN -C -C *** LAST CARD OF (GETROW) *** - END //GO.SYSIN DD hopdm.src/getrow.f echo hopdm.src/gettim.f 1>&2 sed >hopdm.src/gettim.f <<'//GO.SYSIN DD hopdm.src/gettim.f' 's/^-//' - SUBROUTINE GETTIM( IHOUR, IMINUT, ISECND, IHSCND) - INTEGER*2 IHOUR, IMINUT, ISECND, IHSCND -C -C GETTIM - Get the Current System Time -C -C*****Purpose: -C Subroutine GETTIM returns the current system time in the -C INTEGER*2 output variables IHOUR, IMINUT and ISECND ( the -C hour, minutes and seconds, respectively ), by calling the -C Lahey Fortran subroutine TIME. The variable IHSCND ( the -C hundred-seconds ) is set to zero. -C -C*****Subprograms called: -C Fortran-supplied - ICHAR, TIME. - INTRINSIC ICHAR -C*****History: -C Written by Krzysztof C. Kiwiel, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, 01-447 Warsaw. -C Date last modified: January 14, 1987. -C -C*****Body of subroutine GETTIM: - CHARACTER*8 TIM -C TIME sets TIM='HH:MM:SS'. - CALL TIME( TIM) -C In ASCII 48=ICHAR('0'). - IHOUR =10*(ICHAR( TIM(1:1))-48)+ICHAR( TIM(2:2))-48 - IMINUT=10*(ICHAR( TIM(4:4))-48)+ICHAR( TIM(5:5))-48 - ISECND=10*(ICHAR( TIM(7:7))-48)+ICHAR( TIM(8:8))-48 - IHSCND=0 - RETURN -C*****Last card of subroutine GETTIM********************************** - END //GO.SYSIN DD hopdm.src/gettim.f echo hopdm.src/hmain2.f 1>&2 sed >hopdm.src/hmain2.f <<'//GO.SYSIN DD hopdm.src/hmain2.f' 's/^-//' -C************************************************************* -C *** This is the main program of the HOPDM library *** -C *** Version 2.11 of April 6, 1995 *** -C************************************************************* -C -C PROGRAM HMAIN2 -C -C -C *** PURPOSE -C This is the main program of the HOPDM library. -C -C HOPDM is an implementation of a Higher Order -C Primal-Dual logarithmic barrier Method. -C -C -C -C -C *** GLOBAL PARAMETERS - INTEGER*4 IOERR,IOSPC,INMPS,OUTMPS - PARAMETER (IOERR=11,INMPS=12,IOSPC=13,OUTMPS=14) -C - INTEGER*4 LIWORK,LRWORK,LIMAP,LRMAP - INTEGER*4 LMAX,MDIM,NDIM,NZDIM,MAXM,MAXN,MAXNZA,MAXNZL,MXHIST -C -C -C for UNIX (32MB) computers: -C --------------------------- - PARAMETER (LIWORK=700000,LRWORK=400000,LIMAP=10,LRMAP=10) - PARAMETER (LMAX=2,MDIM=30000,NDIM=32600,NZDIM=200000) - PARAMETER (MAXNZL=2320000,MXHIST=MDIM+2*NDIM) -C -C -C -C *** GLOBAL PARAMETERS DESCRIPTION -C LIWORK Dimension of the integer work array IWORK. -C LRWORK Dimension of the real work array RWORK. -C LIMAP Dimension of the map of the integer work array, IMAP. -C LRMAP Dimension of the map of the real work array, RMAP. -C LMAX Maximum order of polynomial used in the method. -C MDIM Maximum number of constraints (see also MAXM). -C NDIM Maximum number of variables (see also MAXN). -C NZDIM Maximum number of non-zeros in the LP constraint matrix -C (see also MAXNZA). -C MAXNZL Maximum number of non-zeros in the Cholesky factor. -C MXHIST Maximum number of entries in the PRE_SOLVE history list. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C IOMPS Input/output unit number where the input MPS file -C is to be read from. -C IOSPC Input/output unit number where the problem -C specifications are to be read from. -C OUTMPS Input/output unit number where the solution MPS file -C is to be written. -C -C -C -C *** VARIABLES AND ARRAYS ASSOCIATED WITH THE MPS FILE - CHARACTER*13 FILMPS,FILSPC,FILERR,FILSOL - CHARACTER*9 NAMEC,NAMEB,NAMBND,NAMRAN,NAMMPS - CHARACTER*8 RWNAME(MDIM),CLNAME(NDIM) - LOGICAL VUSED(NDIM),VBNDED(NDIM) - INTEGER*2 STAVAR(NDIM),STAROW(MDIM),RWSTAT(MDIM) - DOUBLE PRECISION RANGES(MDIM),UPBND(NDIM),LOBND(NDIM) - DOUBLE PRECISION BIG,DLOBND,DUPBND -C -C *** MPS VARIABLES DESCRIPTION -C FILSPC Specifications file name. -C FILMPS MPS input file name. -C FILERR Error file name. -C FILSOL Solution file name. -C NAMEC The name of the desired objective function. -C NAMEB The name of the right hand side section chosen. -C NAMBND The name of the bound section chosen. -C NAMRAN The name of the range section chosen. -C NAMMPS The problem name. -C RWNAME Array of row names. -C RWSTAT Array of row types: -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 objective row; -C 5 other free row. -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C CLNAME Array of column names. -C VUSED An indicator if a variable is active in the optimization -C process: -C .TRUE. active variable; -C .FALSE. FIXED variable. -C VBNDED An indicator if a variable has an UPPER bound: -C .TRUE. UPPER bounded variable; -C .FALSE. UNBOUNDED variable; -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C 7 (or larger) PRESUMED OPTIMAL variable i.e.: x = x0; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C RANGES Array of constraint ranges. -C UPBND Array of upper bounds. Note that the upper bound -C is changed when the variable has a lower bound. -C LOBND Array of lower bounds. -C -C -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(LIWORK),IMAP(LIMAP),RMAP(LRMAP) - DOUBLE PRECISION RWORK(LRWORK) -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real work array containing almost all real -C LP problem data. -C IWORK Integer work array containing almost all integer -C LP problem data. -C RMAP Map of RWORK. -C IMAP Map of IWORK. -C -C Map of IWORK array: -C IMAP(1) Points to CLPNTS array. -C IMAP(2) Points to RWNMBS array. -C IMAP(3) Points to RWHEAD array. -C IMAP(4) Points to RWLINK array. -C IMAP(5) Points to CLNMBS array. -C IMAP(6) Points to LENCOL array. -C IMAP(7) Points to the first empty cell of IWORK array. -C -C Map of RWORK array: -C RMAP(1) Points to ACOEFF array. -C RMAP(2) Points to C array. -C RMAP(3) Points to RHS array. -C RMAP(4) Points to the first empty cell of RWORK array. -C -C -C -C *** WORK ARRAYS - INTEGER*4 INTMP1(NDIM),IROW(NDIM) - INTEGER*2 INTMP2(NDIM),INTMP3(NDIM) - INTEGER*4 IMTMP1(MDIM+1),IMTMP2(MDIM+1) - DOUBLE PRECISION X(NDIM),S(NDIM) - DOUBLE PRECISION Y(MDIM),Z(NDIM),W(NDIM),YPROX(MDIM) - DOUBLE PRECISION DELTAX(NDIM,LMAX),DELTAS(NDIM,LMAX) - DOUBLE PRECISION DELTAY(MDIM,LMAX),RSCALE(MDIM),CSCALE(NDIM) - DOUBLE PRECISION DELTAZ(NDIM,LMAX),DELTAW(NDIM,LMAX),RELT(NDIM) - DOUBLE PRECISION THETA(NDIM),XIB(MDIM),XIC(NDIM),XIU(NDIM) - DOUBLE PRECISION P(MDIM),Q(MDIM),OSCALE - DOUBLE PRECISION RMTMP1(MDIM),RMTMP2(MDIM) - DOUBLE PRECISION RMTMP3(MDIM),RMTMP4(MDIM) - DOUBLE PRECISION RNTMP1(NDIM),RNTMP2(NDIM),RNTMP3(NDIM) - DOUBLE PRECISION RNTMP4(NDIM),RNTMP5(NDIM),RNTMP6(NDIM) - DOUBLE PRECISION COLNRM(NDIM) -C -C *** VARIABLES FOR GENQMD and GENMMD ROUTINES - INTEGER*4 DHEAD(MDIM),PERM0(MDIM),INVP0(MDIM) - INTEGER*4 NBRHD(MDIM),QSIZE(MDIM),QLINK(MDIM) -C -C *** The following arrays can be half-length integer. - INTEGER*2 PERM(MDIM),INVP(MDIM) - INTEGER*2 HEADER(MDIM+1),LINKFD(MDIM+1),LINKBK(MDIM+1) -C -C *** WORK ARRAYS DESCRIPTION -C INTMP1 Integer work array of size MAXN. -C INTMP2 Half-length integer work array of size MAXN. -C INTMP3 Half-length integer work array of size MAXN. -C IMTMP1 Integer work array of size MAXM. -C IMTMP2 Integer work array of size MAXM. -C IROW and RELT are the arrays for temporary handling of rows -C and columns of the constraint matrix. They are primarily -C intended to handle sparse vectors (in packed form) -C but may also be used for storing dense ones. -C RMTMP1 Double precision work array of size MAXM. -C RMTMP2 Double precision work array of size MAXM. -C RMTMP3 Double precision work array of size MAXM. -C RMTMP4 Double precision work array of size MAXM. -C RNTMP1 Double precision work array of size MAXN. -C RNTMP2 Double precision work array of size MAXN. -C RNTMP3 Double precision work array of size MAXN. -C RNTMP4 Double precision work array of size MAXN. -C RNTMP5 Double precision work array of size MAXN. -C RNTMP6 Double precision work array of size MAXN. -C -C X Primal variables of the linear program. -C S Primal slack variables of the linear program. -C Y Dual variables of the linear program. -C Z Dual slack variables of the linear program (var. Z). -C W Dual slack variables of the linear program (var. W). -C DELTAX(*,L) L-th component of deltaX. -C DELTAS(*,L) L-th component of deltaS. -C DELTAY(*,L) L-th component of deltaY. -C DELTAZ(*,L) L-th component of deltaZ. -C DELTAW(*,L) L-th component of deltaW. -C YPROX Dual proximal point. -C -C XIB Violation of primal constraints, i.e. b - A * x -C XIC Violation of dual constraints, i.e. c - At*y - z + w -C XIU Violation of variable bounds, i.e. UPBND - x - s -C RSCALE Row scaling factors. -C CSCALE Column scaling factors. -C OSCALE Objective row scaling factor. -C THETA Diagonal weight matrix. -C P LOWER bounds on shadow prices (dual variables). -C Q UPPER bounds on shadow prices (dual variables). -C -C PERM Permutation resulting from the minimum degree ordering. -C INVP Inverse permutation. -C HEADER Header of the doubly linked lists. -C LINKFD Forward linked lists. -C LINKBK Backward linked lists. -C -C TCODE Termination code: -C 0 OPTIMAL solution found; -C 1 Primal INFEASIBLE (or dual UNBOUNDED); -C 2 Primal UNBOUNDED (or dual INFEASIBLE); -C 3 Fatal accuracy problem; -C 4 Excess iterations/time limit. -C -C -C -C *** PRESOLVE HISTORY - INTEGER*4 LNHIST - INTEGER*2 INHIST(MXHIST) - DOUBLE PRECISION DPHIST(MXHIST) -C -C LNHIST Length of the PRE_SOLVE history list. -C MXHIST Maximum number of entries in the PRE_SOLVE history list. -C INHIST Integer PRE_SOLVE history information. -C DPHIST Double precision PRE_SOLVE history information. -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 IROBJ,M,MFINAL,N,NSTRCT,NZA,MAXCOL,MSGLEV,LEVPRS,NZL - INTEGER*4 I,J,ICALL,K,TCODE,LORD,IWRITE - CHARACTER*100 BUFFER - DOUBLE PRECISION MULT -C -C -C -C *** DATA STRUCTURES FOR CHOLESKY FACTOR - DOUBLE PRECISION LCOEFF(MAXNZL) - DOUBLE PRECISION LDIAG(MDIM),LDSQRT(MDIM) - INTEGER*4 LCLPTS(MDIM+1),LLINKS(MAXNZL) - INTEGER*2 LRWNBS(MAXNZL) - EQUIVALENCE (LCOEFF(1),LLINKS(1)) -C -C LCOEFF Off-diagonal nonzero coefficients of Cholesky matrix. -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C LLINKS Linked lists for Cholesky factor. -C LDIAG Diagonal elements of Cholesky factor. -C LDSQRT Square roots of the diagonal elements of Cholesky factor. -C -C -C -C *** COMMON ARREAS -C Cholesky factorization parameters. - COMMON /CHFCT/ CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN,IDNSRW - DOUBLE PRECISION CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN - INTEGER*4 IDNSRW -C -C Additional Cholesky fact. parameters (interface to HYBRID). - COMMON /CHHYB/ RO,FLOPS,IREG,NZCHL,RTCD - DOUBLE PRECISION RO,FLOPS - INTEGER*4 IREG,NZCHL,RTCD -C -C An indicator if the elimination routine has been used. - COMMON /ELMNTE/ IELIM - INTEGER*4 IELIM -C -C An indicator if a stronger barrier is to be used. - COMMON /LBARR/ IBARR - INTEGER*4 IBARR -C -C -C -C For DOS, the integer array IDATIM is used by subroutine TIMEPF -C to store the current date, time and elapsed time. -C For UNIX, the real scalar ELTIME is used by subroutine DATTIM -C to store the elapsed time. -C -C Only for DOS - COMMON/IDTM/ IDATIM - INTEGER*4 IDATIM(9) -C -C Only for UNIX - COMMON /TIME/ ELTIME - REAL ELTIME(3) -C -C -C *** COMMON ARREAS -C Markers for linking rows. - COMMON /ICGRAD/ MSPLIT(100000) - INTEGER*2 MSPLIT -C -C -C -C *** SUBROUTINES CALLED -C MYWRT,RDSPEC,SETMAP,RDMPS1,RDMPS2,PCPDM, -C PRESOL,PREPRO,SCALEA,SCLCOL,SCLROW,POSTSL,WRTSOL -C -C -C *** NOTES -C -C -C -C *** REFERENCES: -C Altman A., Gondzio J. (1993). An efficient implementation of -C a higher order primal-dual interior point method for large -C sparse linear programs, Archives of Control Sciences 2, -C No 1-2, pp. 23-40. -C Altman A., Gondzio J. (1993). HOPDM - A higher order primal- -C dual method for large scale linear programmming, European -C Journal of Operational Research 66 (1993) pp 158-160. -C Gondzio J. (1992). Splitting dense columns of the constraint -C matrix in interior point methods for large scale linear -C programming, Optimization 24, pp. 285-297. -C Gondzio J. (1993). Implementing Cholesky factorization for -C interior point methods of linear programming, Optimization -C 27, pp. 121-140. -C Gondzio J. (1994). Presolve analysis of linear programs prior -C to applying an interior point method, Technical Report -C No 1994.3, Department of Management Studies, University -C of Geneva, 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, -C February 1994, revised in December 1994. -C Gondzio J. (1994). Multiple centrality corrections in a primal- -C dual method for linear programming, Technical Report -C No 1994.20, Department of Management Studies, University -C of Geneva, 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, -C November 1994. -C Gondzio J., Makowski M. (1995). Solving a class of LP problems -C with a primal-dual logarithmic barrier method, European -C Journal of Operational Research 80, pp. 184-192. -C Gondzio J., Tachat D. (1994). The design and application of -C IPMLO - a FORTRAN library for linear optimization with -C interior point methods, RAIRO Recherche Operationnelle 28, -C No 1, pp. 37-56. -C -C -C -C *** HISTORY: -C The first version of this routine (called HOMAIN) was -C written by: Anna Altman & Jacek Gondzio, -C Systems Research Institute, -C Polish Academy of Sciences, -C Newelska 6, 01-447 Warsaw, Poland. -C Date written: May 18, 1992 -C -C This is a second release of it (called HMAIN2), -C written by: Jacek Gondzio, -C Systems Research Institute, -C Polish Academy of Sciences, -C Newelska 6, 01-447 Warsaw, Poland. -C Date written: November 18, 1993 -C Last modified: April 6, 1995 -C -C -C -C -C -C -C *** BODY OF (HMAIN2) *** -C -C -C -C Print the author's names at the console. - WRITE(BUFFER,51) - 51 FORMAT(1X) - CALL MYWRT(0,BUFFER) - CALL MYWRT(0,BUFFER) - CALL MYWRT(0,BUFFER) - CALL MYWRT(0,BUFFER) - WRITE(BUFFER,52) - 52 FORMAT(2X,' HOPDM - Higher Order Primal-Dual Method, ver 2.11') - CALL MYWRT(0,BUFFER) - WRITE(BUFFER,53) - 53 FORMAT(2X,'--------------------------------------------------') - CALL MYWRT(0,BUFFER) - WRITE(BUFFER,51) - CALL MYWRT(0,BUFFER) - CALL MYWRT(0,BUFFER) - CALL MYWRT(0,BUFFER) - WRITE(BUFFER,54) - 54 FORMAT(2X,'Written by: Jacek Gondzio,') - CALL MYWRT(0,BUFFER) - WRITE(BUFFER,55) - 55 FORMAT(17X,'Systems Research Institute,') - CALL MYWRT(0,BUFFER) - WRITE(BUFFER,56) - 56 FORMAT(17X,'Polish Academy of Sciences,') - CALL MYWRT(0,BUFFER) - WRITE(BUFFER,57) - 57 FORMAT(17X,'Newelska 6, 01-447 Warsaw, Poland') - CALL MYWRT(0,BUFFER) - WRITE(BUFFER,51) - CALL MYWRT(0,BUFFER) - WRITE(BUFFER,58) - 58 FORMAT(2X,'Last modified: April 6, 1995') - CALL MYWRT(0,BUFFER) - WRITE(BUFFER,51) - CALL MYWRT(0,BUFFER) - CALL MYWRT(0,BUFFER) - CALL MYWRT(0,BUFFER) - CALL MYWRT(0,BUFFER) -C -C -C -C Set the maximum order of Taylor polynomial. - LORD=2 -C -C Set an indicator if the elimination routine has been used. - IELIM=0 -C -C Set an indicator of how small pivots are to be handled. - IREG=-1 -C -C Set an indicator if a stronger barrier is to be used. - IBARR=0 -C -C Set the level of printing pre_solve report desired. - MSGLEV=0 -C -C Set the level of pre_solve analysis desired. - LEVPRS=2 -C -C -C -C Read the problem specifications. -C - CALL RDSPEC(FILMPS,FILSPC,FILERR,FILSOL, - X MDIM,NDIM,NZDIM,MAXM,MAXN,MAXNZA, - X NAMEC,NAMEB,NAMBND,NAMRAN, - X MULT,BIG,DLOBND,DUPBND, - X IOERR,IOSPC,INMPS,OUTMPS) -C -C Open the output files. - OPEN(IOERR,FILE=FILERR,ACCESS='SEQUENTIAL') - OPEN(99,FILE='fort.99',ACCESS='SEQUENTIAL') -C -C -C -C Set up the maps of the hidden problem data. -C - CALL SETMAP(MAXM,MAXN,MAXNZA, - X IMAP,RMAP,LIWORK,LRWORK,IOERR) -C -C Print the current date, time and elapsed time. - WRITE(BUFFER,101) - 101 FORMAT(1X) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,102) - 102 FORMAT(1X,'HOMAIN: Reading the MPS file.') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C - CALL MYTIME(0,IOERR) - CALL MYTIME(0,0) -C -C -C -C Read the MPS input file. -C - CALL RDMPS1(MAXM,MAXN,MAXNZA, - X M,N,NZA,IROBJ,INMPS,IOERR, - X BIG,DLOBND,DUPBND, - X NAMEC,NAMEB,NAMRAN,NAMBND,NAMMPS,FILMPS, - X RWNAME,CLNAME,STAVAR,RWSTAT, - X HEADER,LINKFD,INTMP2,INTMP3, - X IWORK(IMAP(2)),IWORK(IMAP(1)),IROW, - X RWORK(RMAP(1)),RWORK(RMAP(3)),RANGES, - X UPBND,LOBND,RELT) -C - CALL RDMPS2(RWORK(RMAP(2)),RWORK(RMAP(3)),RANGES, - X IWORK(IMAP(1)),IWORK(IMAP(2)),RWORK(RMAP(1)), - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)), - X MAXM,MAXN,MAXNZA,M,N,NZA,NSTRCT,MULT, - X INTMP1(1),IMTMP1,IMTMP2, - X STAVAR,UPBND,LOBND,BIG,IROBJ, - X NAMMPS,RWNAME,RWSTAT,STAROW,CLNAME, - X RWORK,IWORK,RMAP,IMAP,IROW,RELT, - X X,IOERR) -C -C Print the current date, time and elapsed time. - WRITE(BUFFER,103) - 103 FORMAT(1X,'HOMAIN: Reading completed.') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C - CALL MYTIME(1,IOERR) - CALL MYTIME(1,0) -C -C -C -C Print the current date, time and elapsed time. - WRITE(BUFFER,201) - 201 FORMAT(1X) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,202) - 202 FORMAT(1X,'HOMAIN: Presolve analysis.') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C - CALL MYTIME(0,IOERR) - CALL MYTIME(0,0) -C -C Initialize bounds on shadow prices. - DO 200 I=1,M - P(I)=-BIG - Q(I)=BIG - 200 CONTINUE -C -C -C -C Go perform the PRE_SOLVE analysis. -C MAXCOL is the threshold length for columns to be split. -C LNHIST is the lenght of the PRE_solve history list. -C - MAXCOL=100 - LNHIST=0 - CALL PRESOL(MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X X,RWORK(RMAP(3)),RWORK(RMAP(2)),CLNAME,UPBND,LOBND, - X INTMP1,INTMP2,INTMP3,IMTMP1,IMTMP2, - X RMTMP1,P,Q,RNTMP1,RNTMP2,RNTMP3, - X PERM,INVP,HEADER,LINKFD,LINKBK, - X STAVAR,RWNAME,STAROW,RWSTAT,RANGES, - X MAXCOL,MSGLEV,LEVPRS,IOERR) -C -C Print the current date, time and elapsed time. - WRITE(BUFFER,203) - 203 FORMAT(1X,'HOMAIN: Analysis completed.') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C - CALL MYTIME(1,IOERR) - CALL MYTIME(1,99) - CALL MYTIME(1,0) -C -C -C -C Check if the PRE_SOLVE analysis has solved the problem. - IF(M.EQ.0) THEN - WRITE(BUFFER,211) - 211 FORMAT(1X) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,212) - 212 FORMAT(1X,'HOMAIN: Problem solved by a PRE_SOLVE analysis!') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,213) - 213 FORMAT(1X,'HOMAIN: Optimal solution found after 0', - X ' iterations.') - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) - WRITE(BUFFER,214) - 214 FORMAT(1X) - CALL MYWRT(0,BUFFER) - GO TO 600 - ENDIF -C -C -C -C Print the current date, time and elapsed time. - WRITE(BUFFER,301) - 301 FORMAT(1X) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,302) - 302 FORMAT(1X,'HOMAIN: Preprocessing for Cholesky factorization.') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C - CALL MYTIME(1,IOERR) - CALL MYTIME(1,0) -C -C -C -C Go preprocess the LP constraint matrix (reorder it according -C to the permutation resulting from the mininmum degree heuristic -C and perform the symbolic Cholesky factorization to set up data -C structures for triangular factor L). -C -C Define VUSED and VBNDED logical arrays. - DO 320 J=1,N - K=STAVAR(J) - VUSED(J)=.TRUE. - VBNDED(J)=.FALSE. - IF(K.EQ.1.OR.K.EQ.3) VBNDED(J)=.TRUE. - IF(K.GE.6) VUSED(J)=.FALSE. - 320 CONTINUE -C - ICALL=0 - CALL PREPRO(MAXM,MAXN,MAXNZA,MAXNZL,M,N, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X INTMP1,IMTMP1,IMTMP2,RMTMP1, - X DHEAD,PERM0,INVP0,NBRHD,QSIZE,QLINK, - X PERM,INVP,HEADER,LINKFD,LINKBK, - X LCLPTS,LRWNBS,LLINKS, - X STAVAR,P,Q,RWNAME,STAROW,RWSTAT,RANGES, - X NZL,ICALL,IOERR) -C -C Print the current date, time and elapsed time. - WRITE(BUFFER,303) - 303 FORMAT(1X,'HOMAIN: Preprocessing completed.') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C - CALL MYTIME(1,IOERR) - CALL MYTIME(1,99) - CALL MYTIME(1,0) -C -C -C -C -C Scale the LP constraint matrix. -C - WRITE(BUFFER,401) - 401 FORMAT(1X) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,402) - 402 FORMAT(1X,'HOMAIN: Scaling the linear program.') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C -C Initialize scaling factors. - DO 420 J=1,N - CSCALE(J)=1.0D0 - RNTMP1(J)=1.0D0 - 420 CONTINUE - DO 440 I=1,M - RSCALE(I)=1.0D0 - 440 CONTINUE - OSCALE=1.0D0 -C - CALL SCALEA(IOERR, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X RMTMP1,RMTMP2,RNTMP1,RNTMP2, - X RWORK(RMAP(3)),RANGES,RWORK(RMAP(2)),UPBND,CSCALE,RSCALE,OSCALE, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)), - X IWORK(IMAP(6)),STAVAR) -C - WRITE(BUFFER,441) - 441 FORMAT(1X,'HOMAIN: Scaling done.') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C -C *** DEBUGGING -C WRITE(IOERR,461) -C 461 FORMAT(1X/1X,'HMAIN2: LP rows before solution:') -C DO 463 I=1,M -C WRITE(BUFFER,462) I,RWNAME(I),RWSTAT(I), -C X P(I),Y(I),Q(I) -C 462 FORMAT(1X,'rw=',I4,', ',A8,' st=',I2, -C X ' Pi=',D14.8,' Yi=',D14.8,' Qi=',D14.8) -C CALL MYWRT(IOERR,BUFFER) -C 463 CONTINUE -C -C Scale the bounds on shadow prices. - DO 460 I=1,M - P(I)=P(I)*RSCALE(I) - Q(I)=Q(I)*RSCALE(I) - 460 CONTINUE -C -C Save the infinity norms of all columns. - DO 480 J=1,N - COLNRM(J)=RNTMP1(J) - 480 CONTINUE -C -C -C -C Print the current date, time and elapsed time. - WRITE(BUFFER,501) - 501 FORMAT(1X) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,502) - 502 FORMAT(1X,'HOMAIN: Solution of the LP problem starts.') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C - CALL MYTIME(1,IOERR) - CALL MYTIME(1,0) -C -C -C -C Go solve the LP problem. -C - CALL PCPDM(TCODE,LORD,MAXM,MAXN,MAXNZA,MAXNZL, - X M,MFINAL,N,NSTRCT,NZA, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X INTMP1,INTMP2,INTMP3,IMTMP1,IMTMP2, - X RMTMP1,RMTMP2,RMTMP3,RNTMP1,RNTMP2,RNTMP3, - X PERM,INVP,HEADER,LINKFD,LINKBK, - X VUSED,VBNDED,RWORK(RMAP(2)),UPBND,RWORK(RMAP(3)),RANGES, - X THETA,XIB,XIC,XIU,RMTMP4,RNTMP4,RNTMP5,RNTMP6, - X COLNRM,X,S,Y,Z,W, - X DELTAX,DELTAS,DELTAY,DELTAZ,DELTAW,YPROX, - X LCOEFF,LDIAG,LDSQRT,LCLPTS,LRWNBS,LLINKS, - X RSCALE,CSCALE,STAVAR,P,Q,STAROW,RWSTAT,RWNAME,IOERR) -C -C Print the current date, time and elapsed time. - WRITE(BUFFER,503) - 503 FORMAT(1X) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,504) TCODE - 504 FORMAT(1X,'HOMAIN: Exit HOPDM, termination code =',I3) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) -C - CALL MYTIME(1,IOERR) - CALL MYTIME(1,99) - CALL MYTIME(1,0) -C -C -C -C Unscale the LP constraint matrix. - DO 520 J=1,N - X(J)=X(J)/CSCALE(J) - S(J)=S(J)/CSCALE(J) - Z(J)=Z(J)*CSCALE(J) - W(J)=W(J)*CSCALE(J) - CSCALE(J)=1.0D0/CSCALE(J) - 520 CONTINUE - OSCALE=1.0D0/OSCALE - CALL SCLCOL(MAXN,MAXNZA,N, - X IWORK(IMAP(1)),IWORK(IMAP(6)),RWORK(RMAP(1)), - X CSCALE,OSCALE,RWORK(RMAP(2)),UPBND,IOERR) -C - DO 540 I=1,M - Y(I)=Y(I)/(RSCALE(I)*OSCALE) - P(I)=P(I)/(RSCALE(I)*OSCALE) - Q(I)=Q(I)/(RSCALE(I)*OSCALE) - XIB(I)=XIB(I)*(RSCALE(I)*OSCALE) - RSCALE(I)=1.0D0/RSCALE(I) - 540 CONTINUE - CALL SCLROW(MAXM,MAXNZA,M,NSTRCT, - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),RWORK(RMAP(1)), - X RSCALE,RANGES,RWORK(RMAP(3)),IOERR) -C - 600 CONTINUE -C -C -C -C *** DEBUGGING -C WRITE(IOERR,601) MFINAL,M -C 601 FORMAT(1X/1X,'after solution, Mfinal=',I6,' M=',I6) -C DO 605 I=1,MFINAL -C IF(Y(I).LE.P(I)-1.D-6.OR.Y(I).GE.Q(I)+1.D-6) THEN -C WRITE(BUFFER,602) I,RWNAME(I),RWSTAT(I), -C X P(I),Y(I),Q(I) -C 602 FORMAT(1X,'rw=',I4,', ',A8,' st=',I2, -C X ' Pi=',D14.8,' Yi=',D14.8,' Qi=',D14.8) -C CALL MYWRT(IOERR,BUFFER) -C IF(Y(I).LE.P(I)-1.D-6.OR.Y(I).GE.Q(I)+1.D-6) THEN -C WRITE(BUFFER,603) I -C 603 FORMAT(1X,'Yi in row=',I6,' is out of bounds.') -C CALL MYWRT(IOERR,BUFFER) -C ENDIF -C ENDIF -C 605 CONTINUE -C -C -C -C Go postprocess the LP constraint matrix. -C - CALL POSTSL(IOERR,MSGLEV, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X RWORK,IWORK,RMAP,IMAP,IROW,RELT, - X IMTMP1,INTMP1,INTMP2,RNTMP1, - X RWORK(RMAP(3)),RANGES,RWORK(RMAP(2)),LOBND,UPBND, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)), - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)), - X X,STAVAR,RWSTAT,STAROW,RWNAME,CLNAME) -C -C -C -C Write the solution. -C Standard MPS output file can be created only if the option -C of rows and columns elimination is disabled. If this option -C is used, complete output is not available. -C -C Open the MPS output file. - OPEN(OUTMPS,FILE=FILSOL,ACCESS='SEQUENTIAL') - IWRITE=1 -C - CALL WRTSOL(M,MFINAL,N,NSTRCT,MAXM,MAXN, - X STAVAR,RWSTAT,STAROW,RWNAME,CLNAME,NAMMPS,MULT, - X LOBND,UPBND,RWORK(RMAP(3)),RWORK(RMAP(2)),X,Y, - X RWORK,IWORK,RMAP,IMAP,IROW,RELT, - X RMTMP1,RMTMP2,IWRITE,OUTMPS,IOERR) -C -C -C -C -C Close the files. - CLOSE(IOERR) - CLOSE(99) - CLOSE(OUTMPS) -C - STOP -C -C -C *** LAST CARD OF (HMAIN2) *** - END //GO.SYSIN DD hopdm.src/hmain2.f echo hopdm.src/mdo.f 1>&2 sed >hopdm.src/mdo.f <<'//GO.SYSIN DD hopdm.src/mdo.f' 's/^-//' -C********************************************************** -C **** MDO ... MINIMUM DEGREE ORDERING **** -C********************************************************** -C - SUBROUTINE MDO(AATPAT,AATPNT,CLIQS,MAXNZL,MAXM,M,NZL, - X PERM,INVP,DGHEAD,LINKFD,LINKBK, - X RWLIST,LSTCLQ,MARKER,TEMP,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXNZL,MAXM,M,NZL,IOERR - INTEGER*4 AATPNT(MAXM+1),CLIQS(MAXNZL) - INTEGER*4 LSTCLQ(MAXM),MARKER(MAXM),TEMP(MAXM),RWLIST(MAXM) -C -C *** The following arrays can be half-length integer. - INTEGER*2 DGHEAD(MAXM),LINKFD(MAXM),LINKBK(MAXM) - INTEGER*2 AATPAT(MAXNZL),PERM(MAXM),INVP(MAXM) -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,IROW,IR,BESTRW,ELROWS,K,KX,KBEG,KEND,NEXT,PREVS - INTEGER*4 MINDEG,DEGREE,OLDDEG,NEWDEG,DISCRD,MASSEL - INTEGER*4 NACTCL,PCLQHD,ICLIQ,IBEG,IEND,LENOFL - DOUBLE PRECISION A1,A2,FLOPS - CHARACTER*100 BUFFER -C -C -C *** COMMON ARREAS -C Markers for linking rows. - COMMON /ICGRAD/ MSPLIT(100000) - INTEGER*2 MSPLIT -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C AATPAT Sparsity pattern of A*Atransp handled as -C a collection of sparse row vectors (diagonal -C elements are excluded from the list). -C AATPNT Pointers to rows of A*Atransp. -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C MAXM Maximum row dimension of the matrix to be decomposed. -C M Dimension of the matrix to be decomposed. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C NZL Number of nonzero entries in Cholesky factor. -C PERM Permutation resulting from the minimum degree ordering. -C INVP Inverse permutation. -C -C WORK ARRAYS: -C CLIQS Cliques of the pivotal rows (linked lists). -C DGHEAD Headers of the forward linked lists of rows (nodes) -C with the same degree. -C LINKFD Forward linked lists of rows with the same degree. -C LINKBK Backward linked lists of rows with the same degree. -C LSTCLQ A list of headers to different pivotal cliques -C that are still active i.e. that have not yet been -C merged with any pivotal row. -C RWLIST A list of nonzero positions of a row that is -C involved in a current step of elimination. -C MARKER Array used to mark already reordered rows. -C TEMP Temporary array used for merging lists. -C -C -C *** SUBROUTINES CALLED: -C MYWRT -C -C -C *** PURPOSE: -C This routine implements the minnimum degree ordering -C for a symmetric positive definite matrix. -C -C -C *** NOTES: -C 1. This routine follows Duff et al. (1989) description -C of the minimum degree ordering. -C 2. This routine assumes that the matrix A*Atransp is -C positive definite, i.e., that pivoting in the numerical -C phase will not be required. -C 3. The cliques discarding mechanism has been implemented. -C 4. Mass elimination technique has been implemented. -C -C -C *** REFERENCES: -C Duff I.S., Erisman A.M., Reid J.K. (1989). Direct methods -C for sparse matrices, Clarendon Press, Oxford 1989, -C chapter 10. -C Gondzio J. (1993). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization 27, pp. 121-140. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: May 8, 1991 -C Last modified: March 28, 1995 -C -C -C -C *** BODY OF (MDO) *** -C -C -C Initialize for the minimum degree ordering. -C Zero work arrays. - DO 20 IROW=1,M - DGHEAD(IROW)=0 - MARKER(IROW)=0 - TEMP(IROW)=0 - 20 CONTINUE -C -C Set the degree doubly linked lists (recall that diagonal -C elements are not stored in the sparsity pattern). - DO 40 IROW=1,M - DEGREE=AATPNT(IROW+1)-AATPNT(IROW)+1 - IF(MSPLIT(IROW).EQ.1) DEGREE=M - NEXT=DGHEAD(DEGREE) - LINKFD(IROW)=NEXT - DGHEAD(DEGREE)=IROW - IF(NEXT.GT.0) LINKBK(NEXT)=IROW - LINKBK(IROW)=-DEGREE - 40 CONTINUE -C -C -C *** DEBUGGING -C DO 42 IROW=1,M -C WRITE(BUFFER,41) IROW,DGHEAD(IROW),LINKFD(IROW),LINKBK(IROW) -C 41 FORMAT(1X,'MDO: row',I6,' hd=',I6,' fd=',I6,' bk=',I6) -C CALL MYWRT(IOERR,BUFFER) -C 42 CONTINUE -C -C Set the parameters controlling the progress -C of the minimum degree ordering. -C NACTCL is the number of the active pivotal cliques -C that have not yet been merged. -C ELROWS is the number of already eliminated rows + 1. -C MINDEG is a current minimum degree found. -C LENOFL is a current length of the Cholesky factor. -C FLOPS is a cost of the numerical phase of the factorization. - NACTCL=0 - ELROWS=1 - MINDEG=1 - LENOFL=0 - FLOPS=0.0D0 -C -C -C -C Eliminate all single-element rows (isolated nodes). -C This elimination does not involve any modification -C of the degree doubly linked lists. - IROW=DGHEAD(1) - 100 IF(IROW.EQ.0) GO TO 120 -C WRITE(BUFFER,101) IROW -C 101 FORMAT(1X,'MDO: row',I6,' has degree 1') -C CALL MYWRT(IOERR,BUFFER) -C -C Eliminate row IROW (save its position in a permuted matrix). - INVP(IROW)=ELROWS - MARKER(IROW)=1 - ELROWS=ELROWS+1 - IROW=LINKFD(IROW) - GO TO 100 -C -C Here if all single-element rows have been eliminated. - 120 DGHEAD(1)=0 -C -C -C -C -C -C Main loop begins here. -C Eliminating rows (nodes) of minimum degree. - 200 IF(ELROWS.GT.M) GO TO 2100 -C -C Look for the row of the minimum degree. - 220 IROW=DGHEAD(MINDEG) - IF(IROW.GT.0) GO TO 240 - MINDEG=MINDEG+1 - GO TO 220 -C -C -C The row of minimum degree has been found. - 240 DEGREE=MINDEG - BESTRW=IROW - MARKER(BESTRW)=1 - TEMP(BESTRW)=1 -C -C -C *** DEBUGGING -C WRITE(BUFFER,241) IROW,MINDEG -C 241 FORMAT(1X,'MDO: row',I6,' has minimum degree',I6) -C CALL MYWRT(IOERR,BUFFER) -C -C Remove row BESTRW from the linked list of rows with degree MINDEG. - NEXT=LINKFD(BESTRW) - IF(NEXT.GT.0) LINKBK(NEXT)=-MINDEG - DGHEAD(MINDEG)=NEXT -C -C -C -C Create the current pivotal clique. -C First, move the pivot row to the form of a linked list -C and save its sparsity pattern in TEMP array. -C Pack the pivotal clique to RWLIST array. -C DEGREE is a number of entries of the pivotal clique. -C PCLQHD is a header to the current pivotal clique. - KBEG=AATPNT(BESTRW) - KEND=AATPNT(BESTRW+1)-1 - DEGREE=0 - PCLQHD=0 - DO 300 K=KBEG,KEND - IR=AATPAT(K) - IF(MARKER(IR).EQ.1) GO TO 300 - DEGREE=DEGREE+1 - TEMP(IR)=-DEGREE - RWLIST(DEGREE)=IR - CLIQS(K)=PCLQHD - PCLQHD=K - 300 CONTINUE -C -C Scan all the previously determined pivotal cliques -C if they involve the pivot. If so, then merge the clique -C with the current one (and update TEMP array). -C ICLIQ indicates the clique that is being analysed. -C IBEG indicates the first clique to be analysed. -C IEND indicates the last clique to be analysed. - IBEG=1 - 320 IEND=NACTCL - IF(IBEG.GT.IEND) GO TO 480 - DO 400 ICLIQ=IBEG,IEND - K=LSTCLQ(ICLIQ) - 360 IF(K.EQ.0) GO TO 400 - IR=AATPAT(K) - IF(IR.EQ.BESTRW) GO TO 420 - K=CLIQS(K) - GO TO 360 - 400 CONTINUE -C -C -C Here if neither of pivotal cliques involves the pivot. -C The current pivotal clique is determined. - GO TO 480 -C -C -C Here if a clique that involves the pivot has been found. -C Merge it with a current pivotal clique. -C ICLIQ indicates the clique to be merged. - 420 K=LSTCLQ(ICLIQ) - 440 NEXT=CLIQS(K) - IR=AATPAT(K) - IF(TEMP(IR).NE.0) GO TO 460 -C -C Add the element to the current pivotal clique. - DEGREE=DEGREE+1 - TEMP(IR)=-DEGREE - RWLIST(DEGREE)=IR - CLIQS(K)=PCLQHD - PCLQHD=K - 460 K=NEXT - IF(K.NE.0) GO TO 440 -C -C Remove the merged clique from the list of active ones and -C return to the scanning for other cliques that involve the pivot. - LSTCLQ(ICLIQ)=LSTCLQ(NACTCL) - IBEG=ICLIQ - NACTCL=NACTCL-1 - GO TO 320 -C -C -C -C Here if the current pivotal clique is determined. -C It is handled in the form of a linked list (that starts -C from PCLQHD). The sparsity pattern of this new pivotal -C clique is also stored in TEMP array. Add the clique -C to the list of active ones. - 480 NACTCL=NACTCL+1 - LSTCLQ(NACTCL)=PCLQHD -C -C -C Update LENOFL and FLOPS. - LENOFL=LENOFL+DEGREE - FLOPS=FLOPS+DBLE(DEGREE)*DBLE(DEGREE) -C -C -C *** DEBUGGING -C WRITE(BUFFER,481) BESTRW,ELROWS,DEGREE+1 -C 481 FORMAT(1X,'MDO: row',I6,' becomes ',I6,' degree=',I6) -C CALL MYWRT(IOERR,BUFFER) -C -C -C -C Recalculate the degrees. -C Analyse all rows involved in this pivotal step (included -C into the current pivotal clique) if their degrees change. - K=PCLQHD - 500 IF(K.EQ.0) GO TO 860 - IROW=AATPAT(K) -C -C Do not recalculate degrees of split dense columns (they -C remain always at the last position in the reordering). - IF(MSPLIT(IROW).EQ.1) GO TO 850 -C -C OLDDEG is an old degree of row (node) IROW. -C NEWDEG is a new degree of row (node) IROW. -C Recall that pivot element contributes to a degree. - KX=IROW - 520 KX=LINKBK(KX) - IF(KX.GT.0) GO TO 520 - OLDDEG=-KX - NEWDEG=DEGREE -C -C -C -C Scan all the previously determined pivotal cliques -C if they involve row IROW. If so, then merge the clique -C with the current one (and update TEMP array). -C ICLIQ indicates the clique that is being analysed. -C IBEG indicates the first clique to be analysed. -C IEND indicates the last clique to be analysed. - IBEG=1 - IEND=NACTCL-1 - 540 IF(IBEG.GT.IEND) GO TO 780 - DO 580 ICLIQ=IBEG,IEND - KX=LSTCLQ(ICLIQ) - 560 IF(KX.EQ.0) GO TO 580 - IR=AATPAT(KX) - IF(IR.EQ.IROW) GO TO 600 - KX=CLIQS(KX) - GO TO 560 - 580 CONTINUE -C -C -C Here if neither of pivotal cliques involves row IROW. -C Row IROW sparsity pattern is determined. - GO TO 780 -C -C -C Here if the clique that involves row IROW has been found. -C Merge it with already determined part of row IROW -C sparsity pattern. -C ICLIQ indicates the clique to be merged. -C DISCRD indicates whether the clique can be discarded. - 600 DISCRD=0 - KX=LSTCLQ(ICLIQ) - 700 NEXT=CLIQS(KX) - IR=AATPAT(KX) - IF(TEMP(IR)) 760,720,740 -C -C Add the element to the sparsity pattern of row IROW. - 720 TEMP(IR)=1 - NEWDEG=NEWDEG+1 - RWLIST(NEWDEG)=IR -C WRITE(BUFFER,721) IR -C 721 FORMAT(1X,'MDO: row',I6,' is added to the pattern of row IROW') -C CALL MYWRT(IOERR,BUFFER) - 740 DISCRD=1 - 760 KX=NEXT - IF(KX.NE.0) GO TO 700 -C -C Here if merging is completed. -C Discard the clique if it is a subset of the current pivotal one. - IF(DISCRD.EQ.0) LSTCLQ(ICLIQ)=0 -C -C -C Return to the scanning for other cliques that involve row IROW. - IBEG=ICLIQ+1 - GO TO 540 -C -C -C -C Here if all the previous cliques that involve row IROW -C have been merged with the pivotal clique. -C The resulting sparsity pattern of row IROW is handled -C in RWLIST array. -C Merge the original row IROW with the above list. - 780 KBEG=AATPNT(IROW) - KEND=AATPNT(IROW+1)-1 - DO 800 KX=KBEG,KEND - IR=AATPAT(KX) - IF(MARKER(IR).EQ.1) GO TO 800 - IF(TEMP(IR).NE.0) GO TO 800 -C -C Add the element to the sparsity pattern of row IROW. - TEMP(IR)=1 - NEWDEG=NEWDEG+1 - RWLIST(NEWDEG)=IR - 800 CONTINUE -C -C -C Here if the new degree of row IROW is fully determined. -C Update the degree doubly linked lists. -C Remove row IROW from the linked list of rows with degree OLDDEG. - IF(NEWDEG.EQ.OLDDEG) GO TO 820 - NEXT=LINKFD(IROW) - PREVS=LINKBK(IROW) - IF(NEXT.GT.0) LINKBK(NEXT)=PREVS - IF(PREVS.LT.0) THEN - DGHEAD(OLDDEG)=NEXT - ELSE - LINKFD(PREVS)=NEXT - ENDIF -C -C Add row IROW to the linked list of rows with degree NEWDEG. - IF(NEWDEG.EQ.0) GO TO 820 - NEXT=DGHEAD(NEWDEG) - DGHEAD(NEWDEG)=IROW - LINKBK(IROW)=-NEWDEG - LINKFD(IROW)=NEXT - IF(NEXT.GT.0) LINKBK(NEXT)=IROW -C -C -C Here if linked lists are updated. -C Restore RWLIST and TEMP arrays to the form that only sparsity -C pattern of the current pivotal clique is taken into account. - 820 DO 840 KX=DEGREE+1,NEWDEG - IR=RWLIST(KX) - TEMP(IR)=0 - 840 CONTINUE -C -C -C Continue recalculating the degrees of rows involved -C in a current step of elimination. - 850 K=CLIQS(K) - GO TO 500 -C -C -C -C Here if degrees are recalculated. -C Eliminate row BESTRW (save its position in a permuted matrix). - 860 INVP(BESTRW)=ELROWS - ELROWS=ELROWS+1 -C -C -C -C Check for a mass elimination case. -C If the current elimination step have created at least one -C row with degree equal to MINDEG-1, then the mass elimination -C can be done. - MASSEL=0 - IF(MINDEG.EQ.1) GO TO 910 - IF(DGHEAD(MINDEG-1).EQ.0) GO TO 910 -C -C -C Here to perform mass elimination. -C -C -C *** DEBUGGING -C WRITE(BUFFER,861) -C 861 FORMAT(1X,'MDO: mass elimination starts.') -C CALL MYWRT(IOERR,BUFFER) -C -C Eliminate all rows with degree equal to MINDEG-1. -C Count the eliminated rows. - DEGREE=MINDEG-1 - IROW=DGHEAD(DEGREE) - 870 IF(IROW.EQ.0) GO TO 880 -C -C *** DEBUGGING -C WRITE(BUFFER,871) IROW,DEGREE,ELROWS -C 871 FORMAT(1X,'MDO: row',I6,' (degree',I6,') becomes row',I6) -C CALL MYWRT(IOERR,BUFFER) -C -C -C Eliminate row IROW (save its position in a permuted matrix). - MASSEL=MASSEL+1 - INVP(IROW)=ELROWS - MARKER(IROW)=1 -C -C Update LENOFL and FLOPS. - DEGREE=DEGREE-1 - LENOFL=LENOFL+DEGREE - FLOPS=FLOPS+DBLE(DEGREE)*DBLE(DEGREE) -C - ELROWS=ELROWS+1 - IROW=LINKFD(IROW) - GO TO 870 -C -C -C End of mass elimination. - 880 DGHEAD(MINDEG-1)=0 -C -C -C Once again update the degrees of rows from the pivotal clique. -C Take account of the degree changes caused be the mass elimination. - DO 900 K=1,MINDEG-1 - IROW=RWLIST(K) - IF(MARKER(IROW).EQ.1) GO TO 900 -C -C OLDDEG is an old degree of row (node) IROW. -C NEWDEG is a new degree of row (node) IROW. -C Recall that pivot element contributes to a degree. - KX=IROW - 890 KX=LINKBK(KX) - IF(KX.GT.0) GO TO 890 - OLDDEG=-KX - NEWDEG=OLDDEG-MASSEL -C -C Update the degree doubly linked lists. -C Remove row IROW from the linked list of rows with degree OLDDEG. -C WRITE(BUFFER,891) IROW,OLDDEG,NEWDEG -C 891 FORMAT(1X,'MDO: row ',I6,' olddeg=',I6,' newdeg=',I6) -C CALL MYWRT(IOERR,BUFFER) - IF(NEWDEG.EQ.OLDDEG) GO TO 900 - NEXT=LINKFD(IROW) - PREVS=LINKBK(IROW) - IF(NEXT.GT.0) LINKBK(NEXT)=PREVS - IF(PREVS.LT.0) THEN - DGHEAD(OLDDEG)=NEXT - ELSE - LINKFD(PREVS)=NEXT - ENDIF -C -C Add row IROW to the linked list of rows with degree NEWDEG. - IF(NEWDEG.EQ.0) GO TO 900 - NEXT=DGHEAD(NEWDEG) - DGHEAD(NEWDEG)=IROW - LINKBK(IROW)=-NEWDEG - LINKFD(IROW)=NEXT - IF(NEXT.GT.0) LINKBK(NEXT)=IROW -C - 900 CONTINUE -C -C -C *** DEBUGGING -C DO 902 IROW=1,M -C WRITE(BUFFER,901) IROW,DGHEAD(IROW),LINKFD(IROW),LINKBK(IROW) -C 901 FORMAT(1X,'MDO: row',I6,' hd=',I6,' fd=',I6,' bk=',I6) -C CALL MYWRT(IOERR,BUFFER) -C 902 CONTINUE -C -C -C -C Restore zero value of TEMP array -C (it still contains the current pivotal clique). - 910 DO 920 KX=1,MINDEG-1 - IR=RWLIST(KX) - IF(MARKER(IR).NE.0) GO TO 920 - TEMP(IR)=0 - 920 CONTINUE -C -C -C -C -C Remove all the discarded cliques from the list of active ones. -C ICLIQ indicates the clique that is being analysed. -C IBEG indicates the first clique to be analysed. -C IEND indicates the last clique to be analysed. - IBEG=1 - 940 IEND=NACTCL - IF(IBEG.GT.IEND) GO TO 1000 - DO 960 ICLIQ=IBEG,IEND - IF(LSTCLQ(ICLIQ).EQ.0) GO TO 980 - 960 CONTINUE - GO TO 1000 -C -C Compress the list. - 980 LSTCLQ(ICLIQ)=LSTCLQ(NACTCL) - IBEG=ICLIQ - NACTCL=NACTCL-1 - GO TO 940 -C -C -C -C -C End of main loop. -C Row of the minimum degree has been eliminated. - 1000 MINDEG=MINDEG-MASSEL-1 - IF(MINDEG.LT.1) MINDEG=1 - GO TO 200 -C -C -C -C -C -C Minimum degree heuristic is completed. -C Set the permutation vector. - 2100 DO 2200 I=1,M - K=INVP(I) - PERM(K)=I - 2200 CONTINUE -C -C -C -C -C Write problem statistics. - K=(AATPNT(M+1)-1)/2 - KX=LENOFL - NZL=KX - A1=LENOFL*200.0 - A2=M*M-M - IF(M.GT.1) THEN - A1=A1/A2 - ELSE - A1=0.0 - ENDIF - WRITE(BUFFER,2201) KX,A1 - 2201 FORMAT(1X,'MDO: Matrix L will have ',I13, - X ' subdiagonal elts (density=',F5.1,'%).') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,2202) KX-K - 2202 FORMAT(1X,' Fill-in ',I13) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,2203) FLOPS - 2203 FORMAT(1X,' Decomposition flops',1PD14.6) - CALL MYWRT(IOERR,BUFFER) -C -C - RETURN -C -C -C -C *** LAST CARD OF (MDO) *** - END //GO.SYSIN DD hopdm.src/mdo.f echo hopdm.src/irsolv.f 1>&2 sed >hopdm.src/irsolv.f <<'//GO.SYSIN DD hopdm.src/irsolv.f' 's/^-//' -C***************************************************************** -C *** IRSOLV ... SOLVE EQUATION WITH A*THETA*Atransp *** -C USE ITERATIVE REFINEMENT TO IMPROVE THE ACCURACY -C***************************************************************** -C - SUBROUTINE IRSOLV(LCOEFF,LCLPTS,LRWNBS,LDIAG, - X MAXM,MAXN,MAXNZA,MAXNZL,M,N,ITREF,IALARM, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X THETA,STAVAR,VUSED, - X RMWRK1,RMWRK2,RMWRK3,RNWRK1,RNWRK2,RNWRK3, - X FNEW,DDD,DELX,DELY,RESX,RESY,IOERR) -C -C *** PARAMETERS - INTEGER*4 MAXM,MAXN,MAXNZA,MAXNZL,M,N,LIWORK,LRWORK - INTEGER*4 ITREF,IALARM,IOERR - DOUBLE PRECISION LCOEFF(*),LDIAG(MAXM) - INTEGER*4 LCLPTS(MAXM+1) - INTEGER*2 LRWNBS(MAXNZL) - INTEGER*4 IROW(MAXN) - DOUBLE PRECISION RELT(MAXN),THETA(MAXN) - INTEGER*2 STAVAR(MAXN) - LOGICAL VUSED(MAXN) - DOUBLE PRECISION RMWRK1(MAXM),RMWRK2(MAXM),RMWRK3(MAXM) - DOUBLE PRECISION RNWRK1(MAXN),RNWRK2(MAXN),RNWRK3(MAXN) - DOUBLE PRECISION FNEW(MAXN),DDD(MAXM),DELX(MAXN),DELY(MAXM) - DOUBLE PRECISION RESX,RESY -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(LIWORK),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(LRWORK) -C -C *** LOCAL VARIABLES - INTEGER*4 I,ITER,J - DOUBLE PRECISION RESX0,RESY0 - CHARACTER*100 BUFFER -C -C Additional Cholesky fact. parameters (interface to HYBRID). - COMMON /CHHYB/ RO,FLOPS,IREG,NZCHL,RTCD - DOUBLE PRECISION RO,FLOPS - INTEGER*4 IREG,NZCHL,RTCD -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C N Number of columns of the LP constraint matrix. -C ITREF Number of steps of the iterative refinement to be -C done to improve the accuracy of solution with -C the Cholesky factorization of A*THETA*Atransp. -C IALARM Parameter set to 1 if the iterative refinement process -C does not improve the accuracy. -C LCOEFF Off-diagonal nonzero coefficients of Cholesky matrix. -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C LDIAG Diagonal elements of Cholesky factor. -C THETA Diagonal weight matrix. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k free variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicate the position of the original variable. -C VUSED An indicator if a variable is active in the optimization -C process: -C .TRUE. active variable; -C .FALSE. FIXED variable. -C FNEW Right-hand-side of the equation (part refering to X). -C DDD Right-hand-side of the equation (part refering to Y). -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C *** COMMON ARREAS -C IREG Regularization: -C 0 add RO to all diagonal elements and increase small -C pivots to TAUADD (used by HYBRID); -C 1 increase small pivots to TAUADD (used by HYBRID); -C -1 increase very small pivots to TAUADD (used by HOPDM). -C RO Regularization parameter. -C -C -C ON OUTPUT: -C DELX Solution of the equation (deltaX). -C DELY Solution of the equation (deltaY). -C RESX Residuum of the solution (part refering to deltaX). -C RESY Residuum of the solution (part refering to deltaY). -C -C WORK ARRAYS: -C IROW and RELT are the arrays for temporary handling -C of rows/columns of the constraint matrix. They -C are primarily intended to handle sparse vectors -C (in packed form) but may also be used for storing -C dense ones. -C RMWRK1 Double precision work array of size MAXM. -C RMWRK2 Double precision work array of size MAXM. -C RMWRK3 Double precision work array of size MAXM. -C RNWRK1 Double precision work array of size MAXN. -C RNWRK2 Double precision work array of size MAXN. -C RNWRK3 Double precision work array of size MAXN. -C -C Map of IWORK array: -C IMAP(1) Points to CLPNTS array. -C IMAP(2) Points to RWNMBS array. -C IMAP(3) Points to RWHEAD array. -C IMAP(4) Points to RWLINK array. -C IMAP(5) Points to CLNMBS array. -C IMAP(6) Points to LENCOL array. -C IMAP(7) Points to the first empty cell of IWORK array. -C -C Map of RWORK array: -C RMAP(1) Points to ACOEFF array. -C RMAP(2) Points to C array. -C RMAP(3) Points to RHS array. -C RMAP(4) Points to the first empty cell of RWORK array. -C -C -C *** SUBROUTINES CALLED: -C DABS, SAX (or FSAX), SATY (or FSATY), SOLAAT -C -C *** PURPOSE: -C This routine solves the equation with A*THETA*Atransp. -C It uses the Cholesky decomposition L*D*Ltransp of the -C above matrix. It performs the required number of steps -C of the iterative refinement on the augmented system -C formulation. -C -C *** NOTES: -C -C *** REFERENCES: -C Altman A., Gondzio J. (1993). An efficient implementation of -C a higher order primal-dual interior point method for large -C sparse linear programs, Archives of Control Sciences 2, -C No 1-2, pp. 23-40. -C Altman A., Gondzio J. (1993). HOPDM - A higher order primal- -C dual method for large scale linear programmming, European -C Journal of Operational Research 66 (1993) pp 158-160. -C Gondzio J. (1993). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization 27, pp. 121-140. -C Gondzio J. (1994). Multiple centrality corrections in a primal- -C dual method for linear programming, Technical Report -C No 1994.20, Department of Management Studies, University -C of Geneva, 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, -C November 1994. -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: March 16, 1995 -C -C -C *** BODY OF (IRSOLV) *** -C -C - IALARM=0 - RESX=0.0D0 - RESY=0.0D0 -C -C -C -C Compute the right hand side of the normal eqations. - DO 100 J=1,N - IF(VUSED(J)) RNWRK1(J)=FNEW(J)*THETA(J) - 100 CONTINUE - CALL FSAX(MAXM,MAXN,MAXNZA,RNWRK1,N,RMWRK1,M, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)),IWORK(IMAP(6)), - X VUSED,IOERR) - DO 200 I=1,M - RMWRK1(I)=RMWRK1(I)+DDD(I) - 200 CONTINUE -C -C Solve normal equations for deltaY. - CALL SOLAAT(LCOEFF,LCLPTS,LRWNBS,LDIAG, - X MAXNZL,MAXM,M,DELY,RMWRK1,IOERR) -C -C Compute deltaX. - CALL FSATY(MAXM,MAXN,MAXNZA,DELY,M,RNWRK1,N, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)),IWORK(IMAP(6)), - X VUSED,IOERR) - DO 300 J=1,N - IF(VUSED(J)) DELX(J)=(RNWRK1(J)-FNEW(J))*THETA(J) - 300 CONTINUE -C -C Save current solution in RMWRK3 and RNWRK3 arrays. - DO 400 I=1,M - RMWRK3(I)=DELY(I) - 400 CONTINUE - DO 500 J=1,N - IF(VUSED(J)) RNWRK3(J)=DELX(J) - 500 CONTINUE -C -C -C -C -C -C Main loop begins here. - ITER=0 - 1000 ITER=ITER+1 -C -C -C -C Compute the residual of the current solution in -C the augmented system of KKT equations. -C Use RMWRK2 to store a residual for part Y (null space error). - CALL FSAX(MAXM,MAXN,MAXNZA,DELX,N,RMWRK2,M, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)),IWORK(IMAP(6)), - X VUSED,IOERR) -C - RESX=0.0D0 - RESY=0.0D0 - DO 1200 I=1,M - RMWRK2(I)=DDD(I)-RMWRK2(I) - RMWRK2(I)=RMWRK2(I)-RO*DELY(I) - IF(DABS(RMWRK2(I)).GT.RESY) RESY=DABS(RMWRK2(I)) - 1200 CONTINUE -C -C *** DEBUGGING - WRITE(BUFFER,1201) ITER,RESY - 1201 FORMAT(1X,'IRSOLV: Iter=',I2,' null space error=',1PD9.2) -C CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C -C Save the residuals for the initial solution. - IF(ITER.EQ.1) THEN - RESX0=RESX - RESY0=RESY - ENDIF - IF(RESX+RESY.LE.1.0D-8) GO TO 2000 -C IF(RESX+RESY.LE.1.0D-6.AND.ITER.GE.2) GO TO 2000 - IF(RESX+RESY.LE.1.0D-7.AND.ITER.GE.2) GO TO 2000 - IF(ITER.GT.ITREF) GO TO 2000 -C -C Restore the initial solution if the residuals have increased -C after the iterative refinemet step. Set IALARM parameter. - IF(RESX+RESY.GT.RESX0+RESY0+1.0D-12) THEN - DO 1300 I=1,M - DELY(I)=RMWRK3(I) - 1300 CONTINUE - DO 1400 J=1,N - IF(VUSED(J)) DELX(J)=RNWRK3(J) - 1400 CONTINUE - RESX=RESX0 - RESY=RESY0 -C WRITE(BUFFER,1401) -C1401 FORMAT(1X,'IRSOLV: Error growth in Cholesky factorization.') -C CALL MYWRT(IOERR,BUFFER) - IALARM=1 - GO TO 2000 - ENDIF - IF(RESX+RESY.GT.1.0D-1*(RESX0+RESY0).AND.ITER.GE.2) THEN - IALARM=1 - ENDIF -C -C Give up if residuals are too large. - IF(RESX+RESY.GE.1.0D+1) GO TO 2000 -C -C -C -C Repeat solution of the augmented system for residuals. -C Use RNWRK1 to store a correction for part X. -C Use RMWRK1 to store a correction for part Y. -C -C Solve normal equations for correction of deltaY. - CALL SOLAAT(LCOEFF,LCLPTS,LRWNBS,LDIAG, - X MAXNZL,MAXM,M,RMWRK1,RMWRK2,IOERR) -C -C Compute correction of deltaX. - CALL FSATY(MAXM,MAXN,MAXNZA,RMWRK1,M,RNWRK1,N, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)),IWORK(IMAP(6)), - X VUSED,IOERR) -C -C -C -C Add corrections to the current solution. - DO 1800 I=1,M - DELY(I)=DELY(I)+RMWRK1(I) - 1800 CONTINUE - DO 1900 J=1,N - IF(VUSED(J)) DELX(J)=DELX(J)+RNWRK1(J)*THETA(J) - 1900 CONTINUE -C -C -C -C -C -C End of the main loop. - GO TO 1000 -C -C - 2000 CONTINUE - RETURN -C -C -C *** LAST CARD OF (IRSOLV) *** - END //GO.SYSIN DD hopdm.src/irsolv.f echo hopdm.src/ldaat.f 1>&2 sed >hopdm.src/ldaat.f <<'//GO.SYSIN DD hopdm.src/ldaat.f' 's/^-//' -C*************************************************************** -C **** LDAAT ... LOAD A*Atransp INTO CHOLESKY FACTOR **** -C*************************************************************** -C - SUBROUTINE LDAAT(ACOEFF,CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X THETA,STAVAR,MAXNZL,MAXM,MAXN,MAXNZA,M, - X LCOEFF,LCLPTS,LRWNBS,LDIAG,DPWORK,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXNZL,MAXM,MAXN,MAXNZA,M,IOERR - DOUBLE PRECISION ACOEFF(MAXNZA),THETA(MAXN) - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM),RWLINK(MAXNZA) - DOUBLE PRECISION LCOEFF(*),LDIAG(MAXM),DPWORK(MAXM) - INTEGER*4 LCLPTS(MAXM+1) -C -C *** The following arrays can be half-length integer. - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) - INTEGER*2 STAVAR(MAXN),LRWNBS(MAXNZL) -C -C -C *** LOCAL VARIABLES - INTEGER*4 IR,J,JX,JCOL,JBEG,JEND,K,KX,KBEG,KEND - DOUBLE PRECISION DP - CHARACTER*100 BUFFER -C -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C ACOEFF Nonzero entries of an LP constraint matrix. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C RWHEAD Headers to the row linked lists of entries of matrix A. -C RWLINK Row linked lists of entries of matrix A. -C CLNMBS Column numbers of nonzeros in a given row of matrix A. -C LENCOL Lengths of columns of matrix A. -C THETA Diagonal weight matrix. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k free variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicate the position of the original variable. -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C LCOEFF Off-diagonal nonzero coefficients of A*THETA*Atransp -C matrix (fill-in positions are zeroed). -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C LDIAG Diagonal elements of Cholesky factor. -C -C WORK ARRAYS: -C DPWORK Array for temporary storage of a single column -C of A*THETA*Atransp matrix. -C -C -C *** SUBROUTINES CALLED: -C MYWRT -C -C -C *** PURPOSE: -C This routine constructs the A*THETA*Atransp matrix -C and places it in a data structure for its Cholesky factor. -C All fill-in positions of this structure are zeroed. -C -C -C *** NOTES: -C 1. Matrices ACOEFF, CLPNTS and RWNMBS handle the LP -C constraint matrix as a collection of columns. -C 2. Matrices ACOEFF, RWHEAD, RWLINK and CLNMBS handle -C matrix A in a form of the row linked lists. -C -C -C *** REFERENCES: -C Duff I.S., Erisman A.M., Reid J.K. (1989). Direct methods -C for sparse matrices, Clarendon Press, Oxford 1989, -C chapters 2 and 10. -C Gondzio J. (1993). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization 27, pp. 121-140. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: May 19, 1991 -C Last modified: January 20, 1994 -C -C -C -C *** BODY OF (LDAAT) *** -C -C -C -C *** DEBUGGING -C WRITE(BUFFER,51) -C 51 FORMAT(1X,'LDAAT: Constraint matrix') -C CALL MYWRT(IOERR,BUFFER) -C DO 58 JCOL=1,N -C KBEG=CLPNTS(JCOL) -C KEND=KBEG+LENCOL(JCOL)-1 -C WRITE(BUFFER,55) JCOL -C 55 FORMAT(1X,'LDAAT: Column ',I5) -C CALL MYWRT(IOERR,BUFFER) -C DO 57 K=KBEG,KEND -C WRITE(BUFFER,56) K,RWNMBS(K),ACOEFF(K) -C 56 FORMAT(1X,'LDAAT: K=',I4,' row=',I4,' elt=',1PD20.12) -C CALL MYWRT(IOERR,BUFFER) -C 57 CONTINUE -C 58 CONTINUE -C DO 70 JCOL=1,N -C IF(STAVAR(JCOL).NE.6) THEN -C WRITE(BUFFER,68) JCOL,THETA(JCOL) -C 68 FORMAT(1X,'LDAAT: THETA(',I4,')=',D12.5) -C CALL MYWRT(IOERR,BUFFER) -C ENDIF -C 70 CONTINUE -C -C -C -C -C -C Main loop begins here (loop over columns of A*THETA*Atransp). - DO 1000 J=1,M -C -C -C Zero all the elements of DPWORK array in the sparsity -C pattern of the appropriate column of Cholesky factor. - JBEG=LCLPTS(J) - JEND=LCLPTS(J+1)-1 - DO 200 JX=JBEG,JEND - IR=LRWNBS(JX) - DPWORK(IR)=0.0 - 200 CONTINUE -C -C -C Scan row J of matrix A (column J of Atransp). - LDIAG(J)=0.0 - K=RWHEAD(J) - 300 IF(K.EQ.0) GO TO 500 - JCOL=CLNMBS(K) - DP=THETA(JCOL)*ACOEFF(K) - LDIAG(J)=LDIAG(J)+DP*ACOEFF(K) -C -C Initialize loop over nonzeros of a column. The whole column -C have to be analysed if its nonzeros are not in increasing -C order of row numbers. -C KBEG=CLPNTS(JCOL) -C KEND=KBEG+LENCOL(JCOL)-1 - KBEG=K+1 - KEND=CLPNTS(JCOL)+LENCOL(JCOL)-1 - DO 400 KX=KBEG,KEND - IR=RWNMBS(KX) - DPWORK(IR)=DPWORK(IR)+DP*ACOEFF(KX) - 400 CONTINUE -C -C -C Continue the scanning of J-th row of matrix A. - 450 K=RWLINK(K) - GO TO 300 -C -C -C Here when the column building is completed. -C Copy the column to the data structures for Cholesky factor. -C Note that fill-in positions contain zeros. - 500 CONTINUE -C -C -C *** DEBUGGING -C WRITE(BUFFER,451) J -C 451 FORMAT(1X,'LDAAT: Cholesky matrix, column ',I5) -C CALL MYWRT(IOERR,BUFFER) -C DO 457 JX=JBEG,JEND -C IR=LRWNBS(JX) -C WRITE(BUFFER,456) JX,LRWNBS(JX),DPWORK(IR) -C 456 FORMAT(1X,'LDAAT: JX=',I4,' rw=',I4,' elt=',1PD20.12) -C CALL MYWRT(IOERR,BUFFER) -C 457 CONTINUE -C -C - DO 600 JX=JBEG,JEND - IR=LRWNBS(JX) - LCOEFF(JX)=DPWORK(IR) - 600 CONTINUE -C -C -C -C -C -C End of main loop. - 1000 CONTINUE -C -C -C - RETURN -C -C *** LAST CARD OF (LDAAT) *** - END //GO.SYSIN DD hopdm.src/ldaat.f echo hopdm.src/limtim.f 1>&2 sed >hopdm.src/limtim.f <<'//GO.SYSIN DD hopdm.src/limtim.f' 's/^-//' -C******************************************* -C *** LIMTIM ... CHECK LIMIT OF TIME *** -C******************************************* -C - SUBROUTINE LIMTIM(LTIME) -C - INTEGER*4 LTIME -C -C *** PURPOSE: -C Check time limit. -C LTIME: 0 continue, 1 stop. -C - LTIME=0 - RETURN -C - END //GO.SYSIN DD hopdm.src/limtim.f echo hopdm.src/lkcode.f 1>&2 sed >hopdm.src/lkcode.f <<'//GO.SYSIN DD hopdm.src/lkcode.f' 's/^-//' - SUBROUTINE LKCODE(RWNAME,M,NAME,INDEX,HEADER,LINKS,IOERR) -C - INTEGER*4 KCODE,M,I,INDEX,IOERR - INTEGER*2 HEADER(M),LINKS(M) - CHARACTER*8 RWNAME(M),NAME - CHARACTER*100 BUFFER -C -C Get code of the NAME. - CALL MYCODE(IOERR,NAME,KCODE,M) - INDEX=HEADER(KCODE) -C -C Determine the index such that RWNAME(index) = NAME. - DO 100 I=1,M - IF(INDEX.EQ.0) GO TO 200 - IF(RWNAME(INDEX).EQ.NAME) GO TO 200 - INDEX=LINKS(INDEX) - 100 CONTINUE -C - 200 CONTINUE - RETURN - END //GO.SYSIN DD hopdm.src/lkcode.f echo hopdm.src/lkindx.f 1>&2 sed >hopdm.src/lkindx.f <<'//GO.SYSIN DD hopdm.src/lkindx.f' 's/^-//' - SUBROUTINE LKINDX(RWNAME,M,NAME,INDEX) -C - INTEGER*4 M,I,INDEX,INDEX2 - CHARACTER*8 RWNAME(M),NAME -C - INDEX2=INDEX -C WRITE(0,10) INDEX -C 10 FORMAT(1X,' old index=',I5) - INDEX=0 - DO 100 I=INDEX2,M - IF(RWNAME(I).EQ.NAME) THEN - INDEX=I - GO TO 200 - ENDIF - 100 CONTINUE - DO 150 I=1,INDEX2 - IF(RWNAME(I).EQ.NAME) THEN - INDEX=I - GO TO 200 - ENDIF - 150 CONTINUE -C - 200 CONTINUE - RETURN - END //GO.SYSIN DD hopdm.src/lkindx.f echo hopdm.src/makefile 1>&2 sed >hopdm.src/makefile <<'//GO.SYSIN DD hopdm.src/makefile' 's/^-//' -FC = f77 -LIBS = - -#FFLAGS = -fast -O4 # Sun: fast execution, nonstandard arithmetic -#LDFLAGS = -fast -O4 # Sun: fast execution, nonstandard arithmetic -FFLAGS = -u -O -LDFLAGS = -PROGRAM = hopdm - -OBJS = hmain2.o setmap.o rdspec.o mywrt.o errwrt.o \ - mycode.o lkcode.o \ - rdmps1.o rdmps2.o rdrhs.o lkindx.o limtim.o \ - presol.o fdiden.o fdaggr.o elvrbl.o elcnst.o \ - rrwsng.o rclsng.o smplx.o postsl.o detspl.o split.o \ - getdim.o mkspar.o scalea.o sclrow.o sclcol.o \ - wrtsol.o reorda.o reordi.o reordv.o emptyr.o \ - prepro.o mdo.o mmd.o genqmd.o symfct.o \ - defaat.o cntaat.o dtsort.o dtsrta.o \ - factor.o ldaat.o numfct.o solaat.o irsolv.o \ - solvl.o solvlt.o sax.o saty.o saxpy.o \ - fsax.o fsaty.o \ - pcpdm.o pcdir.o pcstep.o pcinit.o pcchck.o \ - getcol.o xgtcol.o getrow.o xgtrow.o \ - sdot.o dattim.o mytime.o blas.o - -COBJS = ftime.o -CC = cc -CFLAGS = -DKR_headers - -# If your Fortran library provides subroutines fdate and dtime (as -# is true on at least some Sun systems), omit "ftime.o" from the -# COBJS = line above. Alternatively, if your C compiler understands -# ANSI/ISO C syntax, you can omit "-DKR_headers" from the CFLAGS = -# assignment above. - -$(PROGRAM): $(OBJS) $(COBJS) - $(FC) $(LDFLAGS) $(OBJS) $(COBJS) -o $(PROGRAM) $(LIBS) - - @echo - @echo HOPDM done //GO.SYSIN DD hopdm.src/makefile echo hopdm.src/mkspar.f 1>&2 sed >hopdm.src/mkspar.f <<'//GO.SYSIN DD hopdm.src/mkspar.f' 's/^-//' -C************************************************ -C *** MKSPAR ... MAKE MATRIX A SPARSER *** -C************************************************ -C - SUBROUTINE MKSPAR(IOERR,MSGLEV, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X M1,N1,NZ1,IROW,RELT, - X IMTMP1,INTMP1,INTMP2, - X B,RANGES, - X ACOEFF,CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X P,Q,STAVAR,RWSTAT,STAROW,RWNAME, - X MARKER,LENROW,LIST,LACTIV,ACTIVE) -C -C -C -C *** PARAMETERS - INTEGER*4 IOERR,MSGLEV,MAXM,MAXN,MAXNZA,M,N,NSTRCT,M1,N1,NZ1 - INTEGER*4 IROW(MAXN),IMTMP1(MAXM),INTMP1(MAXN) - INTEGER*2 INTMP2(MAXN) - DOUBLE PRECISION RELT(MAXN),ACOEFF(MAXNZA),B(MAXM),RANGES(MAXM) - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM+1),RWLINK(MAXNZA) - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) - CHARACTER*8 RWNAME(MAXM) - DOUBLE PRECISION P(MAXM),Q(MAXM) - INTEGER*2 STAVAR(MAXN),STAROW(MAXM),RWSTAT(MAXM) - INTEGER*2 MARKER(MAXM),LENROW(MAXM) - INTEGER*2 LIST(MAXM),LACTIV(MAXM),ACTIVE(MAXM) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 COLLEN,MNEW,NCOMN,FIRST,LAST,LENOK,NZELIM - INTEGER*4 I,IPOS,JPIVOT,IR,IRUN,J,K,IKX,KOK,KOUT,NZEL0 - INTEGER*4 JSHORT,JLONG,KSHORT,KLONG,KSHBEG,KSHEND,LSHORT - DOUBLE PRECISION DP,PIVOT,AELT,BELT - DOUBLE PRECISION BIG,SMALLA,GROWTH - CHARACTER*100 BUFFER -C -C -C -C -C *** PARAMETERS DESCRIPTION -C -C *** ON INPUT: -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C MSGLEV The level of PRE_SOLVE information desired: -C 0 only final problem dimensions are printed; -C 1 numbers of eliminated rows and columns are printed; -C 2 names of eliminated rows and columns are printed; -C 3 detailed DEBUGGING information is printed. -C MAXM Maximum number of constraints. -C MAXN Maximum number of variables. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of constraints. -C N Number of variables (total, i.e. including slacks, -C surplus and artificials). -C NSTRCT Number of structural variables (excluding slacks, -C surplus and artificials). -C ACOEFF Array of nonzero elements for each column. -C B Right hand side of the linear program. -C RANGES Array of constraint ranges. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C LENCOL Lengths of (sparse) columns of matrix A. -C P LOWER bounds on shadow prices (dual variables). -C Q UPPER bounds on shadow prices (dual variables). -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C RWSTAT Array of row types: -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 objective row; -C 5 other free row. -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C RWNAME Array of row names (increasing order sort). -C -C *** ON OUTPUT: -C -C -C -C -C *** WORK ARRAYS: -C IROW and RELT are the arrays for temporary handling of rows -C and columns of the constraint matrix. They are primarily -C intended to handle sparse vectors (in packed form) -C but may also be used for storing dense ones. -C IMTMP1 Integer work array of size MAXM. -C INTMP1 Integer work array of size MAXN -C INTMP2 Half-length integer work array of size MAXN. -C MARKER Half-length integer work array of size MAXM. -C LENROW Half-length integer work array of size MAXM. -C LIST Half-length integer work array of size MAXM. -C LACTIV Half-length integer work array of size MAXM. -C ACTIVE Half-length integer work array of size MAXM. -C -C -C -C -C *** PURPOSE -C This routine finds EQUALITY type LP constraints with -C the sparsity structure being the subset of the other -C constraint. Shorter row of A is then used to eliminate -C nonzero entries from the longer one. -C -C -C -C *** SUBROUTINES CALLED -C MYWRT,GETCOL,GETROW,DABS,EMPTYR,REORDA -C -C -C *** NOTES -C This routine is given direct access to the matrix A. -C It alters hidden data structures. -C -C -C -C *** REFERENCES: -C Gondzio J. (1994). Analysis of linear programs prior to applying -C the interior point method, Technical Report NO 1994.3, -C Department of Management Studies, University of Geneva, -C 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, February 1994. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: February 12, 1994 -C -C -C -C -C *** BODY OF (MKSPAR) *** -C -C -C -C Initialize. - BIG=1.0D+30 - SMALLA=1.0D-10 - GROWTH=1.0D+3 - IRUN=1 - NZELIM=0 -C -C -C -C -C Count nonzero elements of all LP constraints. -C Zero INTMP1 array (it will be used to store sparsity -C pattern of the short EQUALITY type constraint). - DO 20 I=1,M - LENROW(I)=0 - 20 CONTINUE - DO 60 J=1,N - INTMP1(J)=0 - IF(STAVAR(J).GE.6) GO TO 60 - KSHBEG=CLPNTS(J) - KSHEND=KSHBEG+LENCOL(J)-1 - DO 40 K=KSHBEG,KSHEND - I=RWNMBS(K) - LENROW(I)=LENROW(I)+1 - 40 CONTINUE - 60 CONTINUE -C -C -C -C Build linked list of equality type LP constraints with -C the same lengths. Initialize ACTIVE array. - LENOK=NSTRCT+1 - 100 DO 120 J=1,NSTRCT+1 - INTMP2(J)=0 - 120 CONTINUE - DO 140 I=M,1,-1 - ACTIVE(I)=0 - IF(RWSTAT(I).NE.1) GO TO 140 - ACTIVE(I)=1 - K=LENROW(I) - LIST(I)=INTMP2(K) - INTMP2(K)=I - 140 CONTINUE -C -C Build a list of equality type rows ordered with increasing -C number of nonzero entries. - LAST=0 - DO 180 J=1,LENOK - I=INTMP2(J) - IF(I.EQ.0) GO TO 180 - 160 LAST=LAST+1 - LACTIV(LAST)=I -C WRITE(BUFFER,161) I,RWSTAT(I),J -C 161 FORMAT(1X,'row=',I6,' rwstat=',I6,' length=',I6) -C CALL MYWRT(IOERR,BUFFER) - I=LIST(I) - IF(I.GT.0) GO TO 160 - 180 CONTINUE -C -C -C -C -C -C -C Main loop begins here. -C Look for EQUALITY type constraints with at least 2 entries. - FIRST=1 - 200 IF(LAST.LT.FIRST) GO TO 1000 - I=LACTIV(FIRST) -C -C Pack the sparsity pattern of row I into INTMP1 array (omit -C already eliminated entries). Save the number of the shortest -C column as JSHORT and the number of the longest column as JLONG. -C Save the largest elt of this row as PIVOT and the corresponding -C column number as JPIVOT. - K=RWHEAD(I) - JSHORT=0 - LSHORT=M+1 - JLONG=0 - COLLEN=0 - JPIVOT=0 - PIVOT=0.0D0 - 320 IF(K.EQ.0) GO TO 400 - J=CLNMBS(K) - IF(J.LE.0) GO TO 340 - INTMP1(J)=K - IF(LENCOL(J).LT.LSHORT) THEN - JSHORT=J - LSHORT=LENCOL(J) - ENDIF - IF(LENCOL(J).GT.COLLEN) THEN - JLONG=J - COLLEN=LENCOL(J) - ENDIF - IF(DABS(ACOEFF(K)).GT.PIVOT) THEN - JPIVOT=J - PIVOT=DABS(ACOEFF(K)) - ENDIF - 340 K=RWLINK(K) - GO TO 320 -C -C - 400 CONTINUE -C -C *** DEBUGGING - IF(MSGLEV.LE.2) GO TO 410 - WRITE(BUFFER,401) - 401 FORMAT(1X) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,402) I,LENROW(I),JPIVOT,PIVOT - 402 FORMAT(1X,'row=',I6,' ln=',I6,' Jpiv=',I6,' piv=',D10.3) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,403) JSHORT,LSHORT,JLONG,COLLEN - 403 FORMAT(1X,'short=',I6,' ln=',I6,' long=',I6,' ln=',I6) - CALL MYWRT(IOERR,BUFFER) - 410 CONTINUE -C -C -C Scan short column. Check if any row crossing it contains row I. - IF(LSHORT.EQ.1) GO TO 900 - KSHBEG=CLPNTS(JSHORT) - KSHEND=KSHBEG+LENCOL(JSHORT)-1 - DO 800 K=KSHBEG,KSHEND - IR=RWNMBS(K) - IF(IR.EQ.I) GO TO 800 - IF(IR.LE.0) GO TO 800 - IF(LENROW(IR).LT.LENROW(I)) GO TO 800 -C -C Scan row IR. Count the number of common entries with row I. -C Pack the sparsity pattern of row IR into IROW array (omit -C already eliminated entries). - NCOMN=0 - KLONG=RWHEAD(IR) - 420 IF(KLONG.EQ.0) GO TO 500 - J=CLNMBS(KLONG) - IF(J.LE.0) GO TO 440 - IROW(J)=KLONG - IF(INTMP1(J).GT.0) NCOMN=NCOMN+1 - 440 KLONG=RWLINK(KLONG) - GO TO 420 -C -C Check if the sparsity pattern of row I is a subset of that -C of row IR. - 500 CONTINUE - IF(MSGLEV.LE.2) GO TO 502 - WRITE(BUFFER,501) IR,LENROW(IR),NCOMN - 501 FORMAT(1X,'row=',I6,' len=',I6,' NCOMN=',I6) - CALL MYWRT(IOERR,BUFFER) - 502 CONTINUE - IF(NCOMN.LT.LENROW(I)) GO TO 800 -C -C -C Perform the elimination. Recall, that INTMP1 and IROW arrays -C remember sparsity patterns of rows I and IR, respectively. -C Compute Gaussian elementary operator that eliminates nonzero -C entry from the longest column. If it is acceptable, then use it. -C Otherwise use the PIVOT element (the largest entry of row I) -C to define the operator. - NZEL0=NZELIM - KSHORT=INTMP1(JLONG) - KLONG=IROW(JLONG) - DP=ACOEFF(KLONG)/ACOEFF(KSHORT) - IF(DABS(DP).LE.GROWTH) GO TO 600 - KSHORT=INTMP1(JPIVOT) - KLONG=IROW(JPIVOT) - DP=ACOEFF(KLONG)/ACOEFF(KSHORT) -C -C Perform elimination: ROW(ir) := ROW(ir) - DP * ROW(i) - 600 CONTINUE - IF(MSGLEV.LE.2) GO TO 602 - WRITE(BUFFER,601) KSHORT,KLONG,DP - 601 FORMAT(1X,'KSHORT=',I6,' KLONG=',I6,' M_entry=',D10.3) - CALL MYWRT(IOERR,BUFFER) - 602 CONTINUE - IF(DABS(DP).GE.GROWTH) GO TO 800 -C -C -C Perform elimination: ROW(ir) := ROW(ir) - DP * ROW(i) -C Loop over nonzero entries of row I. - KSHORT=RWHEAD(I) - 620 IF(KSHORT.EQ.0) GO TO 700 - J=CLNMBS(KSHORT) -C WRITE(BUFFER,621) KSHORT,I,CLNMBS(KSHORT),ACOEFF(KSHORT) -C 621 FORMAT(1X,'Kshort=',I5,' rw=',I6,' cl=',I6,' elt=',D10.3) -C CALL MYWRT(IOERR,BUFFER) - IF(J.LE.0) GO TO 680 - KLONG=IROW(J) -C WRITE(BUFFER,622) KLONG,RWNMBS(KLONG),CLNMBS(KLONG), -C X ACOEFF(KLONG) -C 622 FORMAT(1X,'Klong=',I6,' rw=',I6,' cl=',I6,' elt=',D10.3) -C CALL MYWRT(IOERR,BUFFER) -C -C Update nonzero entry of the longer row. - AELT=ACOEFF(KLONG)-DP*ACOEFF(KSHORT) - ACOEFF(KLONG)=AELT - IF(DABS(AELT).LE.SMALLA) THEN - NZELIM=NZELIM+1 - LENROW(IR)=LENROW(IR)-1 - CLNMBS(KLONG)=-CLNMBS(KLONG) - RWNMBS(KLONG)=-RWNMBS(KLONG) - IF(MSGLEV.LE.2) GO TO 642 - WRITE(BUFFER,641) IR - 641 FORMAT(1X,'MKSPAR: Entry removed from row=',I6) - CALL MYWRT(IOERR,BUFFER) - 642 CONTINUE - ENDIF - 680 KSHORT=RWLINK(KSHORT) - GO TO 620 -C -C Update RHS. - 700 BELT=B(IR)-DP*B(I) - IF(DABS(BELT).LE.SMALLA) BELT=0.0D0 - B(IR)=BELT -C -C Update bounds on shadow prices. - IF(DP.LE.0.0D0) THEN - P(I)=P(I)+DP*Q(IR) - Q(I)=Q(I)+DP*P(IR) - ELSE - P(I)=P(I)+DP*P(IR) - Q(I)=Q(I)+DP*Q(IR) - ENDIF -C -C Add row IR to the list of active rows. - IF(RWSTAT(IR).NE.1) GO TO 800 - IF(ACTIVE(IR).EQ.1) GO TO 800 - IF(NZEL0.EQ.NZELIM) GO TO 800 - IF(LAST.EQ.M) THEN -C -C Move the list to the beginning of LACTIV array. - DO 720 IKX=1,LAST-FIRST+1 - LACTIV(IKX)=LACTIV(IKX+FIRST-1) - 720 CONTINUE - LAST=LAST-FIRST+1 - FIRST=1 - ENDIF - LAST=LAST+1 - ACTIVE(IR)=1 - LACTIV(LAST)=IR -C -C Save length of the row used in the elimination. - LENOK=LENROW(I) -C - 800 CONTINUE -C -C -C Zero INTMP1 array. - 900 K=RWHEAD(I) - 920 IF(K.EQ.0) GO TO 960 - J=CLNMBS(K) - IF(J.LE.0) GO TO 940 - INTMP1(J)=0 - 940 K=RWLINK(K) - GO TO 920 -C -C Eliminate row I from the list of active rows. - 960 CONTINUE - ACTIVE(I)=0 - FIRST=FIRST+1 -C -C -C -C -C -C -C End of main loop. - GO TO 200 - 1000 CONTINUE -C -C -C -C -C -C -C Check if MAKE_SPARSE heuristic produced considerable reduction -C (at least 50%) of nonzero entries in A. If so, then repeat it -C for all rows of length at most LENOK. - IF(IRUN.EQ.2) GO TO 1020 - IF(NZELIM.LE.100) GO TO 1020 - IF(2*NZELIM.LE.NZ1) GO TO 1020 -C -C Repeat MAKE_SPARSE heuristic. - IRUN=2 - IF(MSGLEV.LE.0) GO TO 1012 - WRITE(BUFFER,1011) NZELIM - 1011 FORMAT(1X,'MKSPAR: First pass, nonz. elim: ',I9) - CALL MYWRT(IOERR,BUFFER) - 1012 CONTINUE - GO TO 100 -C -C -C -C -C -C -C Here if a successful run of the loop has been completed. - 1020 IF(MSGLEV.LE.0) GO TO 1030 - WRITE(BUFFER,1021) NZELIM - 1021 FORMAT(1X,'MKSPAR: Nonzeros eliminated: ',I9) - CALL MYWRT(IOERR,BUFFER) - 1030 CONTINUE -C -C -C -C -C -C - IF(NZELIM.GT.0) THEN -C -C Reorder elements within each column of the LP constraint -C matrix in such a way that those of the active part of A -C are at the beginning of the lists. The column lengths will -C later be decreased to forget inactive part of matrix A. -C Set the new row linked lists of nonzero elements of matrix A. -C Recall that CLPNTS(j) indicates the first entry of column j. -C Zero RWHEAD array. - DO 1200 I=1,M - RWHEAD(I)=0 - 1200 CONTINUE -C -C Reorder nonzero elements within each column. - DO 1500 J=1,N - IF(STAVAR(J).GE.6) GO TO 1500 - KSHBEG=CLPNTS(J) - KSHEND=KSHBEG+LENCOL(J)-1 - KOK=0 - KOUT=0 - DO 1300 K=KSHBEG,KSHEND - I=RWNMBS(K) - IF(I.GT.0) THEN - KOK=KOK+1 - IROW(KOK)=RWNMBS(K) - RELT(KOK)=ACOEFF(K) - ELSE - IPOS=LENCOL(J)-KOUT - KOUT=KOUT+1 - IROW(IPOS)=RWNMBS(K) - RELT(IPOS)=ACOEFF(K) - ENDIF - 1300 CONTINUE -C -C Save only active part of the column. -C Set the row linked lists. - KSHBEG=CLPNTS(J)-1 - DO 1400 IKX=1,KOK - K=KSHBEG+IKX - I=IROW(IKX) - RWNMBS(K)=I - CLNMBS(K)=J - ACOEFF(K)=RELT(IKX) - RWLINK(K)=RWHEAD(I) - RWHEAD(I)=K - 1400 CONTINUE - LENCOL(J)=KOK - 1500 CONTINUE -C -C Determine the permutation that puts all empty and inactive -C rows at the end of the list. -C - IRUN=3 - IF(MSGLEV.LE.1) IRUN=4 - CALL EMPTYR(MAXM,M,MNEW,IRUN, - X RWHEAD,STAROW,MARKER,LENROW,IOERR) -C -C -C Reorder the rows of the LP constraint matrix according to -C the permutation resulting from the analysis of EMPTYR. - IF(MNEW.LT.M) THEN -C - CALL REORDA(MAXM,MAXN,MAXNZA,M,N, - X CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X MARKER,LENROW,IMTMP1,IROW,RELT, - X RWNAME,STAROW,RWSTAT,RANGES,B,IOERR) -C -C Reorder bounds on shadow prices P and Q. - CALL REORDV(MAXM,M, - X MARKER,LENROW,P,RELT,IOERR) - CALL REORDV(MAXM,M, - X MARKER,LENROW,Q,RELT,IOERR) -C -C Set the new number of rows of the constraint matrix. - M=MNEW -C - ENDIF - ENDIF -C -C -C -C -C -C -C Determine current dimensions of the problem. - M1=M - N1=0 - NZ1=0 - DO 1600 J=1,NSTRCT - IF(STAVAR(J).GE.6) GO TO 1600 - IF(STAVAR(J).LT.0) THEN - K=-STAVAR(J) - IF(J.GE.K) GO TO 1600 - ENDIF - N1=N1+1 - NZ1=NZ1+LENCOL(J) - 1600 CONTINUE -C -C -C -C -C - RETURN -C -C -C -C *** LAST CARD OF (MKSPAR) *** - END //GO.SYSIN DD hopdm.src/mkspar.f echo hopdm.src/mmd.f 1>&2 sed >hopdm.src/mmd.f <<'//GO.SYSIN DD hopdm.src/mmd.f' 's/^-//' -c*************************************************************** -c*************************************************************** -c**** genmmd ..... multiple minimum external degree **** -c*************************************************************** -c*************************************************************** -c -c purpose - this routine implements the minimum degree -c algorithm. it makes use of the implicit representation -c of elimination graphs by quotient graphs, and the -c notion of indistinguishable nodes. it also implements -c the modifications by multiple elimination and minimum -c external degree. -c --------------------------------------------- -c caution - the adjacency vector adjncy will be -c destroyed. -c --------------------------------------------- -c -c input parameters - -c neqns - number of equations. -c (xadj,adjncy) - the adjacency structure. -c delta - tolerance value for multiple elimination. -c maxint - maximum machine representable (short) integer -c (any smaller estimate will do) for marking -c nodes. -c -c output parameters - -c perm - the minimum degree ordering. -c invp - the inverse of perm. -c nofsub - an upper bound on the number of nonzero -c subscripts for the compressed storage scheme. -c -c working parameters - -c dhead - vector for head of degree lists. -c invp - used temporarily for degree forward link. -c perm - used temporarily for degree backward link. -c qsize - vector for size of supernodes. -c llist - vector for temporary linked lists. -c marker - a temporary marker vector. -c -c program subroutines - -c mmdelm, mmdint, mmdnum, mmdupd. -c -c*************************************************************** -c - subroutine mmd ( neqns, xadj, adjncy, invp, perm, - 1 delta, dhead, qsize, llist, marker, - 1 maxint, nofsub ) -c -c*************************************************************** -c - implicit none -c - integer*4 adjncy(1), dhead(1) , invp(1) , llist(1) , - 1 marker(1), perm(1) , qsize(1) - integer*4 xadj(1) - integer*4 delta , ehead , i , maxint, mdeg , - 1 mdlmt , mdnode, neqns , nextmd, nofsub, - 1 num, tag -c -c*************************************************************** -c - if ( neqns .le. 0 ) return -c -c ------------------------------------------------ -c initialization for the minimum degree algorithm. -c ------------------------------------------------ - nofsub = 0 - call mmdint ( neqns, xadj, adjncy, dhead, invp, perm, - 1 qsize, llist, marker ) -c -c ---------------------------------------------- -c num counts the number of ordered nodes plus 1. -c ---------------------------------------------- - num = 1 -c -c ----------------------------- -c eliminate all isolated nodes. -c ----------------------------- - nextmd = dhead(1) - 100 continue - if ( nextmd .le. 0 ) go to 200 - mdnode = nextmd - nextmd = invp(mdnode) - marker(mdnode) = maxint - invp(mdnode) = - num - num = num + 1 - go to 100 -c - 200 continue -c ---------------------------------------- -c search for node of the minimum degree. -c mdeg is the current minimum degree; -c tag is used to facilitate marking nodes. -c ---------------------------------------- - if ( num .gt. neqns ) go to 1000 - tag = 1 - dhead(1) = 0 - mdeg = 2 - 300 continue - if ( dhead(mdeg) .gt. 0 ) go to 400 - mdeg = mdeg + 1 - go to 300 - 400 continue -c ------------------------------------------------- -c use value of delta to set up mdlmt, which governs -c when a degree update is to be performed. -c ------------------------------------------------- - mdlmt = mdeg + delta - ehead = 0 -c - 500 continue - mdnode = dhead(mdeg) - if ( mdnode .gt. 0 ) go to 600 - mdeg = mdeg + 1 - if ( mdeg .gt. mdlmt ) go to 900 - go to 500 - 600 continue -c ---------------------------------------- -c remove mdnode from the degree structure. -c ---------------------------------------- - nextmd = invp(mdnode) - dhead(mdeg) = nextmd - if ( nextmd .gt. 0 ) perm(nextmd) = - mdeg - invp(mdnode) = - num - nofsub = nofsub + mdeg + qsize(mdnode) - 2 - if ( num+qsize(mdnode) .gt. neqns ) go to 1000 -c ---------------------------------------------- -c eliminate mdnode and perform quotient graph -c transformation. reset tag value if necessary. -c ---------------------------------------------- - tag = tag + 1 - if ( tag .lt. maxint ) go to 800 - tag = 1 - do 700 i = 1, neqns - if ( marker(i) .lt. maxint ) marker(i) = 0 - 700 continue - 800 continue - call mmdelm ( mdnode, xadj, adjncy, dhead, invp, - 1 perm, qsize, llist, marker, maxint, - 1 tag ) - num = num + qsize(mdnode) - llist(mdnode) = ehead - ehead = mdnode - if ( delta .ge. 0 ) go to 500 - 900 continue -c ------------------------------------------- -c update degrees of the nodes involved in the -c minimum degree nodes elimination. -c ------------------------------------------- - if ( num .gt. neqns ) go to 1000 - call mmdupd ( ehead, neqns, xadj, adjncy, delta, mdeg, - 1 dhead, invp, perm, qsize, llist, marker, - 1 maxint, tag ) - go to 300 -c - 1000 continue - call mmdnum ( neqns, perm, invp, qsize ) - return -c - end -c*************************************************************** -c*************************************************************** -c*** mmdint ..... mult minimum degree initialization *** -c*************************************************************** -c*************************************************************** -c -c purpose - this routine performs initialization for the -c multiple elimination version of the minimum degree -c algorithm. -c -c input parameters - -c neqns - number of equations. -c (xadj,adjncy) - adjacency structure. -c -c output parameters - -c (dhead,dforw,dbakw) - degree doubly linked structure. -c qsize - size of supernode (initialized to one). -c llist - linked list. -c marker - marker vector. -c -c*************************************************************** -c - subroutine mmdint ( neqns, xadj, adjncy, dhead, dforw, - 1 dbakw, qsize, llist, marker ) -c -c*************************************************************** -c - implicit none -c - integer*4 adjncy(1), dbakw(1) , dforw(1) , dhead(1) , - 1 llist(1) , marker(1), qsize(1) - integer*4 xadj(1) - integer*4 fnode , ndeg , neqns , node -c -c*************************************************************** -c - do 100 node = 1, neqns - dhead(node) = 0 - qsize(node) = 1 - marker(node) = 0 - llist(node) = 0 - 100 continue -c ------------------------------------------ -c initialize the degree doubly linked lists. -c ------------------------------------------ - do 200 node = 1, neqns - ndeg = xadj(node+1) - xadj(node) + 1 - fnode = dhead(ndeg) - dforw(node) = fnode - dhead(ndeg) = node - if ( fnode .gt. 0 ) dbakw(fnode) = node - dbakw(node) = - ndeg - 200 continue - return -c - end -c*************************************************************** -c*************************************************************** -c** mmdelm ..... multiple minimum degree elimination *** -c*************************************************************** -c*************************************************************** -c -c purpose - this routine eliminates the node mdnode of -c minimum degree from the adjacency structure, which -c is stored in the quotient graph format. it also -c transforms the quotient graph representation of the -c elimination graph. -c -c input parameters - -c mdnode - node of minimum degree. -c maxint - estimate of maximum representable (short) -c integer. -c tag - tag value. -c -c updated parameters - -c (xadj,adjncy) - updated adjacency structure. -c (dhead,dforw,dbakw) - degree doubly linked structure. -c qsize - size of supernode. -c marker - marker vector. -c llist - temporary linked list of eliminated nabors. -c -c*************************************************************** -c - subroutine mmdelm ( mdnode, xadj, adjncy, dhead, dforw, - 1 dbakw, qsize, llist, marker, maxint, - 1 tag ) -c -c*************************************************************** -c - implicit none -c - integer*4 adjncy(1), dbakw(1) , dforw(1) , dhead(1) , - 1 llist(1) , marker(1), qsize(1) - integer*4 xadj(1) - integer*4 elmnt , i , istop , istrt , j , - 1 jstop , jstrt , link , maxint, mdnode, - 1 nabor , node , npv , nqnbrs, nxnode, - 1 pvnode, rlmt , rloc , rnode , tag , - 1 xqnbr -c -c*************************************************************** -c -c ----------------------------------------------- -c find reachable set and place in data structure. -c ----------------------------------------------- - marker(mdnode) = tag - istrt = xadj(mdnode) - istop = xadj(mdnode+1) - 1 -c ------------------------------------------------------- -c elmnt points to the beginning of the list of eliminated -c nabors of mdnode, and rloc gives the storage location -c for the next reachable node. -c ------------------------------------------------------- - elmnt = 0 - rloc = istrt - rlmt = istop - do 200 i = istrt, istop - nabor = adjncy(i) - if ( nabor .eq. 0 ) go to 300 - if ( marker(nabor) .ge. tag ) go to 200 - marker(nabor) = tag - if ( dforw(nabor) .lt. 0 ) go to 100 - adjncy(rloc) = nabor - rloc = rloc + 1 - go to 200 - 100 continue - llist(nabor) = elmnt - elmnt = nabor - 200 continue - 300 continue -c ----------------------------------------------------- -c merge with reachable nodes from generalized elements. -c ----------------------------------------------------- - if ( elmnt .le. 0 ) go to 1000 - adjncy(rlmt) = - elmnt - link = elmnt - 400 continue - jstrt = xadj(link) - jstop = xadj(link+1) - 1 - do 800 j = jstrt, jstop - node = adjncy(j) - link = - node - if ( node ) 400, 900, 500 - 500 continue - if ( marker(node) .ge. tag .or. - 1 dforw(node) .lt. 0 ) go to 800 - marker(node) = tag -c --------------------------------- -c use storage from eliminated nodes -c if necessary. -c --------------------------------- - 600 continue - if ( rloc .lt. rlmt ) go to 700 - link = - adjncy(rlmt) - rloc = xadj(link) - rlmt = xadj(link+1) - 1 - go to 600 - 700 continue - adjncy(rloc) = node - rloc = rloc + 1 - 800 continue - 900 continue - elmnt = llist(elmnt) - go to 300 - 1000 continue - if ( rloc .le. rlmt ) adjncy(rloc) = 0 -c -------------------------------------------------------- -c for each node in the reachable set, do the following ... -c -------------------------------------------------------- - link = mdnode - 1100 continue - istrt = xadj(link) - istop = xadj(link+1) - 1 - do 1700 i = istrt, istop - rnode = adjncy(i) - link = - rnode - if ( rnode ) 1100, 1800, 1200 - 1200 continue -c -------------------------------------------- -c if rnode is in the degree list structure ... -c -------------------------------------------- - pvnode = dbakw(rnode) - if ( pvnode .eq. 0 .or. - 1 pvnode .eq. (-maxint) ) go to 1300 -c ------------------------------------- -c then remove rnode from the structure. -c ------------------------------------- - nxnode = dforw(rnode) - if ( nxnode .gt. 0 ) dbakw(nxnode) = pvnode - if ( pvnode .gt. 0 ) dforw(pvnode) = nxnode - npv = - pvnode - if ( pvnode .lt. 0 ) dhead(npv) = nxnode - 1300 continue -c ---------------------------------------- -c purge inactive quotient nabors of rnode. -c ---------------------------------------- - jstrt = xadj(rnode) - jstop = xadj(rnode+1) - 1 - xqnbr = jstrt - do 1400 j = jstrt, jstop - nabor = adjncy(j) - if ( nabor .eq. 0 ) go to 1500 - if ( marker(nabor) .ge. tag ) go to 1400 - adjncy(xqnbr) = nabor - xqnbr = xqnbr + 1 - 1400 continue - 1500 continue -c ---------------------------------------- -c if no active nabor after the purging ... -c ---------------------------------------- - nqnbrs = xqnbr - jstrt - if ( nqnbrs .gt. 0 ) go to 1600 -c ----------------------------- -c then merge rnode with mdnode. -c ----------------------------- - qsize(mdnode) = qsize(mdnode) + qsize(rnode) - qsize(rnode) = 0 - marker(rnode) = maxint - dforw(rnode) = - mdnode - dbakw(rnode) = - maxint - go to 1700 - 1600 continue -c -------------------------------------- -c else flag rnode for degree update, and -c add mdnode as a nabor of rnode. -c -------------------------------------- - dforw(rnode) = nqnbrs + 1 - dbakw(rnode) = 0 - adjncy(xqnbr) = mdnode - xqnbr = xqnbr + 1 - if ( xqnbr .le. jstop ) adjncy(xqnbr) = 0 -c - 1700 continue - 1800 continue - return -c - end -c*************************************************************** -c*************************************************************** -c***** mmdupd ..... multiple minimum degree update ***** -c*************************************************************** -c*************************************************************** -c -c purpose - this routine updates the degrees of nodes -c after a multiple elimination step. -c -c input parameters - -c ehead - the beginning of the list of eliminated -c nodes (i.e., newly formed elements). -c neqns - number of equations. -c (xadj,adjncy) - adjacency structure. -c delta - tolerance value for multiple elimination. -c maxint - maximum machine representable (short) -c integer. -c -c updated parameters - -c mdeg - new minimum degree after degree update. -c (dhead,dforw,dbakw) - degree doubly linked structure. -c qsize - size of supernode. -c llist - working linked list. -c marker - marker vector for degree update. -c tag - tag value. -c -c*************************************************************** -c - subroutine mmdupd ( ehead, neqns, xadj, adjncy, delta, - 1 mdeg, dhead, dforw, dbakw, qsize, - 1 llist, marker, maxint, tag ) -c -c*************************************************************** -c - implicit none -c - integer*4 adjncy(1), dbakw(1) , dforw(1) , dhead(1) , - 1 llist(1) , marker(1), qsize(1) - integer*4 xadj(1) - integer*4 deg , deg0 , delta , ehead , elmnt , - 1 enode , fnode , i , iq2 , istop , - 1 istrt , j , jstop , jstrt , link , - 1 maxint, mdeg , mdeg0 , mtag , nabor , - 1 neqns , node , q2head, qxhead, tag -c -c*************************************************************** -c - mdeg0 = mdeg + delta - elmnt = ehead - 100 continue -c ------------------------------------------------------- -c for each of the newly formed element, do the following. -c (reset tag value if necessary.) -c ------------------------------------------------------- - if ( elmnt .le. 0 ) return - mtag = tag + mdeg0 - if ( mtag .lt. maxint ) go to 300 - tag = 1 - do 200 i = 1, neqns - if ( marker(i) .lt. maxint ) marker(i) = 0 - 200 continue - mtag = tag + mdeg0 - 300 continue -c --------------------------------------------- -c create two linked lists from nodes associated -c with elmnt: one with two nabors (q2head) in -c adjacency structure, and the other with more -c than two nabors (qxhead). also compute deg0, -c number of nodes in this element. -c --------------------------------------------- - q2head = 0 - qxhead = 0 - deg0 = 0 - link = elmnt - 400 continue - istrt = xadj(link) - istop = xadj(link+1) - 1 - do 700 i = istrt, istop - enode = adjncy(i) - link = - enode - if ( enode ) 400, 800, 500 -c - 500 continue - if ( qsize(enode) .eq. 0 ) go to 700 - deg0 = deg0 + qsize(enode) - marker(enode) = mtag -c ---------------------------------- -c if enode requires a degree update, -c then do the following. -c ---------------------------------- - if ( dbakw(enode) .ne. 0 ) go to 700 -c --------------------------------------- -c place either in qxhead or q2head lists. -c --------------------------------------- - if ( dforw(enode) .eq. 2 ) go to 600 - llist(enode) = qxhead - qxhead = enode - go to 700 - 600 continue - llist(enode) = q2head - q2head = enode - 700 continue - 800 continue -c -------------------------------------------- -c for each enode in q2 list, do the following. -c -------------------------------------------- - enode = q2head - iq2 = 1 - 900 continue - if ( enode .le. 0 ) go to 1500 - if ( dbakw(enode) .ne. 0 ) go to 2200 - tag = tag + 1 - deg = deg0 -c ------------------------------------------ -c identify the other adjacent element nabor. -c ------------------------------------------ - istrt = xadj(enode) - nabor = adjncy(istrt) - if ( nabor .eq. elmnt ) nabor = adjncy(istrt+1) -c ------------------------------------------------ -c if nabor is uneliminated, increase degree count. -c ------------------------------------------------ - link = nabor - if ( dforw(nabor) .lt. 0 ) go to 1000 - deg = deg + qsize(nabor) - go to 2100 - 1000 continue -c -------------------------------------------- -c otherwise, for each node in the 2nd element, -c do the following. -c -------------------------------------------- - istrt = xadj(link) - istop = xadj(link+1) - 1 - do 1400 i = istrt, istop - node = adjncy(i) - link = - node - if ( node .eq. enode ) go to 1400 - if ( node ) 1000, 2100, 1100 -c - 1100 continue - if ( qsize(node) .eq. 0 ) go to 1400 - if ( marker(node) .ge. tag ) go to 1200 -c ------------------------------------- -c case when node is not yet considered. -c ------------------------------------- - marker(node) = tag - deg = deg + qsize(node) - go to 1400 - 1200 continue -c ---------------------------------------- -c case when node is indistinguishable from -c enode. merge them into a new supernode. -c ---------------------------------------- - if ( dbakw(node) .ne. 0 ) go to 1400 - if ( dforw(node) .ne. 2 ) go to 1300 - qsize(enode) = qsize(enode) + - 1 qsize(node) - qsize(node) = 0 - marker(node) = maxint - dforw(node) = - enode - dbakw(node) = - maxint - go to 1400 - 1300 continue -c -------------------------------------- -c case when node is outmatched by enode. -c -------------------------------------- - if ( dbakw(node) .eq.0 ) - 1 dbakw(node) = - maxint - 1400 continue - go to 2100 - 1500 continue -c ------------------------------------------------ -c for each enode in the qx list, do the following. -c ------------------------------------------------ - enode = qxhead - iq2 = 0 - 1600 continue - if ( enode .le. 0 ) go to 2300 - if ( dbakw(enode) .ne. 0 ) go to 2200 - tag = tag + 1 - deg = deg0 -c --------------------------------- -c for each unmarked nabor of enode, -c do the following. -c --------------------------------- - istrt = xadj(enode) - istop = xadj(enode+1) - 1 - do 2000 i = istrt, istop - nabor = adjncy(i) - if ( nabor .eq. 0 ) go to 2100 - if ( marker(nabor) .ge. tag ) go to 2000 - marker(nabor) = tag - link = nabor -c ------------------------------ -c if uneliminated, include it in -c deg count. -c ------------------------------ - if ( dforw(nabor) .lt. 0 ) go to 1700 - deg = deg + qsize(nabor) - go to 2000 - 1700 continue -c ------------------------------- -c if eliminated, include unmarked -c nodes in this element into the -c degree count. -c ------------------------------- - jstrt = xadj(link) - jstop = xadj(link+1) - 1 - do 1900 j = jstrt, jstop - node = adjncy(j) - link = - node - if ( node ) 1700, 2000, 1800 -c - 1800 continue - if ( marker(node) .ge. tag ) - 1 go to 1900 - marker(node) = tag - deg = deg + qsize(node) - 1900 continue - 2000 continue - 2100 continue -c ------------------------------------------- -c update external degree of enode in degree -c structure, and mdeg (min deg) if necessary. -c ------------------------------------------- - deg = deg - qsize(enode) + 1 - fnode = dhead(deg) - dforw(enode) = fnode - dbakw(enode) = - deg - if ( fnode .gt. 0 ) dbakw(fnode) = enode - dhead(deg) = enode - if ( deg .lt. mdeg ) mdeg = deg - 2200 continue -c ---------------------------------- -c get next enode in current element. -c ---------------------------------- - enode = llist(enode) - if ( iq2 .eq. 1 ) go to 900 - go to 1600 - 2300 continue -c ----------------------------- -c get next element in the list. -c ----------------------------- - tag = mtag - elmnt = llist(elmnt) - go to 100 -c - end -c*************************************************************** -c*************************************************************** -c***** mmdnum ..... multi minimum degree numbering ***** -c*************************************************************** -c*************************************************************** -c -c purpose - this routine performs the final step in -c producing the permutation and inverse permutation -c vectors in the multiple elimination version of the -c minimum degree ordering algorithm. -c -c input parameters - -c neqns - number of equations. -c qsize - size of supernodes at elimination. -c -c updated parameters - -c invp - inverse permutation vector. on input, -c if qsize(node)=0, then node has been merged -c into the node -invp(node); otherwise, -c -invp(node) is its inverse labelling. -c -c output parameters - -c perm - the permutation vector. -c -c*************************************************************** -c - subroutine mmdnum ( neqns, perm, invp, qsize ) -c -c*************************************************************** -c - implicit none -c - integer*4 invp(1) , perm(1) , qsize(1) - integer*4 father, neqns , nextf , node , nqsize, - 1 num , root -c -c*************************************************************** -c - do 100 node = 1, neqns - nqsize = qsize(node) - if ( nqsize .le. 0 ) perm(node) = invp(node) - if ( nqsize .gt. 0 ) perm(node) = - invp(node) - 100 continue -c ------------------------------------------------------ -c for each node which has been merged, do the following. -c ------------------------------------------------------ - do 500 node = 1, neqns - if ( perm(node) .gt. 0 ) go to 500 -c ----------------------------------------- -c trace the merged tree until one which has -c not been merged, call it root. -c ----------------------------------------- - father = node - 200 continue - if ( perm(father) .gt. 0 ) go to 300 - father = - perm(father) - go to 200 - 300 continue -c ----------------------- -c number node after root. -c ----------------------- - root = father - num = perm(root) + 1 - invp(node) = - num - perm(root) = num -c ------------------------ -c shorten the merged tree. -c ------------------------ - father = node - 400 continue - nextf = - perm(father) - if ( nextf .le. 0 ) go to 500 - perm(father) = - root - father = nextf - go to 400 - 500 continue -c ---------------------- -c ready to compute perm. -c ---------------------- - do 600 node = 1, neqns - num = - invp(node) - invp(node) = num - perm(num) = node - 600 continue - return -c - end //GO.SYSIN DD hopdm.src/mmd.f echo hopdm.src/mycode.f 1>&2 sed >hopdm.src/mycode.f <<'//GO.SYSIN DD hopdm.src/mycode.f' 's/^-//' -C******************************************************************* -C ** MYCODE ... ENCODE THE 8-CHARACTER NAME INTO AN INTEGER ** -C******************************************************************* -C - SUBROUTINE MYCODE(IOERR,NAME,KCODE,M) -C -C -C *** PARAMETERS - CHARACTER*9 NAME - INTEGER*4 IOERR,KCODE,M -C -C -C *** LOCAL VARIABLES - INTEGER*4 IPOS - CHARACTER*100 BUFFER -C -C -C *** PARAMETERS DESCRIPTION -C NAME 8-character name (row or column name). -C KCODE Integer code associated to the name. -C M The number of rows (or columns) in matrix A. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: October 14, 1994 -C -C -C *** BODY OF (MYCODE) *** -C -C - KCODE=0 - DO 100 IPOS=1,8 - KCODE=KCODE+ICHAR(NAME(IPOS:IPOS))*IPOS -C WRITE(BUFFER,101) IPOS,NAME(IPOS:IPOS) -C 101 FORMAT(1X,'ipos=',I2,' char=',A1) -C CALL MYWRT(IOERR,BUFFER) - 100 CONTINUE - KCODE=MOD(KCODE,M)+1 -C WRITE(BUFFER,102) NAME,KCODE -C 102 FORMAT(1X,' name=',A8,' has a code=',I6) -C CALL MYWRT(IOERR,BUFFER) - RETURN -C -C -C *** LAST CARD OF (MYCODE) *** - END //GO.SYSIN DD hopdm.src/mycode.f echo hopdm.src/mytime.f 1>&2 sed >hopdm.src/mytime.f <<'//GO.SYSIN DD hopdm.src/mytime.f' 's/^-//' -C**************************************************** -C ** MYWRT ... WRITE A RECORD FROM THE BUFFER ** -C**************************************************** -C - SUBROUTINE MYTIME(JOB,IOLOG) -C -C *** PARAMETERS - INTEGER*4 JOB,IOLOG,ISYSTM -C -C -C For DOS, the integer array IDATIM is used by subroutine TIMEPF -C to store the current date, time and elapsed time. -C For UNIX, the real scalar ELTIME is used by subroutine DATTIM -C to store the elapsed time. -C -C Only for DOS - COMMON/IDTM/ IDATIM - INTEGER*4 IDATIM(9) -C -C Only for UNIX - COMMON /TIME/ ELTIME - REAL ELTIME(3) -C -C -C *** PARAMETERS DESCRIPTION -C JOB is an integer input variable: -C 0 initialize the clock; -C 1 print the elapsed time. -C IOLOG non-negative output file number. -C ISYSTM system indicator: -C 0 DOS; -C 1 UNIX. -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: March 29, 1995 -C -C -C -C -C *** BODY OF (MYTIME) *** -C - ISYSTM=1 - IF(ISYSTM.EQ.0) THEN -C Here for DOS - CALL TIMEPF(JOB,IOLOG,IDATIM) - ELSE -C Here for UNIX - CALL DATTIM(JOB,IOLOG,ELTIME) - ENDIF - RETURN -C -C *** LAST CARD OF (MYTIME) *** - END //GO.SYSIN DD hopdm.src/mytime.f echo hopdm.src/mywrt.f 1>&2 sed >hopdm.src/mywrt.f <<'//GO.SYSIN DD hopdm.src/mywrt.f' 's/^-//' -C**************************************************** -C ** MYWRT ... WRITE A RECORD FROM THE BUFFER ** -C**************************************************** -C - SUBROUTINE MYWRT(IOLOG,BUFFER) -C -C -C *** PARAMETERS - INTEGER*4 IOLOG - CHARACTER*78 BUFFER -C -C -C *** PARAMETER DESCRIPTION -C IOLOG Output unit number where the message is to be written. -C BUFFER Message to be written. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: October 30, 1992 -C -C -C -C -C -C *** BODY OF (MYWRT) *** -C - WRITE(IOLOG,100) BUFFER - 100 FORMAT(A78) -C - RETURN -C -C *** LAST CARD OF (MYWRT) *** - END //GO.SYSIN DD hopdm.src/mywrt.f echo hopdm.src/numfct.f 1>&2 sed >hopdm.src/numfct.f <<'//GO.SYSIN DD hopdm.src/numfct.f' 's/^-//' -C************************************************************ -C **** NUMFCT ... NUMERICAL FACTORIZATION **** -C************************************************************ -C - SUBROUTINE NUMFCT(LCOEFF,LCLPTS,LRWNBS,LDIAG,LDSQRT, - X MAXNZL,MAXM,M,MKSQRT, - X HEADER,LINKFD,LINKBK,RSTART,DPWORK,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXNZL,MAXM,M,MKSQRT,IOERR - DOUBLE PRECISION LCOEFF(*),LDIAG(MAXM),LDSQRT(MAXM),DPWORK(MAXM) - INTEGER*4 LCLPTS(MAXM+1),RSTART(MAXM) -C -C *** The following arrays can be half-length integer. - INTEGER*2 LRWNBS(MAXNZL) - INTEGER*2 HEADER(MAXM),LINKFD(MAXM),LINKBK(MAXM) -C -C -C *** LOCAL VARIABLES - INTEGER*4 IROW,IRWACT,IX,JCOL,K,KBEG,KEND,LENROW,NEXT,NXTACT - INTEGER*4 IRWMAX,IRWMIN,I,IRMV - DOUBLE PRECISION DP,ELTMAX,PVCAND,CGROW,RGROW,SMALLP,TAUADD - CHARACTER*100 BUFFER -C -C -C *** COMMON ARREAS -C Cholesky factorization parameters. - COMMON /CHFCT/ CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN,IDNSRW - DOUBLE PRECISION CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN - INTEGER*4 IDNSRW -C -C Additional Cholesky fact. parameters (interface to HYBRID). - COMMON /CHHYB/ RO,FLOPS,IREG,NZCHL,RTCD - DOUBLE PRECISION RO,FLOPS - INTEGER*4 IREG,NZCHL,RTCD -C -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C MAXM Maximum row dimension of the LP constraint matrix. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C MKSQRT Parameter indicating if square roots of LDIAG are to be -C computed: -C 0 no square roots necessary; -C 1 compute square roots of diagonal matrix. -C LCOEFF Off-diagonal nonzero coefficients of A*THETA*Atransp -C matrix (fill-in positions are zeroed). -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C LDIAG Diagonal elements of A*THETA*Atransp. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C LCOEFF Off-diagonal nonzero coefficients of Cholesky matrix. -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C LDIAG Diagonal elements of Cholesky factor. -C LDSQRT Square roots of the diagonal elements of Cholesky factor. -C -C WORK ARRAYS: -C HEADER Header of the doubly linked lists of rows that have their -C next active off-diagonal entries in the same columns. -C LINKFD Forward linked lists. -C LINKBK Backward linked lists. -C RSTART Pointer to the next active off-diagonal entry -C of a given row. -C DPWORK Temporary work array. -C -C -C -C *** Some parameters used by the Cholesky decomposition. -C CSMALL During the Cholesky decomposition all numbers smaller -C than CSMALL (in the absolute value) are presumed -C to be numerical errors only and are set to zero. -C CSMALL is initialized to the computer relative precision. -C PIVTOL The tolerance for pivots in Cholesky factor L. -C Pivots smaller than PIVTOL are rejected and the matrix -C is presumed to be singular. The factorization is not -C terminated, however. Pivot element is replaced with -C a small positive value. -C TAU To avoid unpredicted exit from the Cholesky decomposition -C a small multiple of the identity matrix is added to the -C A*THETA*Atransp matrix before its factorization. -C It has a value equal to TAU times the largest diagonal -C element of the matrix to be decomposed. TAU is -C initialized to the value of computer relative precision. -C DENSE Threshold value for a column to be treated as dense. -C IDNSRW Index of row of the Cholesky factor for which a switch -C is made to dense code. -C IREG Regularization: -C 0 add RO to all diagonal elements and increase small -C pivots to TAUADD (used by HYBRID); -C 1 increase small pivots to TAUADD (used by HYBRID); -C -1 increase very small pivots to TAUADD (used by HOPDM). -C RO Regularization parameter. -C -C -C -C *** SUBROUTINES CALLED: -C MYWRT,DABS,DSQRT,DCOPY,DAXPY -C -C -C *** PURPOSE: -C This routine implements the numerical factorization -C for a symmetric positive definite matrix. -C It decomposes positive definite symmetric martix -C to the form: L * D * Ltransp. -C -C -C *** NOTES: -C 1. This routine follows Duff et al. (1989) description -C of the Cholesky factorization. It thus reflects -C the multifrontal approach to it. -C 2. The lower right corner of the Cholesky factor is stored -C as a dense matrix (double addressing is thus avoided). -C IDNSRW (from CHFACT common block) is a number of the -C first row of a dense window. -C -C -C *** REFERENCES: -C Duff I.S., Erisman A.M., Reid J.K. (1989). Direct methods -C for sparse matrices, Clarendon Press, Oxford 1989, -C chapters 3 and 10. -C Gondzio J. (1993). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization 27, pp. 121-140. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: April 15, 1991 -C Last modified: June 10, 1994 -C -C -C -C *** BODY OF (NUMFCT) *** -C -C -C -C -C Find the largest and the smallest diagonal entries -C of A*THETA*Atransp. - IX=1 - IRWMAX=1 - IRWMIN=1 - DP=DABS(LDIAG(1)) - PIVMAX=DP - PIVMIN=DP - DO 40 IROW=2,M - DP=LDIAG(IROW) - IF(DP.GT.PIVMAX) THEN - PIVMAX=DP - IRWMAX=IROW - ENDIF - IF(DP.LT.PIVMIN) THEN - PIVMIN=DP - IRWMIN=IROW - ENDIF - 40 CONTINUE -C -C WRITE(BUFFER,41) IRWMAX,LDIAG(IRWMAX) -C 41 FORMAT(1X,'NUMFCT: Max. diag. elt in row ',I6,', Dii=',1PD12.4) -C CALL MYWRT(IOERR,BUFFER) -C WRITE(BUFFER,42) IRWMIN,LDIAG(IRWMIN) -C 42 FORMAT(1X,'NUMFCT: Min. diag. elt in row ',I6,', Dii=',1PD12.4) -C CALL MYWRT(IOERR,BUFFER) -C -C -C -C Set the tolerance for acceptable pivot element. -C Pivot elements smaller than PIVTOL will be replaced with TAUADD. -C - IF(IREG.EQ.-1) THEN -C *** Here for HOPDM: correct only very small pivots of A*Atransp. - TAUADD=TAU*LDIAG(IRWMAX) - PIVTOL=1.0D-10*TAUADD - ENDIF -C - IF(IREG.GE.0) THEN -C *** Here for HYBRID: correct too small pivots of A*Atransp. - TAUADD=TAU*LDIAG(IRWMAX) - PIVTOL=TAUADD - IF(IREG.EQ.0) THEN -C Add regularizing term to A*Atransp (proximal algorithm). -C DO 60 IROW=1,M -C LDIAG(IROW)=LDIAG(IROW)+RO -C 60 CONTINUE - ENDIF -C -C Modification: June 10, 1994 for proximal point algorithm. - PIVTOL=1.0D-10*TAUADD -C - ENDIF - SMALLP=0.999999D0*PIVTOL -C WRITE(BUFFER,61) PIVTOL,TAUADD -C 61 FORMAT(1X,'NUMFCT: PIVTOL=',1PD12.4,' TAUADD=',1PD12.4) -C CALL MYWRT(IOERR,BUFFER) -C -C -C -C Zero HEADER and RSTART arrays. - DO 100 IROW=1,M - HEADER(IROW)=0 - RSTART(IROW)=0 - 100 CONTINUE -C -C -C Set the doubly linked lists of rows that have the next -C subdiagonal entry in the same columns. Recall that LCLPTS(i) -C indicates the first off-diagonal entry of row i. -C Save also the locations of these elements in RSTART array. - DO 200 IROW=1,IDNSRW-1 - KBEG=LCLPTS(IROW) - KEND=LCLPTS(IROW+1)-1 - IF(KBEG.GT.KEND) GO TO 200 - JCOL=LRWNBS(KBEG) - NEXT=HEADER(JCOL) - LINKFD(IROW)=NEXT - HEADER(JCOL)=IROW - IF(NEXT.GT.0) LINKBK(NEXT)=IROW - LINKBK(IROW)=-JCOL - RSTART(IROW)=KBEG - 200 CONTINUE -C -C -C -C -C -C The first main loop begins here. -C Loop over SPARSE rows of Cholesky factor. -C The contents of a given row IROW are first unpacked into -C a full array DPWORK. All rows that have an off-diagonal -C entry in column IROW are then scanned. Their contributions -C are added to DPWORK array. Having completed the above -C calculations the elements of DPWORK array are packed back -C to the data structures for Cholesky factor. All the rows -C involved in a pivotal step (excluding the pivotal one) -C are added to the linked lists determined by their next -C off-diagonal entry. -C - DO 1000 IROW=1,IDNSRW-1 -C -C -C Unpack row IROW of Cholesky matrix to a work array. - KBEG=LCLPTS(IROW) - KEND=LCLPTS(IROW+1)-1 - DO 300 K=KBEG,KEND - JCOL=LRWNBS(K) - DPWORK(JCOL)=LCOEFF(K) - 300 CONTINUE -C -C -C Scan all rows of Cholesky matrix involved in this pivotal step -C (i.e. those which have the next active element in column IROW). -C IRWACT is a number of such an active row. -C NXTACT is a number of the next active row. -C ELTMAX is a maximum element in an actvive row. - IRWACT=HEADER(IROW) - ELTMAX=0.0D0 - 350 IF(IRWACT.EQ.0) GO TO 500 - NXTACT=LINKFD(IRWACT) - KBEG=RSTART(IRWACT) - KEND=LCLPTS(IRWACT+1)-1 - IF(DABS(LCOEFF(KBEG)).GE.ELTMAX) THEN - ELTMAX=DABS(LCOEFF(KBEG)) - ENDIF - DP=LDIAG(IRWACT)*LCOEFF(KBEG) -C LDIAG(IROW)=LDIAG(IROW)-DP*LCOEFF(KBEG) - DO 400 K=KBEG+1,KEND - JCOL=LRWNBS(K) - DPWORK(JCOL)=DPWORK(JCOL)-DP*LCOEFF(K) - 400 CONTINUE -C -C -C Here if the contribution of row IRWACT has been added. -C Find the next active entry of this row (i.e. JCOL) -C and add the row to the appropriate linked list. - IF(KBEG+1.GT.KEND) GO TO 450 - JCOL=LRWNBS(KBEG+1) - NEXT=HEADER(JCOL) - HEADER(JCOL)=IRWACT - LINKFD(IRWACT)=NEXT - LINKBK(IRWACT)=-JCOL - IF(NEXT.GT.0) LINKBK(NEXT)=IRWACT -C -C Save the position of the next active entry. - RSTART(IRWACT)=KBEG+1 -C -C -C Continue the scanning of all rows involved in this pivotal step. - 450 IRWACT=NXTACT - GO TO 350 -C -C -C -C Here if the pivot row is fully determined. -C Pack it back to the data structures for Cholesky factor. - 500 KBEG=LCLPTS(IROW) - KEND=LCLPTS(IROW+1)-1 - IF(LDIAG(IROW).GE.TAUADD) GO TO 800 -C -C -C Handling small pivots. - IF(LDIAG(IROW).LE.PIVTOL) LDIAG(IROW)=PIVTOL -C -C Analyse growth factor in a row. - IRMV=0 - RGROW=ELTMAX/LDIAG(IROW) - IF(RGROW*ELTMAX.GE.1.0D+16) THEN - DP=ELTMAX*ELTMAX - IF(LDIAG(IROW).LT.1.D-9*DP) LDIAG(IROW)=1.D-9*DP - IF(RGROW.GE.1.0D+12) THEN - DP=LDIAG(IROW) - IF(DP.LT.1.D-6*ELTMAX) LDIAG(IROW)=1.D-6*ELTMAX - ENDIF - IF(RGROW.GE.1.0D+14) THEN - LDIAG(IROW)=1.D-4*ELTMAX -C IRMV=1 - ENDIF - WRITE(BUFFER,701) IROW,ELTMAX,RGROW,LDIAG(IROW) - 701 FORMAT(1X,'rw=',I6,' eltmax=',1PD12.4,' rgr=',1PD12.4, - X ' corr. pvt=',1PD12.4) - CALL MYWRT(IOERR,BUFFER) - ENDIF - RGROW=ELTMAX/LDIAG(IROW) - IF(RGROW*ELTMAX.GE.1.0D+12) THEN - LDIAG(IROW)=1.D-12*RGROW*ELTMAX*LDIAG(IROW) - IF(RGROW*ELTMAX.GE.1.0D+14) IRMV=1 - WRITE(BUFFER,702) IROW,ELTMAX*RGROW,LDIAG(IROW) - 702 FORMAT(1X,'rw=',I6,' scnd corr, eltmax*rgr=',1PD12.4, - X ' corr. pvt=',1PD12.4) - CALL MYWRT(IOERR,BUFFER) - RGROW=ELTMAX/LDIAG(IROW) - ENDIF -C -C Analyse growth factor in a column. Choose the minimum value -C of the pivot that keeps AAt positive definite. - CGROW=0.0D0 - PVCAND=0.0D0 - DO 720 K=KBEG,KEND - JCOL=LRWNBS(K) - IF(DABS(DPWORK(JCOL)).GE.CGROW) CGROW=DABS(DPWORK(JCOL)) - DP=DPWORK(JCOL)*DPWORK(JCOL)/LDIAG(JCOL) - IF(DP.GE.PVCAND) PVCAND=DP - 720 CONTINUE - IF(PVCAND.GE.0.999D0*LDIAG(IROW)) THEN - WRITE(BUFFER,721) IROW,LDIAG(IROW),PVCAND - 721 FORMAT(1X,'irow=',I6,' Dii=',1PD16.8, - X ' pivot candidate p=',1PD16.8) - CALL MYWRT(IOERR,BUFFER) - IF(PVCAND.GE.0.999999D0*LDIAG(IROW)) THEN - IF(PVCAND.GE.1.001D0*LDIAG(IROW)) THEN - IF(LDIAG(IROW).LT.TAUADD) LDIAG(IROW)=TAUADD - IRMV=1 - ELSE - LDIAG(IROW)=1.000002*PVCAND - ENDIF - ENDIF - ENDIF - IF(IRMV.EQ.1) THEN - DP=LDIAG(IROW) - WRITE(BUFFER,781) IROW,LDIAG(IROW),RGROW*CGROW/DP - 781 FORMAT(1X,'rw=',I6,' Dii=',1PD12.4, - X ' column removed, growth=',1PD12.4) - CALL MYWRT(IOERR,BUFFER) - DO 780 K=KBEG,KEND - JCOL=LRWNBS(K) - DPWORK(JCOL)=0.0D0 - 780 CONTINUE - ENDIF - 800 LDIAG(IROW)=LDIAG(IROW)+RO - DP=1.0/LDIAG(IROW) - DO 900 K=KBEG,KEND - JCOL=LRWNBS(K) - LCOEFF(K)=DP*DPWORK(JCOL) - LDIAG(JCOL)=LDIAG(JCOL)-DP*DPWORK(JCOL)*DPWORK(JCOL) - IF(LDIAG(JCOL).LE.SMALLP) LDIAG(JCOL)=SMALLP - 900 CONTINUE -C -C -C -C End of main loop. - 1000 CONTINUE -C -C -C -C -C -C The second main loop begins here. -C Loop over DENSE rows of Cholesky factor. -C The contents of a given row IROW are first unpacked into -C a full array DPWORK. All rows that have an off-diagonal -C entry in column IROW are then scanned. Their contributions -C are added to DPWORK array. Having completed the above -C calculations the elements of DPWORK array are packed back -C to the data structures for Cholesky factor. All the sparse rows -C involved in a pivotal step are added to the linked lists -C determined by their next off-diagonal entry. -C - DO 2000 IROW=IDNSRW,M -C -C -C Unpack row IROW of Cholesky matrix to a work array. - KBEG=LCLPTS(IROW) - LENROW=LCLPTS(IROW+1)-KBEG -C CALL DCOPY(LCOEFF(KBEG),DPWORK(IROW+1),LENROW) - call dcopy(LENROW,LCOEFF(KBEG),ix,DPWORK(IROW+1),ix) -C -C -C Scan all rows of Cholesky matrix involved in this pivotal step -C (i.e. those which have the next active element in column IROW). -C -C -C First, take account of sparse rows. -C IRWACT is a number of such an active row. -C NXTACT is a number of the next active row. -C ELTMAX is a maximum element in an actvive row. - IRWACT=HEADER(IROW) - ELTMAX=0.0D0 - 1350 IF(IRWACT.EQ.0) GO TO 1500 - NXTACT=LINKFD(IRWACT) - KBEG=RSTART(IRWACT) - KEND=LCLPTS(IRWACT+1)-1 - IF(DABS(LCOEFF(KBEG)).GE.ELTMAX) THEN - ELTMAX=DABS(LCOEFF(KBEG)) - ENDIF - DP=LDIAG(IRWACT)*LCOEFF(KBEG) -C LDIAG(IROW)=LDIAG(IROW)-DP*LCOEFF(KBEG) - DO 1400 K=KBEG+1,KEND - JCOL=LRWNBS(K) - DPWORK(JCOL)=DPWORK(JCOL)-DP*LCOEFF(K) - 1400 CONTINUE -C -C -C Here if the contribution of row IRWACT has been added. -C Find the next active entry of this row (i.e. JCOL) -C and add the row to the appropriate linked list. - IF(KBEG+1.GT.KEND) GO TO 1450 - JCOL=LRWNBS(KBEG+1) - NEXT=HEADER(JCOL) - HEADER(JCOL)=IRWACT - LINKFD(IRWACT)=NEXT - LINKBK(IRWACT)=-JCOL - IF(NEXT.GT.0) LINKBK(NEXT)=IRWACT -C -C Save the position of the next active entry. - RSTART(IRWACT)=KBEG+1 -C -C -C Continue the scanning of all rows involved in this pivotal step. - 1450 IRWACT=NXTACT - GO TO 1350 -C -C -C Take account of dense rows. - 1500 DO 1600 IRWACT=IDNSRW,IROW-1 - KBEG=LCLPTS(IRWACT+1)-LENROW-1 - IF(DABS(LCOEFF(KBEG)).GE.ELTMAX) THEN - ELTMAX=DABS(LCOEFF(KBEG)) - ENDIF - DP=LDIAG(IRWACT)*LCOEFF(KBEG) -C LDIAG(IROW)=LDIAG(IROW)-DP*LCOEFF(KBEG) -C CALL DAXPY(LCOEFF(KBEG+1),DPWORK(IROW+1),LENROW,-DP) - call daxpy(LENROW,-DP,LCOEFF(KBEG+1),ix,DPWORK(IROW+1),ix) - 1600 CONTINUE -C -C -C -C Here if the pivot row is fully determined. -C Pack it back to the data structures for Cholesky factor. - KBEG=LCLPTS(IROW) - LENROW=LCLPTS(IROW+1)-KBEG - KBEG=KBEG-1 - IF(LDIAG(IROW).GE.TAUADD) GO TO 1800 -C -C -C Handling small pivots. - IF(LDIAG(IROW).LE.PIVTOL) LDIAG(IROW)=PIVTOL -C -C Analyse growth factor in a row. - IRMV=0 - RGROW=ELTMAX/LDIAG(IROW) - IF(RGROW*ELTMAX.GE.1.0D+16) THEN - DP=ELTMAX*ELTMAX - IF(LDIAG(IROW).LT.1.D-9*DP) LDIAG(IROW)=1.D-9*DP - IF(RGROW.GE.1.0D+12) THEN - DP=LDIAG(IROW) - IF(DP.LT.1.D-6*ELTMAX) LDIAG(IROW)=1.D-6*ELTMAX - ENDIF - IF(RGROW.GE.1.0D+14) THEN - LDIAG(IROW)=1.D-4*ELTMAX -C IRMV=1 - ENDIF - WRITE(BUFFER,1701) IROW,ELTMAX,RGROW,LDIAG(IROW) - 1701 FORMAT(1X,'rw=',I6,' eltmax=',1PD12.4,' rgr=',1PD12.4, - X ' corr. pvt=',1PD12.4) - CALL MYWRT(IOERR,BUFFER) - ENDIF - RGROW=ELTMAX/LDIAG(IROW) - IF(RGROW*ELTMAX.GE.1.0D+12) THEN - LDIAG(IROW)=1.D-12*RGROW*ELTMAX*LDIAG(IROW) - IF(RGROW*ELTMAX.GE.1.0D+14) IRMV=1 - WRITE(BUFFER,1702) IROW,ELTMAX*RGROW,LDIAG(IROW) - 1702 FORMAT(1X,'rw=',I6,' scnd corr, eltmax*rgr=',1PD12.4, - X ' corr. pvt=',1PD12.4) - CALL MYWRT(IOERR,BUFFER) - RGROW=ELTMAX/LDIAG(IROW) - ENDIF -C -C Analyse growth factor in a column. - CGROW=0.0D0 - PVCAND=0.0D0 - DO 1720 I=1,LENROW - JCOL=IROW+I - IF(DABS(DPWORK(JCOL)).GE.CGROW) CGROW=DABS(DPWORK(JCOL)) - DP=DPWORK(JCOL)*DPWORK(JCOL)/LDIAG(JCOL) - IF(DP.GE.PVCAND) PVCAND=DP - 1720 CONTINUE - IF(PVCAND.GE.0.999D0*LDIAG(IROW)) THEN - WRITE(BUFFER,1721) IROW,LDIAG(IROW),PVCAND - 1721 FORMAT(1X,'irow=',I6,' Dii=',1PD16.8, - X ' pivot candidate p=',1PD16.8) - CALL MYWRT(IOERR,BUFFER) - IF(PVCAND.GE.0.999999D0*LDIAG(IROW)) THEN - IF(PVCAND.GE.1.001D0*LDIAG(IROW)) THEN - IF(LDIAG(IROW).LT.TAUADD) LDIAG(IROW)=TAUADD - IRMV=1 - ELSE - LDIAG(IROW)=1.000002*PVCAND - ENDIF - ENDIF - ENDIF - IF(IRMV.EQ.1) THEN - DP=LDIAG(IROW) - WRITE(BUFFER,1781) IROW,LDIAG(IROW),RGROW*CGROW/DP - 1781 FORMAT(1X,'rw=',I6,' Dii=',1PD12.4, - X ' column removed, growth=',1PD12.4) - CALL MYWRT(IOERR,BUFFER) - DO 1780 I=1,LENROW - JCOL=IROW+I - DPWORK(JCOL)=0.0D0 - 1780 CONTINUE - ENDIF - 1800 LDIAG(IROW)=LDIAG(IROW)+RO - DP=1.0/LDIAG(IROW) - DO 1900 I=1,LENROW - JCOL=IROW+I - K=KBEG+I - LCOEFF(K)=DP*DPWORK(JCOL) - LDIAG(JCOL)=LDIAG(JCOL)-DP*DPWORK(JCOL)*DPWORK(JCOL) - IF(LDIAG(JCOL).LE.SMALLP) LDIAG(JCOL)=SMALLP - 1900 CONTINUE -C -C -C -C End of main loop. - 2000 CONTINUE - IF(LDIAG(M).LE.TAUADD) THEN - RGROW=ELTMAX/LDIAG(M) - WRITE(BUFFER,2001) LDIAG(M),RGROW - 2001 FORMAT(1X,'last pivot=',1PD12.4,' rgr=',1PD12.4) - CALL MYWRT(IOERR,BUFFER) - IF(RGROW.GE.1.0D+10) THEN - IF(LDIAG(M).LT.1.D-10*ELTMAX) LDIAG(M)=1.D-10*ELTMAX - ENDIF - ENDIF -C -C -C -C -C -C Find the largest and the smallest diagonal entries -C of the Cholesky factor. - IRWMAX=1 - IRWMIN=1 - DP=DABS(LDIAG(1)) - PIVMAX=DP - PIVMIN=DP - DO 5200 IROW=2,M - DP=DABS(LDIAG(IROW)) - IF(DP.GT.PIVMAX) THEN - PIVMAX=DP - IRWMAX=IROW - ENDIF - IF(DP.LT.PIVMIN) THEN - PIVMIN=DP - IRWMIN=IROW - ENDIF - 5200 CONTINUE -C - WRITE(BUFFER,5201) IRWMAX,LDIAG(IRWMAX) - 5201 FORMAT(1X,'NUMFCT: Max. pivot in row ',I6,', Dii=',1PD12.4) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,5202) IRWMIN,LDIAG(IRWMIN) - 5202 FORMAT(1X,'NUMFCT: Min. pivot in row ',I6,', Dii=',1PD12.4) - CALL MYWRT(IOERR,BUFFER) -C -C -C -C Find the largest off-diagonal element of the Cholesky factor. -C DP=0.0 -C DO 5300 K=1,LCLPTS(M+1)-1 -C IF(DABS(LCOEFF(K)).GT.DP) DP=DABS(LCOEFF(K)) -C5300 CONTINUE -C WRITE(BUFFER,5301) DP -C5301 FORMAT(1X,'NUMFCT: Max. elt in L=',1PD12.4) -C CALL MYWRT(IOERR,BUFFER) -C -C -C -C Compute the square roots of diagonal elements if necessary. - IF(MKSQRT.EQ.0) GO TO 5500 - DO 5400 IROW=1,M - LDSQRT(IROW)=DSQRT(LDIAG(IROW)) - 5400 CONTINUE - 5500 CONTINUE -C -C -C -C -C -C - RETURN -C -C -C -C Here to write error message. -C9000 WRITE(BUFFER,9001) IROW,LDIAG(IROW) -C9001 FORMAT(1X,'NUMFCT ERROR: Diagonal entry of row ',I6, -C X ' is too small ',D12.4) -C CALL ERRWRT(IOERR,BUFFER) -C STOP -C -C -C *** LAST CARD OF (NUMFCT) *** - END //GO.SYSIN DD hopdm.src/numfct.f echo hopdm.src/pcchck.f 1>&2 sed >hopdm.src/pcchck.f <<'//GO.SYSIN DD hopdm.src/pcchck.f' 's/^-//' -C***************************************************************** -C *** PCCHCK ... CHECK FEASIBILITY OF THE CURRENT COLUTION *** -C *** PREDICTOR-CORRECTOR PRIMAL-DUAL METHOD *** -C***************************************************************** -C - SUBROUTINE PCCHCK(MAXM,MAXN,M,N,IOERR, - X PRMAXB,PRMAXU,DLMAXC, - X VUSED,VBNDED,XIB,XIC,XIU) -C -C -C *** PARAMETERS - INTEGER*4 MAXM,MAXN,M,N,IOERR - DOUBLE PRECISION PRMAXB,PRMAXU,DLMAXC - LOGICAL VUSED(MAXN),VBNDED(MAXN) - DOUBLE PRECISION XIB(M),XIC(N),XIU(N) -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,J - DOUBLE PRECISION DP - CHARACTER*100 BUFFER -C -C -C *** PARAMETERS DESCRIPTION -C ON INPUT: -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C N Number of columns of the LP constraint matrix. -C VUSED An indicator if a variable is active in the optimization -C process: -C .TRUE. active variable; -C .FALSE. FIXED variable. -C VBNDED An indicator if a variable has an UPPER bound: -C .TRUE. UPPER bounded variable; -C .FALSE. UNBOUNDED variable; -C XIB Violation of primal constraints, i.e. b - A * x -C XIC Violation of dual constraints, i.e. c - At*y - z + w -C XIU Violation of variable bounds, i.e. UPBND - x - s -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C ON OUTPUT: -C ERRB max{|xib(i)|:i=1,...,m}. -C ERRU max{|xiu(j)|:i=1,...,n}. -C ERRC max{|xic(j)|:j=1,...,n}. -C -C -C *** LOCAL VARIABLES DESCRIPTION -C -C -C *** SUBROUTINES CALLED: -C DABS -C -C -C *** PURPOSE: -C This routine checks the primal and dual feasibility -C of the current solution. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, -C Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: November 11, 1993 -C -C -C *** BODY OF (PCCHCK) *** -C -C -C PRMAXB=max{|xib(i)|:i=1,...,m} -C XIB: = b - A * x -C - PRMAXB=0d0 - DO 100 I=1,M - DP=DABS(XIB(I)) - IF(DP.GT.PRMAXB) PRMAXB=DP - 100 CONTINUE -C -C -C PRMAXU=max{|xiu(j)|:j=1,...,n} -C XIU: = UPBND - x - s -C -C DLMAXC=max{|xic(j)|:j=1,...,n} -C XIC: = c - At*y - z + w -C - PRMAXU=0d0 - DLMAXC=0d0 - DO 200 J=1,N - IF(VUSED(J)) THEN - DP=DABS(XIC(J)) - IF(DP.GT.DLMAXC) DLMAXC=DP - IF(VBNDED(J)) THEN - DP=DABS(XIU(J)) - IF(DP.GT.PRMAXU) PRMAXU=DP - ENDIF - ENDIF - 200 CONTINUE -C -C - WRITE(BUFFER,201) PRMAXB,PRMAXU,DLMAXC - 201 FORMAT(1X,'PCCHCK: ||A*x-b||=',1PD9.3, - X ' ||x+s-u||=',1PD9.3,' ||At*y+z-w-c||=',1PD9.3) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C -C - RETURN -C -C -C *** LAST CARD OF (PCCHCK) *** - END //GO.SYSIN DD hopdm.src/pcchck.f echo hopdm.src/pcdir.f 1>&2 sed >hopdm.src/pcdir.f <<'//GO.SYSIN DD hopdm.src/pcdir.f' 's/^-//' -C************************************************************* -C *** PCDIR ... COMPUTE THE STEP DIRECTION *** -C *** PREDICTOR-CORRECTOR PRIMAL-DUAL METHOD *** -C************************************************************* -C - SUBROUTINE PCDIR(IDIR,BARR,OLDBAR,ALPHAP,ALPHAD,SMALLX, - X MAXM,MAXN,MAXNZA,MAXNZL,M,N,ITREF,IALARM, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X LCOEFF,LCLPTS,LRWNBS,LDIAG,LDSQRT, - X STAVAR,VUSED,VBNDED,THETA,XIB,XIC,XIU,DDD,GGG,HHH,FNEW, - X X,Y,S,Z,W,DELTAX,DELTAS,DELTAY,DELTAZ,DELTAW,YPROX, - X RMTMP1,RMTMP2,RMTMP3,RNTMP1,RNTMP2,RNTMP3, - X RESX,RESY,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 IDIR,MAXM,MAXN,MAXNZA,MAXNZL,M,N - INTEGER*4 LIWORK,LRWORK,ITREF,IALARM,IOERR - INTEGER*2 STAVAR(MAXN) - LOGICAL VUSED(MAXN),VBNDED(MAXN) - DOUBLE PRECISION THETA(MAXN),XIB(MAXM),XIC(MAXN),XIU(MAXN) - DOUBLE PRECISION BARR,OLDBAR,ALPHAP,ALPHAD,SMALLX - DOUBLE PRECISION DDD(MAXM),GGG(MAXN),HHH(MAXN),FNEW(MAXN) - INTEGER*4 IROW(MAXN) - DOUBLE PRECISION RELT(MAXN) - DOUBLE PRECISION RMTMP1(MAXM),RMTMP2(MAXM),RMTMP3(MAXM) - DOUBLE PRECISION RNTMP1(MAXN),RNTMP2(MAXN),RNTMP3(MAXN) - DOUBLE PRECISION X(MAXN),S(MAXN),Y(MAXM),Z(MAXN),W(MAXN) - DOUBLE PRECISION DELTAX(MAXN,2),DELTAS(MAXN,2) - DOUBLE PRECISION DELTAY(MAXM,2),YPROX(MAXM) - DOUBLE PRECISION DELTAZ(MAXN,2),DELTAW(MAXN,2) - DOUBLE PRECISION RESX,RESY -C -C *** DATA STRUCTURES FOR CHOLESKY FACTOR - DOUBLE PRECISION LCOEFF(MAXNZL) - DOUBLE PRECISION LDIAG(MAXM),LDSQRT(MAXM) - INTEGER*4 LCLPTS(MAXM+1) - INTEGER*2 LRWNBS(MAXNZL) -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(LIWORK),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(LRWORK) -C -C -C *** LOCAL VARIABLES - DOUBLE PRECISION DP,DX,DS,DZ,DW,XZSW,ALP,ALD - INTEGER*4 I,J,K,KSMALL,KLARGE - CHARACTER*100 BUFFER -C -C Additional Cholesky fact. parameters (interface to HYBRID). - COMMON /CHHYB/ RO,FLOPS,IREG,NZCHL,RTCD - DOUBLE PRECISION RO,FLOPS - INTEGER*4 IREG,NZCHL,RTCD -C -C -C *** PARAMETERS DESCRIPTION -C -C IDIR Index of the Newton's step component desired: -C 1 primal-dual affine scaling direction; -C 2 corrector term for the pred-corr direction. -C 3 corrector term for the pure primal-dual direction. -C 4 pure primal-dual direction. -C BARR Barrier parameter. -C SMALLX The threshold number for primal variables X and S. -C -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C N Number of columns of the LP constraint matrix. -C ITREF Number of steps of the iterative refinement process -C to be done to improve the accuracy of solutions -C with the Cholesky factorization of A*THETA*Atransp. -C IALARM Parameter set to 1 if the iterative refinement process -C does not improve the accuracy. -C -C LCOEFF Off-diagonal nonzero coefficients of Cholesky matrix. -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C LDIAG Diagonal elements of Cholesky factor. -C LDSQRT Square roots of the diagonal elements of Cholesky factor. -C -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C 7 (or larger) PRESUMED OPTIMAL variable i.e.: x = x0; -C -k free variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status. -C VUSED An indicator if a variable is active in the optimization -C process: -C .TRUE. active variable; -C .FALSE. FIXED variable. -C VBNDED An indicator if a variable has an UPPER bound: -C .TRUE. UPPER bounded variable; -C .FALSE. UNBOUNDED variable; -C THETA Diagonal weight matrix. -C XIB Violation of primal constraints, i.e. b - A * x -C XIC Violation of dual constraints, i.e. c - At*y - z + w -C XIU Violation of variable bounds, i.e. UPBND - x - s -C DDD Work array. It stores: -C XIB (affine dir); -C zero (corr., p-c algorithm). -C zero (corr., pure p-d step). -C GGG Work array. It stores: -C -X*Z*e (affine dir.); -C BARR*e - deltaX*deltaZ*e (corr., p-c algorithm). -C BARR*e (corr., pure p-d step). -C HHH Work array. It stores: -C -S*W*e (affine dir.); -C BARR*e - deltaS*deltaW*e (corr., p-c algorithm). -C BARR*e (corr., pure p-d step). -C FNEW Work array. It stores: -C XIC-X**(-1)*GGG+S**(-1)*HHH-S**(-1)*W*XIU (affine dir); -C -X**(-1)*GGG+S**(-1)*HHH (any corrector step). -C -C X Primal variables of the linear program. -C S Primal slack variables of the linear program. -C Y Dual variables of the linear program. -C Z Dual slack variables of the linear program. -C W Dual slack variables of the linear program. -C DELTAX(*,L) L-th component of deltaX. -C DELTAS(*,L) L-th component of deltaS. -C DELTAY(*,L) L-th component of deltaY. -C DELTAZ(*,L) L-th component of deltaZ. -C DELTAW(*,L) L-th component of deltaW. -C YPROX Dual proximal point. -C -C RESX Residuum of the solution (part refering to deltaX). -C RESY Residuum of the solution (part refering to deltaY). -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C -C *** COMMON ARREAS -C IREG Regularization: -C 0 add RO to all diagonal elements and increase small -C pivots to TAUADD (used by HYBRID); -C 1 increase small pivots to TAUADD (used by HYBRID); -C -1 increase very small pivots to TAUADD (used by HOPDM). -C RO Regularization parameter. -C -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real work array containing almost all real -C LP problem data. -C IWORK Integer work array containing almost all integer -C LP problem data. -C RMAP Map of RWORK. -C IMAP Map of IWORK. -C -C Map of IWORK array: -C IMAP(1) Points to CLPNTS array. -C IMAP(2) Points to RWNMBS array. -C IMAP(3) Points to RWHEAD array. -C IMAP(4) Points to RWLINK array. -C IMAP(5) Points to CLNMBS array. -C IMAP(6) Points to LENCOL array. -C IMAP(7) Points to the first empty cell of IWORK array. -C -C Map of RWORK array: -C RMAP(1) Points to ACOEFF array. -C RMAP(2) Points to COBJ array. -C RMAP(3) Points to RHS array. -C RMAP(4) Points to the first empty cell of RWORK array. -C -C -C *** WORK ARRAYS. -C IROW and RELT are the arrays for temporary handling -C of rows/columns of the constraint matrix. They -C are primarily intended to handle sparse vectors -C (in packed form) but may also be used for storing -C dense ones. -C RMTMP1 Double precision work array of size MAXM. -C RMTMP2 Double precision work array of size MAXM. -C RMTMP3 Double precision work array of size MAXM. -C RNTMP1 Double precision work array of size MAXN. -C RNTMP2 Double precision work array of size MAXN. -C RNTMP3 Double precision work array of size MAXN. -C -C -C *** SUBROUTINES CALLED: -C IRSOLV -C -C -C *** PURPOSE: -C This subroutine computes the components of the step direction. -C -C -C *** REFERENCES: -C Altman A., Gondzio J. (1992). An efficient implementation -C of a higher order primal-dual interior point method -C for large sparse linear programs, Archives of Control -C Sciences (to appear). -C Altman A., Gondzio J. (1993). HOPDM - A higher order primal- -C dual method for large scale linear programmming, European -C Journal of Operational Research 66 (1993) pp 158-160. -C Lustig I., Marsten R., Shanno D.F. (1992). On implementing -C Mehrotra's predictor-corrector interior point method for -C linear programming, SIAM Journal on Optimization 2, -C No 3, pp. 435-449. -C Mehrotra S. (1992): On the Implementation of a Primal-Dual -C Interior Point Method, SIAM Journal on Optimization 2, -C No 4, pp. 575-601. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, -C Systems Research Institute, -C Polish Academy of Sciences, -C Newelska 6, 01-447 Warsaw, Poland. -C Last modified: June 10, 1994 -C -C -C -C *** BODY OF (PCDIR) *** -C -C -C -C -C - IF(IDIR.GE.4) GO TO 4000 - IF(IDIR.GE.2) GO TO 1000 -C -C -C -C -C -C -C Here if a primal-dual affine scaling direction -C is to be computed. -C ********************************************** -C GGG -X*Z*e -C HHH -S*W*e -C FNEW XIC-X**(-1)*GGG+S**(-1)*HHH-S**(-1)*W*XIU -C -C -C Compute GGG, HHH and FNEW. - DO 200 J=1,N - IF(VUSED(J)) THEN - GGG(J)=-X(J)*Z(J) - FNEW(J)=XIC(J)+Z(J) - IF(VBNDED(J)) THEN - HHH(J)=-S(J)*W(J) - FNEW(J)=FNEW(J)-W(J)-W(J)*XIU(J)/S(J) - ENDIF - ENDIF - 200 CONTINUE -C -C -C Solve the augmented system for deltaX and deltaY. -C Use normal equations in solve for deltaY and an iterative -C refinement on the augmented system to improve the accuracy. -C - CALL IRSOLV(LCOEFF,LCLPTS,LRWNBS,LDIAG, - X MAXM,MAXN,MAXNZA,MAXNZL,M,N,ITREF,IALARM, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X THETA,STAVAR,VUSED, - X RMTMP1,RMTMP2,RMTMP3,RNTMP1,RNTMP2,RNTMP3, - X FNEW,XIB,DELTAX(1,1),DELTAY(1,1),RESX,RESY,IOERR) -C -C -C Compute deltaZ = - Z - X**(-1)*Z*deltaX -C Compute deltaS = XIU - deltaX -C Compute deltaW = - W - S**(-1)*W*deltaS - DO 600 J=1,N - IF(VUSED(J)) THEN - DELTAZ(J,1)=-Z(J)-Z(J)*DELTAX(J,1)/X(J) - IF(VBNDED(J)) THEN - DELTAS(J,1)=XIU(J)-DELTAX(J,1) - DELTAW(J,1)=-W(J)-W(J)*DELTAS(J,1)/S(J) - ENDIF - ENDIF - 600 CONTINUE -C - GO TO 9000 -C -C -C -C -C -C -C Here if a corrector step is to be computed. -C ******************************************* -C GGG BARR*e - deltaX*deltaZ*e -C HHH BARR*e - deltaS*deltaW*e -C FNEW -X**(-1)*GGG+S**(-1)*HHH -C -C -C Compute GGG, HHH and FNEW. - 1000 IF(IDIR.EQ.2) THEN -C -C (Second order) predictor-corrector. - DO 1200 J=1,N - IF(VUSED(J)) THEN - GGG(J)=-DELTAX(J,1)*DELTAZ(J,1) - DP=X(J)*Z(J) - GGG(J)=GGG(J)+BARR - FNEW(J)=-GGG(J)/X(J) - IF(VBNDED(J)) THEN - HHH(J)=-DELTAS(J,1)*DELTAW(J,1) - DP=S(J)*W(J) - HHH(J)=HHH(J)+BARR - FNEW(J)=FNEW(J)+HHH(J)/S(J) - ENDIF - ENDIF - 1200 CONTINUE - ENDIf -C - IF(IDIR.EQ.3) THEN -C -C Corerctor for pure primal-dual direction. - DO 1300 J=1,N - IF(VUSED(J)) THEN - GGG(J)=BARR - FNEW(J)=-GGG(J)/X(J) - IF(VBNDED(J)) THEN - HHH(J)=BARR - FNEW(J)=FNEW(J)+HHH(J)/S(J) - ENDIF - ENDIF - 1300 CONTINUE - ENDIf - DO 1500 I=1,M - DDD(I)=0.0D0 - 1500 CONTINUE -C -C -C Solve the augmented system for deltaX and deltaY. -C Use normal equations in solve for deltaY and an iterative -C refinement on the augmented system to improve the accuracy. -C - CALL IRSOLV(LCOEFF,LCLPTS,LRWNBS,LDIAG, - X MAXM,MAXN,MAXNZA,MAXNZL,M,N,ITREF,IALARM, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X THETA,STAVAR,VUSED, - X RMTMP1,RMTMP2,RMTMP3,RNTMP1,RNTMP2,RNTMP3, - X FNEW,DDD,DELTAX(1,2),DELTAY(1,2),RESX,RESY,IOERR) -C -C -C Compute deltaZ = X**(-1)*(GGG-Z*deltaX) -C Compute deltaS = - deltaX -C Compute deltaW = S**(-1)*(HHH-W*deltaS) - DO 1600 J=1,N - IF(VUSED(J)) THEN - DELTAZ(J,2)=(GGG(J)-Z(J)*DELTAX(J,2))/X(J) - IF(VBNDED(J)) THEN - DELTAS(J,2)=-DELTAX(J,2) - DELTAW(J,2)=(HHH(J)-W(J)*DELTAS(J,2))/S(J) - ENDIF - ENDIF - 1600 CONTINUE - GO TO 9000 -C -C -C -C -C - 4000 IF(IDIR.GE.5) GO TO 5000 -C -C -C -C -C -C -C Here if a primal-dual affine scaling direction -C is to be computed. -C ********************************************** -C GGG BARR-X*Z*e -C HHH BARR-S*W*e -C FNEW XIC-X**(-1)*GGG+S**(-1)*HHH-S**(-1)*W*XIU -C -C -C Compute GGG, HHH and FNEW. - DO 4200 J=1,N - IF(VUSED(J)) THEN - GGG(J)=BARR-X(J)*Z(J) - FNEW(J)=XIC(J)-GGG(J)/X(J) - IF(VBNDED(J)) THEN - HHH(J)=BARR-S(J)*W(J) - FNEW(J)=FNEW(J)+HHH(J)/S(J)-W(J)*XIU(J)/S(J) - ENDIF - ENDIF - 4200 CONTINUE - DO 4500 I=1,M - DDD(I)=XIB(I)+RO*(Y(I)-YPROX(I)) - 4500 CONTINUE -C -C -C Solve the augmented system for deltaX and deltaY. -C Use normal equations in solve for deltaY and an iterative -C refinement on the augmented system to improve the accuracy. -C - CALL IRSOLV(LCOEFF,LCLPTS,LRWNBS,LDIAG, - X MAXM,MAXN,MAXNZA,MAXNZL,M,N,ITREF,IALARM, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X THETA,STAVAR,VUSED, - X RMTMP1,RMTMP2,RMTMP3,RNTMP1,RNTMP2,RNTMP3, - X FNEW,DDD,DELTAX(1,1),DELTAY(1,1),RESX,RESY,IOERR) -C -C -C Compute deltaZ = X**(-1)*GGG - X**(-1)*Z*deltaX -C Compute deltaS = XIU - deltaX -C Compute deltaW = S**(-1)*HHH - S**(-1)*W*deltaS - DO 4600 J=1,N - IF(VUSED(J)) THEN - DELTAZ(J,1)=(GGG(J)-Z(J)*DELTAX(J,1))/X(J) - IF(VBNDED(J)) THEN - DELTAS(J,1)=XIU(J)-DELTAX(J,1) - DELTAW(J,1)=(HHH(J)-W(J)*DELTAS(J,1))/S(J) - ENDIF - ENDIF - 4600 CONTINUE -C - GO TO 9000 -C -C -C - 5000 IF(IDIR.GE.6) GO TO 6000 -C -C -C -C -C -C -C Here if a corrector step is to be computed. -C ******************************************* -C GGG BARR*e - deltaX*deltaZ*e -C HHH BARR*e - deltaS*deltaW*e -C FNEW -X**(-1)*GGG+S**(-1)*HHH -C -C (Higher order) predictor-corrector. - DO 5200 J=1,N - IF(VUSED(J)) THEN - GGG(J)=-DELTAX(J,1)*DELTAZ(J,1) - GGG(J)=GGG(J)+BARR-OLDBAR - FNEW(J)=-GGG(J)/X(J) - IF(VBNDED(J)) THEN - HHH(J)=-DELTAS(J,1)*DELTAW(J,1) - HHH(J)=HHH(J)+BARR-OLDBAR - FNEW(J)=FNEW(J)+HHH(J)/S(J) - ENDIF - ENDIF - 5200 CONTINUE - DO 5500 I=1,M - DDD(I)=0.0D0 - 5500 CONTINUE -C -C -C Solve the augmented system for deltaX and deltaY. -C Use normal equations in solve for deltaY and an iterative -C refinement on the augmented system to improve the accuracy. -C - CALL IRSOLV(LCOEFF,LCLPTS,LRWNBS,LDIAG, - X MAXM,MAXN,MAXNZA,MAXNZL,M,N,ITREF,IALARM, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X THETA,STAVAR,VUSED, - X RMTMP1,RMTMP2,RMTMP3,RNTMP1,RNTMP2,RNTMP3, - X FNEW,DDD,DELTAX(1,2),DELTAY(1,2),RESX,RESY,IOERR) -C -C -C Compute deltaZ = X**(-1)*(GGG-Z*deltaX) -C Compute deltaS = - deltaX -C Compute deltaW = S**(-1)*(HHH-W*deltaS) - DO 5600 J=1,N - IF(VUSED(J)) THEN - DELTAZ(J,2)=(GGG(J)-Z(J)*DELTAX(J,2))/X(J) - IF(VBNDED(J)) THEN - DELTAS(J,2)=-DELTAX(J,2) - DELTAW(J,2)=(HHH(J)-W(J)*DELTAS(J,2))/S(J) - ENDIF - ENDIF - 5600 CONTINUE - GO TO 9000 -C - 6000 CONTINUE -C -C -C -C -C Compute the minimum complementarity gap that can be achieved -C when moving in a current predictor direction: -C XZSW=(x+ALPHAP*dx)t*(z+ALPHAD*dz)+(s+ALPHAP*ds)t*(w+ALPHAD*dw). -C - XZSW=0.0D0 - K=0 - DO 6020 J=1,N - IF(VUSED(J)) THEN - DX=DELTAX(J,1) - DZ=DELTAZ(J,1) - XZSW=XZSW+(X(J)+ALPHAP*DX)*(Z(J)+ALPHAD*DZ) - K=K+1 - IF(VBNDED(J)) THEN - DS=DELTAS(J,1) - DW=DELTAW(J,1) - XZSW=XZSW+(S(J)+ALPHAP*DS)*(W(J)+ALPHAD*DW) - K=K+1 - ENDIF - ENDIF - 6020 CONTINUE - XZSW=XZSW/DBLE(K) -C WRITE(BUFFER,6021) BARR,XZSW -C6021 FORMAT(1X,' barrier=',1PD10.3,' predicted cmpl.=',1PD10.3) -C CALL MYWRT(IOERR,BUFFER) -C IF(XZSW.GE.2.0D0*BARR) XZSW=2.0D0*BARR -C -C -C -C -C -C Here if a corrector step is to be computed. -C ******************************************* -C GGG BARR*e - Xprim*Zprim*e -C HHH BARR*e - Sprim*Wprim*e -C FNEW -X**(-1)*GGG+S**(-1)*HHH -C -C (Higher order) predictor-corrector. - ALP=ALPHAP*1.08D0+0.08D0 - IF(ALP.GE.1.0D0) ALP=1.0D0 - ALD=ALPHAD*1.08D0+0.08D0 - IF(ALD.GE.1.0D0) ALD=1.0D0 - KSMALL=0 - KLARGE=0 - DO 6200 J=1,N - IF(VUSED(J)) THEN - DX=DELTAX(J,1) - DZ=DELTAZ(J,1) - DP=(X(J)+ALP*DX)*(Z(J)+ALD*DZ) - GGG(J)=0.0D0 - IF(DP.LE.1.0D-1*BARR) THEN - KSMALL=KSMALL+1 -C GGG(J)=2.0D0*BARR-DP - GGG(J)=BARR-DP - ENDIF - IF(DP.GE.10.0D0*BARR) THEN - KLARGE=KLARGE+1 - GGG(J)=-5.0D0*BARR -C IF(DP.GE.50.0D0*BARR) GGG(J)=-10.0D0*BARR - ENDIF - FNEW(J)=-GGG(J)/X(J) - IF(VBNDED(J)) THEN - DS=DELTAS(J,1) - DW=DELTAW(J,1) - DP=(S(J)+ALP*DS)*(W(J)+ALD*DW) - HHH(J)=0.0D0 - IF(DP.LE.1.0D-1*BARR) THEN - KSMALL=KSMALL+1 -C HHH(J)=2.0D0*BARR-DP - HHH(J)=BARR-DP - ENDIF - IF(DP.GE.10.0D0*BARR) THEN - KLARGE=KLARGE+1 - HHH(J)=-5.0D0*BARR -C IF(DP.GE.50.0D0*BARR) HHH(J)=-10.0D0*BARR - ENDIF - FNEW(J)=FNEW(J)+HHH(J)/S(J) - ENDIF - ENDIF - 6200 CONTINUE -C WRITE(BUFFER,6201) KSMALL,KLARGE -C6201 FORMAT(1X,'PCDIR: complement. pairs, KSMALL=',I6,' KLARGE=',I6) -C CALL MYWRT(IOERR,BUFFER) - DO 6500 I=1,M - DDD(I)=0.0D0 - 6500 CONTINUE -C -C -C Solve the augmented system for deltaX and deltaY. -C Use normal equations in solve for deltaY and an iterative -C refinement on the augmented system to improve the accuracy. -C - CALL IRSOLV(LCOEFF,LCLPTS,LRWNBS,LDIAG, - X MAXM,MAXN,MAXNZA,MAXNZL,M,N,ITREF,IALARM, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X THETA,STAVAR,VUSED, - X RMTMP1,RMTMP2,RMTMP3,RNTMP1,RNTMP2,RNTMP3, - X FNEW,DDD,DELTAX(1,2),DELTAY(1,2),RESX,RESY,IOERR) -C -C -C Compute deltaZ = X**(-1)*(GGG-Z*deltaX) -C Compute deltaS = - deltaX -C Compute deltaW = S**(-1)*(HHH-W*deltaS) - DO 6600 J=1,N - IF(VUSED(J)) THEN - DELTAZ(J,2)=(GGG(J)-Z(J)*DELTAX(J,2))/X(J) - IF(VBNDED(J)) THEN - DELTAS(J,2)=-DELTAX(J,2) - DELTAW(J,2)=(HHH(J)-W(J)*DELTAS(J,2))/S(J) - ENDIF - ENDIF - 6600 CONTINUE - GO TO 9000 -C -C -C -C -C -C -C -C -C -C - 9000 CONTINUE - RETURN -C -C -C *** LAST CARD OF (PCDIR) *** - END //GO.SYSIN DD hopdm.src/pcdir.f echo hopdm.src/pcelim.f 1>&2 sed >hopdm.src/pcelim.f <<'//GO.SYSIN DD hopdm.src/pcelim.f' 's/^-//' -C****************************************************************** -C * PCELIM ... ELIMINATE COLS/ROWS APPROACHING OPTIMAL VALUES * -C * PREDICTOR-CORRECTOR PRIMAL-DUAL METHOD * -C****************************************************************** -C - SUBROUTINE PCELIM(LORD,MAXM,MAXN,MAXNZA,MAXNZL, - X M,N,NSTRCT,NFIX,MOUT, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X LDSQRT,LCLPTS,LRWNBS,LLINKS, - X ACOEFF,CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X INTMP1,IXCHNG,ISCHNG,IMTMP1,IMTMP2,RNTMP1, - X PERM,INVP,HEADER,LINKFD,LINKBK, - X PRFSBT,DLFSBT,XIB,XIU,XIC,XFIX,YFIX, - X X,Y,S,Z,W,DELTAX,DELTAS,DELTAY,DELTAZ,DELTAW,YPROX, - X VUSED,VBNDED,C,UPBND,P,Q,B,RANGES, - X RSCALE,CSCALE,STAVAR,STAROW,RWSTAT,RWNAME,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 LORD,MAXM,MAXN,MAXNZA,MAXNZL,M,N,NSTRCT,NFIX,MOUT - INTEGER*4 LIWORK,LRWORK,IOERR -C - DOUBLE PRECISION ACOEFF(MAXNZA) - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM+1),RWLINK(MAXNZA) - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) -C - INTEGER*4 INTMP1(MAXN),IROW(MAXN) - INTEGER*2 IXCHNG(MAXN),ISCHNG(MAXN) - DOUBLE PRECISION RNTMP1(MAXN),RELT(MAXN) - INTEGER*4 IMTMP1(MAXM+1),IMTMP2(MAXM+1) -C - INTEGER*2 PERM(MAXM),INVP(MAXM) - INTEGER*2 HEADER(MAXM+1),LINKFD(MAXM+1),LINKBK(MAXM+1) -C - LOGICAL VUSED(MAXN),VBNDED(MAXN) - DOUBLE PRECISION P(MAXM),Q(MAXM) - DOUBLE PRECISION C(MAXN),B(MAXM),UPBND(MAXN),RANGES(MAXM) - DOUBLE PRECISION X(MAXN),S(MAXN),Y(MAXM),Z(MAXN),W(MAXN) - DOUBLE PRECISION DELTAX(MAXN,LORD),DELTAS(MAXN,LORD) - DOUBLE PRECISION DELTAY(MAXM,LORD),YPROX(MAXM) - DOUBLE PRECISION DELTAZ(MAXN,LORD),DELTAW(MAXN,LORD) - DOUBLE PRECISION PRFSBT,DLFSBT,XFIX,YFIX - DOUBLE PRECISION XIB(MAXM),XIU(MAXN),XIC(MAXN) - DOUBLE PRECISION RSCALE(MAXM),CSCALE(MAXN) - INTEGER*2 STAVAR(MAXN),STAROW(MAXM),RWSTAT(MAXM) - CHARACTER*8 RWNAME(MAXM) -C -C *** DATA STRUCTURES FOR CHOLESKY FACTOR - DOUBLE PRECISION LDSQRT(MAXM) - INTEGER*4 LCLPTS(MAXM+1),LLINKS(MAXNZL) - INTEGER*2 LRWNBS(MAXNZL) -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(LIWORK),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(LRWORK) -C -C -C -C *** COMMON AREAS -C An indicator if the elimination routine has been used. - COMMON /ELMNTE/ IELIM - INTEGER*4 IELIM -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 KNZ - INTEGER*4 I,IKX,IPOS,IR,IRUN,J,JCOL,MNEW - INTEGER*4 K,KBEG,KEND,KOK,KOUT,KSTAT - DOUBLE PRECISION DP - CHARACTER*100 BUFFER -C -C -C *** COMMON ARREAS -C Markers for linking rows. - COMMON /ICGRAD/ MSPLIT(100000) - INTEGER*2 MSPLIT -C -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C -C LORD The highest degree of computed derivatives of x,s,y,z,w -C (order of Mehrotra's method). -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C N Number of columns of the LP constraint matrix. -C NSTRCT Number of structural variables. -C NFIX Number of variables FIXED on their optimal values. -C MOUT Number of LP constraints that are presumed to be -C inactive at the optimum. -C -C ACOEFF Nonzero elements of matrix A. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C LENCOL Lengths of columns of matrix A. -C -C LDSQRT Square roots of the diagonal elements of Cholesky factor. -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C LLINKS Linked lists for Cholesky factor. -C -C INTMP1 Integer work array of size MAXN. -C IXCHNG An indicator of changes of variable X. -C ISCHNG An indicator of changes of variable S. -C IMTMP1 Integer work array of size MAXM. -C IMTMP2 Integer work array of size MAXM. -C IROW and RELT are the arrays for temporary handling -C of rows/columns of the constraint matrix. They -C are primarily intended to handle sparse vectors -C (in packed form) but may also be used for storing -C dense ones. -C RNTMP1 Double precision work array of size MAXN. -C PRFSBT Primal feasibility tolerance. -C DLFSBT Dual feasibility tolerance. -C XIB Current primal residual A*x-b. -C XIU Current primal residual x+s-upbnd. -C XIC Current dual residual At*y+z-w-c. -C XFIX Threshold value for fixing primal variables. As soon -C as the primal variable is smaller than XFIX (and the -C appropriate dual slack variable is bounded away from -C zero), the variable is presumed to approach a zero -C optimal value. It is then fixed and eliminated from -C the problem. -C YFIX Threshold value for eliminating LP constraints. As soon -C as the dual variable is smaller than YFIX (and the -C appropriate primal slack variable is bounded away from -C zero), the constraint is presumed to be inactive at the -C optimum. It is then eliminated from the problem. -C -C PERM Permutation resulting from the elimination of inactive -C constraints. -C INVP Inverse permutation. -C HEADER Header of the doubly linked lists. -C LINKFD Forward linked lists. -C LINKBK Backward linked lists. -C -C VUSED An indicator if a variable is active in the optimization -C process: -C .TRUE. active variable; -C .FALSE. FIXED variable. -C VBNDED An indicator if a variable has an UPPER bound: -C .TRUE. UPPER bounded variable; -C .FALSE. UNBOUNDED variable; -C C Objective function coefficients. -C UPBND Array of upper bounds. Note that the upper bound -C is changed when the variable has a lower bound. -C P LOWER bounds on shadow prices (dual variables). -C Q UPPER bounds on shadow prices (dual variables). -C B Right-hand-side of the linear program. -C RANGES Array of constraint ranges. -C -C X Primal variables of the linear program. -C S Primal slack variables of the linear program. -C Y Dual variables of the linear program. -C Z Dual slack variables of the linear program. -C W Dual slack variables of the linear program. -C DELTAX(*,L) L-th derivative of x(alpha) (for alpha=1) with -C respect to alpha divided by l!. -C DELTAS(*,L) L-th derivative of s(alpha) (for alpha=1) with -C respect to alpha divided by l!. -C DELTAY(*,L) L-th derivative of y(alpha) (for alpha=1) with -C respect to alpha divided by l!. -C DELTAZ(*,L) L-th derivative of z(alpha) (for alpha=1) with -C respect to alpha divided by l!. -C DELTAW(*,L) L-th derivative of w(alpha) (for alpha=1) with -C respect to alpha divided by l!. -C YPROX Dual proximal point. -C -C RSCALE Current row scaling factors. -C CSCALE Current column scaling factors. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C 7 (or larger) PRESUMED OPTIMAL variable i.e.: x = x0; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C RWSTAT Array of row types (sort as before): -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 row type is objective or free. -C RWNAME Array of row names (increasing order sort). -C -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real work array containing almost all real -C LP problem data. -C IWORK Integer work array containing almost all integer -C LP problem data. -C RMAP Map of RWORK. -C IMAP Map of IWORK. -C -C Map of IWORK array: -C IMAP(1) Points to CLPNTS array. -C IMAP(2) Points to RWNMBS array. -C IMAP(3) Points to RWHEAD array. -C IMAP(4) Points to RWLINK array. -C IMAP(5) Points to CLNMBS array. -C IMAP(6) Points to LENCOL array. -C IMAP(7) Points to the first empty cell of IWORK array. -C -C Map of RWORK array: -C RMAP(1) Points to ACOEFF array. -C RMAP(2) Points to C array. -C RMAP(3) Points to RHS array. -C RMAP(4) Points to the first empty cell of RWORK array. -C -C -C -C -C *** LOCAL VARIABLES DESCRIPTION -C -C -C -C -C *** SUBROUTINES CALLED: -C SATY(FSATY),GETCOL,GETROW,MYWRT, -C EMPTYR,REORDA,REORDV,REORDI,SYMFCT,SYMREF -C -C -C *** PURPOSE: -C This routine eliminates: -C - variables presumed to approach their optimal values; -C - constraints presumed to be inactive at the optimum. -C -C -C *** NOTES: -C -C -C -C *** WARNING: -C This routine alters hidden data structures. -C It then should be used with extreme care. -C -C -C -C *** REFERENCES: -C Altman A., Gondzio J. (1992). An efficient implementation -C of a higher order primal-dual interior point method -C for large sparse linear programs, Archives of Control -C Sciences (to appear). -C Altman A., Gondzio J. (1993). HOPDM - A higher order primal- -C dual method for large scale linear programmming, European -C Journal of Operational Research 66 (1993) pp 158-160. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, -C Systems Research Institute, -C Polish Academy of Sciences, -C Newelska 6, 01-447 Warsaw, Poland. -C Last modified: June 22, 1994 -C -C -C -C -C -C -C *** BODY OF (PCELIM) *** -C -C -C -C Set an indicator if the elimination routine has been used. - IELIM=1 -C -C -C -C -C *** DEBUGGING -C DO 40 J=1,N -C IF(X(J).LE.XFIX) THEN -C WRITE(BUFFER,41) J,STAVAR(J),X(J),Z(J) -C 41 FORMAT(1X,'J=',I4,' st=',I4,' X=',1PD9.2,' Z=',1PD9.2) -C CALL MYWRT(IOERR,BUFFER) -C ENDIF -C IF(STAVAR(J).EQ.1.OR.STAVAR(J).EQ.3) THEN -C K=STAVAR(J) -C IF(S(J).LE.XFIX) THEN -C WRITE(BUFFER,42) J,K,S(J),W(J) -C 42 FORMAT(1X,'J=',I4,' st=',I4,' S=',1PD9.2,' W=',1PD9.2) -C CALL MYWRT(IOERR,BUFFER) -C ENDIF -C ENDIF -C 40 CONTINUE -C -C -C -C -C *** DEBUGGING -C DO 80 J=1,N -C IF(STAVAR(J).GE.0) GO TO 80 -C -C Here for a FREE variable. -C JCOL=J -C K=STAVAR(JCOL) -C IF(JCOL.LT.-K) GO TO 80 -C CALL GETCOL(JCOL,RWORK,IWORK,RMAP,IMAP, -C X IROW,RELT,KNZ,MAXN,IOERR) -C CALL SDOT(Y,IROW,RELT,KNZ,DP) -C WRITE(IOERR,81) JCOL,KNZ,DP,XIC(JCOL),Z(JCOL),C(JCOL) -C 81 FORMAT(1X,'col=',I4,' nz=',I4,' Aty=',1PD9.2, -C X ' XIC=',1PD9.2,' Z=',1PD9.2,' C=',1PD9.2) -C JCOL=-K -C K=STAVAR(JCOL) -C CALL GETCOL(JCOL,RWORK,IWORK,RMAP,IMAP, -C X IROW,RELT,KNZ,MAXN,IOERR) -C CALL SDOT(Y,IROW,RELT,KNZ,DP) -C WRITE(IOERR,82) JCOL,KNZ,DP,XIC(JCOL),Z(JCOL),C(JCOL) -C 82 FORMAT(1X,'col=',I4,' nz=',I4,' Aty=',1PD9.2, -C X ' XIC=',1PD9.2,' Z=',1PD9.2,' C=',1PD9.2) -C 80 CONTINUE -C -C -C -C -C -C -C Loop over variables. -C Fix all the variables that approach their bounds. -C The following conditions have to be satisfied to eliminate -C a variable: -C 1. is satisfies bound constraint with sufficient accuracy; -C 2. appropriate dual variable is bounded away from zero; -C 3. it is already small (i.e. X(j) < XFIX); -C 4. it has continuously decreased in at least 5 subsequent -C iters. - NFIX=0 - DO 200 J=1,NSTRCT - IF(.NOT.VUSED(J)) GO TO 200 -C - IF(STAVAR(J).LT.0) THEN -C -C Here for a FREE variable. - KSTAT=STAVAR(J) - DP=X(J)-X(-KSTAT) - IF(DABS(DP).LE.1.0D0) GO TO 200 - ENDIF -C - IF(VBNDED(J)) THEN -C -C Here for UPPER bounded variable. -C First, check if x + s = u. - DP=DABS(XIU(J)) - IF(DP.GT.0.00001*UPBND(J)) GO TO 200 - IF(X(J).LE.XFIX.AND.X(J).LE.0.000001*UPBND(J)) THEN - IF(Z(J)-W(J)+XIC(J).LE.0.5) GO TO 200 - IF(IXCHNG(J).GT.-3) GO TO 200 - IF(ISCHNG(J).LE.2) GO TO 200 -C WRITE(BUFFER,111) J,STAVAR(J),X(J),S(J),UPBND(J) -C 111 FORMAT(1X,'111, J=',I6,' st=',I6, -C X ' X=',D12.5,' S=',D12.5,' Uj=',D12.5) -C CALL MYWRT(IOERR,BUFFER) - X(J)=0.0 - S(J)=UPBND(J) - GO TO 140 - ENDIF - IF(S(J).LE.XFIX.AND.S(J).LE.0.000001*UPBND(J)) THEN - IF(W(J)-Z(J)-XIC(J).LE.0.5) GO TO 200 - IF(ISCHNG(J).GT.-3) GO TO 200 - IF(IXCHNG(J).LE.2) GO TO 200 -C WRITE(BUFFER,112) J,STAVAR(J),X(J),S(J),UPBND(J) -C 112 FORMAT(1X,'112, J=',I6,' st=',I6, -C X ' X=',D12.5,' S=',D12.5,' Uj=',D12.5) -C CALL MYWRT(IOERR,BUFFER) - X(J)=UPBND(J) - S(J)=0.0 - GO TO 140 - ENDIF -C -C Here to eliminate useless (large) UPPER bounds. - IF(UPBND(J).GE.1.0D+4.AND.S(J).GE.0.95*UPBND(J)) THEN - IF(Z(J)-W(J)+XIC(J).LE.0.5) GO TO 200 - IF(DABS(XIU(J)).GE.1.0D-3) GO TO 200 - IF(W(J).GE.1.0D-4) GO TO 200 - IF(IXCHNG(J).GT.-2) GO TO 200 - IF(ISCHNG(J).LE.2) GO TO 200 -C WRITE(BUFFER,121) J,STAVAR(J),X(J),S(J),UPBND(J) -C 121 FORMAT(1X,'121, J=',I6,' st=',I6, -C X ' X=',D12.5,' S=',D12.5,' Uj=',D12.5) -C CALL MYWRT(IOERR,BUFFER) -C -C Do not alter Z. - S(J)=0.0 - XIC(J)=XIC(J)-W(J) - W(J)=0.0 - XIU(J)=0.0 - STAVAR(J)=2 - VBNDED(J)=.FALSE. -C -C Zero all unused components of DELTAs. - DO 120 I=1,LORD - DELTAS(J,I)=0.0 - DELTAW(J,I)=0.0 - 120 CONTINUE - GO TO 200 - ENDIF -C -C Here to eliminate useless (inactive) UPPER bounds. - IF(UPBND(J).GE.1.0D+2.AND.DABS(XIU(J)).LE.YFIX) THEN - IF(Z(J)+W(J).GE.YFIX) GO TO 200 - IF(DABS(XIC(J)).GE.YFIX) GO TO 200 - IF(S(J).LE.2.0D-1*UPBND(J)) GO TO 200 -C WRITE(BUFFER,131) J,STAVAR(J),X(J),S(J),UPBND(J) -C 131 FORMAT(1X,'131, J=',I6,' st=',I6, -C X ' X=',D12.5,' S=',D12.5,' Uj=',D12.5) -C CALL MYWRT(IOERR,BUFFER) -C -C Do not alter Z. - S(J)=0.0 - XIC(J)=XIC(J)-W(J) - W(J)=0.0 - XIU(J)=0.0 - STAVAR(J)=2 - VBNDED(J)=.FALSE. -C -C Zero all unused components of DELTAs. - DO 130 I=1,LORD - DELTAS(J,I)=0.0 - DELTAW(J,I)=0.0 - 130 CONTINUE - GO TO 200 - ENDIF - ELSE -C -C Here for UNBOUNDED (or LOWER bounded) variable. - IF(X(J).LE.XFIX) THEN - IF(Z(J)+XIC(J).LE.0.2) GO TO 200 - IF(IXCHNG(J).GT.-3) GO TO 200 -C WRITE(BUFFER,141) J,STAVAR(J),X(J),S(J),UPBND(J) -C 141 FORMAT(1X,'141, J=',I6,' st=',I6, -C X ' X=',D12.5,' S=',D12.5,' Uj=',D12.5) -C CALL MYWRT(IOERR,BUFFER) - X(J)=0.0 - KSTAT=STAVAR(J) - IF(KSTAT.LT.0) THEN -C -C Here for a FREE variable. Change status of the split brother. - STAVAR(J)=0 - STAVAR(-KSTAT)=0 - ENDIF - GO TO 140 - ENDIF - ENDIF - GO TO 200 -C -C Eliminate variable J from the LP problem. - 140 NFIX=NFIX+1 - VUSED(J)=.FALSE. - DP=X(J) - XIU(J)=0.0D0 - XIC(J)=0.0D0 - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 -C WRITE(BUFFER,161) J,X(J) -C 161 FORMAT(1X,'PCELIM: Fixing variable J=',I7,' X=',1PD16.8) -C CALL MYWRT(IOERR,BUFFER) -C WRITE(BUFFER,162) J,STAVAR(J),IXCHNG(J),ISCHNG(J),UPBND(J) -C 162 FORMAT(1X,'J=',I6,' st=',I6, -C X ' ixchng=',I3,' ischng=',I3,' Uj=',D12.4) -C CALL MYWRT(IOERR,BUFFER) - STAVAR(J)=STAVAR(J)+7 - DO 160 K=KBEG,KEND - I=RWNMBS(K) - B(I)=B(I)-DP*ACOEFF(K) - 160 CONTINUE -C -C Zero all unused components of DELTAs. - DO 180 I=1,LORD - DELTAX(J,I)=0.0 - DELTAZ(J,I)=0.0 - DELTAS(J,I)=0.0 - DELTAW(J,I)=0.0 - 180 CONTINUE -C -C -C -C -C End of the loop over variables. - 200 CONTINUE -C -C -C -C -C -C Check if there were any new FIXED variables. If so, then -C they have been removed from the LP problem formulation and, -C consequently, should be removed from the row linked lists. -C Compute primal residual XIB. - IF(NFIX.GT.0) THEN -C -C -C Here if there were FIXED variables. -C Set the new row linked lists of nonzero elements of matrix A. -C Recall that CLPNTS(j) indicates the first entry of column j. -C Zero RWHEAD array. - DO 340 I=1,M - RWHEAD(I)=0 - XIB(I)=B(I) - 340 CONTINUE -C -C Set the row linked lists. - DO 380 J=1,N -C -C Omit all FIXED variables. - IF(VUSED(J)) THEN - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 360 K=KBEG,KEND - I=RWNMBS(K) - XIB(I)=XIB(I)-X(J)*ACOEFF(K) - RWLINK(K)=RWHEAD(I) - CLNMBS(K)=J - RWHEAD(I)=K - 360 CONTINUE - ENDIF - 380 CONTINUE -C -C Check if the eliminated rows were not violated. - DO 400 I=1,M - K=RWHEAD(I) - IF(K.LE.0) THEN -C WRITE(BUFFER,401) I,RWSTAT(I),RWHEAD(I),B(I) -C 401 FORMAT(1X,'PCELIM: i=',I5,' st=',I2,' hd=',I6,' B=',D10.4) -C CALL MYWRT(IOERR,BUFFER) -C - IF(RWSTAT(I).EQ.1) THEN -C -C Here for EQUALITY constraint. - IF(DABS(B(I)).GT.PRFSBT) GO TO 9020 - GO TO 400 - ENDIF -C - IF(RWSTAT(I).EQ.2) THEN -C -C Here for GREATER OR EQUAL type constraint. - IF(B(I).GT.PRFSBT) GO TO 9020 - GO TO 400 - ENDIF -C - IF(RWSTAT(I).EQ.3) THEN -C -C Here for LESS OR EQUAL type constraint. - IF(B(I).LT.-PRFSBT) GO TO 9020 - GO TO 400 - ENDIF - ENDIF - 400 CONTINUE -C - ENDIF -C -C -C -C -C XIB array now contains primal residuals. If the residual -C (of some inequality-type LP constraint) is nonzero, -C then try to absorb it by the appropriate slack variable. -C If it is not possible, then leave nonzero residual in XIB. -C As the above analysis involves the loop over all slack -C variables associated with the inequality constraints -C it is also used to eliminate inactive constraints. - DO 410 J=1,N - INTMP1(J)=0 - 410 CONTINUE - MOUT=0 - DO 460 J=NSTRCT+1,N - IF(.NOT.VUSED(J)) GO TO 460 -C -C Get column J from the data structures. - KBEG=CLPNTS(J) - IR=RWNMBS(KBEG) - IF(IR.GT.M) GO TO 460 - DP=(XIB(IR)+X(J)*ACOEFF(KBEG))/ACOEFF(KBEG) -C - IF(RWLINK(KBEG).EQ.0) THEN -C -C Single-element row with only a slack entry is found. -C Remove the row from the LP problem. -C WRITE(BUFFER,421) J,IR,DP -C 421 FORMAT(1X,'PCELIM: col=',I6,' IR=',I6,' slack=',D10.4, -C X ' is eliminated.') -C CALL MYWRT(IOERR,BUFFER) -C -C Check if the slack variable is nonnegative. - IF(DP.LE.-PRFSBT) GO TO 9030 -C -C Here to eliminate single-element LP constraint. - X(J)=DP - STAVAR(J)=14 - VUSED(J)=.FALSE. - INTMP1(J)=INTMP1(J)+1 - MOUT=MOUT+1 - RWHEAD(IR)=-RWHEAD(IR) -C Y(IR)=0.0 - XIC(J)=0.0 -C -C Zero all unused components of DELTAs. - DO 420 I=1,LORD - DELTAX(J,I)=0.0 - DELTAZ(J,I)=0.0 - DELTAS(J,I)=0.0 - DELTAW(J,I)=0.0 - 420 CONTINUE - GO TO 460 -C - ENDIF -C -C -C Check if the slack variable can absorb infeasibility. If so, -C then correct X(J). If not, then do not alter the old X(J). - IF(DP.GE.0.1) THEN -C -C Here if the slack variable absorbs infeasibility. - X(J)=DP - XIB(IR)=0.0 -C -C -C Check if the analysed constraint is to be eliminated. - IF(X(J).GE.1.0) THEN - IF(DABS(Y(IR)).GE.YFIX) GO TO 460 -C -C Here to eliminate inactive LP constraint. - CALL GETROW(IR,RWORK,IWORK,RMAP,IMAP, - X IROW,RELT,K,MAXN,IOERR) - DP=0.0 - DO 430 IKX=1,K - IF(DABS(RELT(IKX)).GT.DP) DP=DABS(RELT(IKX)) - 430 CONTINUE - IF(DABS(Y(IR))*DP.GE.YFIX*100.0) GO TO 460 -C WRITE(BUFFER,442) J,IR,DP,DABS(Y(IR)),RSCALE(IR) -C 442 FORMAT(1X,'PCELIM: col=',I4,' IR=',I4,' ||r||=',D10.4, -C X ' |y|=',D10.4,' rscl=',D10.4) -C CALL MYWRT(IOERR,BUFFER) - DO 440 IKX=1,K - JCOL=IROW(IKX) - INTMP1(JCOL)=INTMP1(JCOL)+1 -C WRITE(BUFFER,443) IR,JCOL,RELT(IKX) -C 443 FORMAT(1X,'PCELIM: Rw=',I6,' cl=',I6,' elt=',D12.4) -C CALL MYWRT(IOERR,BUFFER) - 440 CONTINUE - MOUT=MOUT+1 - RWHEAD(IR)=-RWHEAD(IR) - Y(IR)=0.0 -C WRITE(BUFFER,444) J,Z(J),XIC(J) -C 444 FORMAT(1X,'PCELIM: col=',I6,' Z=',D12.4,' XIC=',D12.4) -C CALL MYWRT(IOERR,BUFFER) - XIC(J)=0.0 -C -C Zero all unused components of DELTAs. - DO 450 I=1,LORD - DELTAX(J,I)=0.0 - DELTAZ(J,I)=0.0 - DELTAS(J,I)=0.0 - DELTAW(J,I)=0.0 - 450 CONTINUE -C - ENDIF - ENDIF - 460 CONTINUE -C -C -C -C -C Determine the permutation that puts all empty and inactive -C rows at the end of the list. -C - IRUN=3 - CALL EMPTYR(MAXM,M,MNEW,IRUN, - X RWHEAD,STAROW,PERM,INVP,IOERR) -C -C -C Reorder the rows of the LP constraint matrix according to -C the permutation resulting from the analysis of EMPTYR. - IF(MNEW.LT.M) THEN -C - CALL REORDA(MAXM,MAXN,MAXNZA,M,N, - X CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X PERM,INVP,IMTMP1,IMTMP2,RELT, - X RWNAME,STAROW,RWSTAT,RANGES,B,IOERR) -C -C -C Reorder RSCALE, YPROX, P, Q, XIB, Y, LDSQRT and MSPLIT arrays. -C - CALL REORDV(MAXM,M, - X PERM,INVP,RSCALE,RELT,IOERR) - CALL REORDV(MAXM,M, - X PERM,INVP,YPROX,RELT,IOERR) - CALL REORDV(MAXM,M, - X PERM,INVP,P,RELT,IOERR) - CALL REORDV(MAXM,M, - X PERM,INVP,Q,RELT,IOERR) - CALL REORDV(MAXM,M, - X PERM,INVP,XIB,RELT,IOERR) - CALL REORDV(MAXM,M, - X PERM,INVP,Y,RELT,IOERR) - CALL REORDV(MAXM,M, - X PERM,INVP,LDSQRT,RELT,IOERR) - CALL REORDI(MAXM,M, - X PERM,INVP,MSPLIT,IMTMP1(1),IOERR) -C -C -C -C Reorder elements within each column of the LP constraint -C matrix in such a way that those of the active part of A -C are at the beginning of the lists. The column lengths will -C later be decreased to forget inactive part of matrix A. -C Set the new row linked lists of nonzero elements of matrix A. -C Recall that CLPNTS(j) indicates the first entry of column j. -C Zero RWHEAD array. - DO 620 I=1,M - RWHEAD(I)=0 - 620 CONTINUE - DO 700 J=1,N - IF(.NOT.VUSED(J)) GO TO 700 - KBEG=CLPNTS(J)-1 - KOK=0 - KOUT=0 - DO 640 IKX=1,LENCOL(J) - K=KBEG+IKX - I=RWNMBS(K) - IF(I.LE.MNEW) THEN - KOK=KOK+1 - IROW(KOK)=RWNMBS(K) - RELT(KOK)=ACOEFF(K) - ELSE - IPOS=LENCOL(J)-KOUT - KOUT=KOUT+1 - IROW(IPOS)=RWNMBS(K) - RELT(IPOS)=ACOEFF(K) - ENDIF - 640 CONTINUE -C -C Set the row linked lists. - DO 660 IKX=1,LENCOL(J) - K=KBEG+IKX - I=IROW(IKX) - RWNMBS(K)=I - ACOEFF(K)=RELT(IKX) - RWLINK(K)=RWHEAD(I) - RWHEAD(I)=K - 660 CONTINUE - 700 CONTINUE -C -C -C -C -C Update the column lengths of the active part of the LP -C constraint matrix. Mark all eliminated slacks. - DO 720 J=1,N - LENCOL(J)=LENCOL(J)-INTMP1(J) - IF(LENCOL(J).EQ.0.AND.J.GT.NSTRCT) THEN - STAVAR(J)=14 - VUSED(J)=.FALSE. - ENDIF - 720 CONTINUE -C -C -C Prepare data structures for the new Cholesky matrix. - IF(M-MNEW.GT.M/50.OR.NFIX.GT.NSTRCT/20) THEN -C -C Repeat symbolic factorization. - CALL SYMFCT(LLINKS,IROW, - X LCLPTS,LRWNBS,MAXNZL,MAXM,MAXN,MAXNZA,MNEW, - X HEADER,LINKFD,LINKBK,IMTMP1,IMTMP2,STAVAR, - X CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL,IOERR) -C - ELSE -C -C Compress data structures for Cholesky matrix. - CALL SYMREF(MAXNZL,MAXM,M,MNEW, - X LCLPTS,LRWNBS,PERM,INVP,IOERR) -C - ENDIF -C -C -C Set the new number of rows of the constraint matrix. - M=MNEW -C -C -C -C -C Recompute the residual of the dual constraint. -C -C XIC := c - At*y - z + w -C -C CALL SATY(RWORK,IWORK,RMAP,IMAP,Y,M,XIC,N, -C X IROW,RELT,MAXN,IOERR) - CALL FSATY(MAXM,MAXN,MAXNZA,Y,M,XIC,N, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)),IWORK(IMAP(6)), - X VUSED,IOERR) - DO 780 J=1,N - IF(VUSED(J)) THEN - XIC(J)=C(J)-XIC(J)-Z(J) - IF(VBNDED(J)) THEN - XIC(J)=XIC(J)+W(J) - IF(XIC(J).LT.0.0D0) THEN - Z(J)=Z(J)-XIC(J) - XIC(J)=0.0D0 - ENDIF - ENDIF - ENDIF - 780 CONTINUE - ENDIF -C -C -C -C Write the LP problem statistics. - KNZ=0 - DO 880 J=1,N - IF(VUSED(J)) THEN - IF(STAVAR(J).LT.0) THEN - K=-STAVAR(J) - IF(J.GE.K) GO TO 880 - ENDIF - KNZ=KNZ+LENCOL(J) - ENDIF - 880 CONTINUE -C - WRITE(BUFFER,891) - 891 FORMAT(1X,'PCELIM: New LP problem statistics:') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,892) M - 892 FORMAT(1X,' Constraints ',I13) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,893) KNZ - 893 FORMAT(1X,' Nonzero elts in A ',I13) - CALL MYWRT(IOERR,BUFFER) -C - RETURN -C -C -C Here if an error occurs. - 9020 WRITE(BUFFER,9021) I,RWNAME(I),B(I) - 9021 FORMAT(1X,'PCELIM: Constraint ',I6,' (name=',A8, - X ') is violated, slack=',D12.6) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9022) - 9022 FORMAT(1X,'PCELIM: Problem is infeasible.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9030 WRITE(BUFFER,9031) IR,RWNAME(IR),DP - 9031 FORMAT(1X,'PCELIM: Constraint ',I6,' (name=',A8, - X ') is violated, slack=',D12.6) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9032) - 9032 FORMAT(1X,'PCELIM: Problem is infeasible.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C -C -C *** LAST CARD OF (PCELIM) *** - END //GO.SYSIN DD hopdm.src/pcelim.f echo hopdm.src/pcinit.f 1>&2 sed >hopdm.src/pcinit.f <<'//GO.SYSIN DD hopdm.src/pcinit.f' 's/^-//' -C********************************************************************* -C * PCINIT ... INITIALIZE FOR THE PREDICTOR-CORRECTOR P-D METHOD * -C********************************************************************* -C - SUBROUTINE PCINIT(IXY,LORD,MAXM,MAXN,MAXNZA,MAXNZL,M,N, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X LCOEFF,LCLPTS,LRWNBS,LDIAG,LDSQRT, - X VUSED,VBNDED,HEADER,LINKFD,LINKBK, - X COLNRM,C,STAVAR,P,Q,B,UPBND,THETA,X,Y,S,Z,W, - X DELTAX,DELTAS,DELTAY,DELTAZ,DELTAW, - X INTMP1,RMTMP1,RMTMP2,RNTMP1,RNTMP2,IOERR) -C -C -C -C *** PARAMETERS - INTEGER*4 IXY,LORD,MAXM,MAXN,MAXNZA,MAXNZL,M,N - INTEGER*4 LIWORK,LRWORK,IOERR - INTEGER*4 INTMP1(MAXN),IROW(MAXN) - DOUBLE PRECISION RMTMP1(MAXM),RMTMP2(MAXM) - DOUBLE PRECISION RNTMP1(MAXN),RNTMP2(MAXN),RELT(MAXN) - INTEGER*2 HEADER(MAXM+1),LINKFD(MAXM+1),LINKBK(MAXM+1) - LOGICAL VUSED(MAXN),VBNDED(MAXN) - INTEGER*2 STAVAR(MAXN) - DOUBLE PRECISION COLNRM(MAXN),P(MAXM),Q(MAXM) - DOUBLE PRECISION C(MAXN),B(MAXM),X(MAXN),S(MAXN),Y(MAXM) - DOUBLE PRECISION Z(MAXN),W(MAXN),UPBND(MAXN),THETA(MAXN) - DOUBLE PRECISION DELTAX(MAXN,LORD),DELTAS(MAXN,LORD) - DOUBLE PRECISION DELTAY(MAXM,LORD) - DOUBLE PRECISION DELTAZ(MAXN,LORD),DELTAW(MAXN,LORD) -C -C *** DATA STRUCTURES FOR CHOLESKY FACTOR - DOUBLE PRECISION LCOEFF(MAXNZL) - DOUBLE PRECISION LDIAG(MAXM),LDSQRT(MAXM) - INTEGER*4 LCLPTS(MAXM+1) - INTEGER*2 LRWNBS(MAXNZL) -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(LIWORK),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(LRWORK) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,J,K,LX,LS,MKSQRT - DOUBLE PRECISION XMIN,SMIN,ZMIN,WMIN - DOUBLE PRECISION DP,DD,XJP,SJP,ZJD,WJD,SX,SS,SZ,SW,XZSW - CHARACTER*100 BUFFER -C -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C -C IXY Indicates the method of setting initial values: -C 1 Altman and Gondzio (92) combined with Mehrotra (91). -C 2 y(i)=0 x(j)=s(j)=N/||Aj|| and z(j)=w(j)=||Aj||. -C 4 FAP: y(i)=0 and x(j):=min{x0,UPBND(j)/2}, where x0=1. -C LORD The highest degree of computed derivatives of x,s,y,z,w -C (order of Mehrotra's method). -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C N Number of columns of the LP constraint matrix. -C -C LCOEFF Off-diagonal nonzero coefficients of Cholesky matrix. -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C LDIAG Diagonal elements of Cholesky factor. -C LDSQRT Square roots of the diagonal elements of Cholesky factor. -C -C HEADER Header of the doubly linked lists. -C LINKFD Forward linked lists. -C LINKBK Backward linked lists. -C -C INTMP1 Integer work array of size MAXN. -C IROW and RELT are the arrays for temporary handling -C of rows/columns of the constraint matrix. They -C are primarily intended to handle sparse vectors -C (in packed form) but may also be used for storing -C dense ones. -C RMTMP1 Double precision work array of size MAXM. -C RMTMP2 Double precision work array of size MAXM. -C RNTMP1 Double precision work array of size MAXN. -C RNTMP2 Double precision work array of size MAXN. -C -C COLNRM Infinity morms of columns of A. -C C Objective function coefficients. -C P LOWER bounds on shadow prices (dual variables). -C Q UPPER bounds on shadow prices (dual variables). -C VUSED An indicator if a variable is active in the optimization -C process: -C .TRUE. active variable; -C .FALSE. FIXED variable. -C VBNDED An indicator if a variable has an UPPER bound: -C .TRUE. UPPER bounded variable; -C .FALSE. UNBOUNDED variable; -C STAVAR Array of variable status. -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C 7 (or larger) PRESUMED OPTIMAL variable i.e.: x = x0; -C -k free variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status. -C B Right-hand-side of the linear program. -C UPBND Upper bounds for primal variables X. -C THETA Diagonal weight matrix. -C -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C -C X Primal variables of the linear program. -C S Primal slack variables of the linear program. -C Y Dual variables of the linear program. -C Z Dual slack variables of the linear program. -C W Dual slack variables of the linear program. -C DELTAX(*,L) L-th derivative of x(alpha) (for alpha=1) with -C respect to alpha divided by l!. -C DELTAS(*,L) L-th derivative of s(alpha) (for alpha=1) with -C respect to alpha divided by l!. -C DELTAY(*,L) L-th derivative of y(alpha) (for alpha=1) with -C respect to alpha divided by l!. -C DELTAZ(*,L) L-th derivative of z(alpha) (for alpha=1) with -C respect to alpha divided by l!. -C DELTAW(*,L) L-th derivative of w(alpha) (for alpha=1) with -C respect to alpha divided by l!. -C -C -C -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real work array containing almost all real -C LP problem data. -C IWORK Integer work array containing almost all integer -C LP problem data. -C RMAP Map of RWORK. -C IMAP Map of IWORK. -C -C Map of IWORK array: -C IMAP(1) Points to CLPNTS array. -C IMAP(2) Points to RWNMBS array. -C IMAP(3) Points to RWHEAD array. -C IMAP(4) Points to RWLINK array. -C IMAP(5) Points to CLNMBS array. -C IMAP(6) Points to LENCOL array. -C IMAP(7) Points to the first empty cell of IWORK array. -C -C Map of RWORK array: -C RMAP(1) Points to ACOEFF array. -C RMAP(2) Points to COBJ array. -C RMAP(3) Points to RHS array. -C RMAP(4) Points to the first empty cell of RWORK array. -C -C -C -C *** LOCAL VARIABLES DESCRIPTION -C DP Stepsize in primal space. -C DD Stepsize in dual space. -C XZSW Conmplementarity gap (xt*z+st*w). -C XMIN Minimal value of x(j),j=1,...,n. -C SMIN Minimal value of s(j),j=1,...,n. -C ZMIN Minimal value of z(j),j=1,...,n. -C WMIN Minimal value of w(j),j=1,...,n. -C -C -C -C *** SUBROUTINES CALLED: -C FACTOR,SOLAAT,GETCOL,SAX,SATY,SAXPY,DABS,DMAX1 -C -C -C *** PURPOSE: -C This routine initializes primal variable X, dual variable Y -C and all the slack variables S, Z, W for the higher order -C primal-dual logarithmic barrier interior point method of -C Mehrotra (1991). -C -C We start from the solution of the following optimization -C problems: -C min{|(x,s)|:A*x=b, x+s=upbnd} and -C min{|(z,w)|:At*y+z-w=c}. -C Solution of the first problem: -C v = (A*At)**(-1)*(A*upbnd-2*b), -C x = (upbnd-At*v)/2, -C s = upbnd - x. -C Solution of the second problem: -C y = (A*At)**(-1)*(A*c), -C z = (At*y-c)/2, -C w=-z. -C -C Next we define stepsizes in primal and dual spaces: -C dp:=max{-1.5*min[x(j)],-1.5*min[s(j)],0} and -C dd:=max{-1.5*min[z(j)],-1.5*min[w(j)],0}. -C and modify dp and dd: -C dp:=dp+0.5*xzsw/(sz+sw), -C dd:=dd+0.5*xzsw/(sx+ss), where -C xzsw=(x+dp*e)t*(z+dd*e)+(s+dp*e)t*(w+dd*e), -C sx=sum_{j=1}^{n}{x(j)}, -C ss=sum_{j=1}^{n}{s(j)}, -C sz=sum_{j=1}^{n}{z(j)}, -C sw=sum_{j=1}^{n}{w(j)}, and -C x:=x+dp*e, s:=s+dp*e, z:= z+dd*e, w:=w+dd*e (y is unaltered). -C -C -C -C -C -C *** REFERENCES: -C Altman A., Gondzio J. (1992). An efficient implementation -C of a higher order primal-dual interior point method -C for large sparse linear programs, Archives of Control -C Sciences (to appear). -C Altman A., Gondzio J. (1993). HOPDM - A higher order primal- -C dual method for large scale linear programmming, European -C Journal of Operational Research 66 (1993) pp 158-160. -C Lustig I., Marsten R., Shanno D.F. (1992). On implementing -C Mehrotra's predictor-corrector interior point method for -C linear programming, SIAM Journal on Optimization 2, -C No 3, pp. 435-449. -C Mehrotra S. (1992): On the Implementation of a Primal-Dual -C Interior Point Method, SIAM Journal on Optimization 2, -C No 4, pp. 575-601. -C Mehrotra S. (1991): Higher Order Methods and their Performance, -C Technical Report 90-16R1, Department of Industrial Engineering -C and Management Sciences, Northwestern University, Evanston, -C Illinois 60208-3119, U.S.A. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, -C Systems Research Institute, -C Polish Academy of Sciences, -C Newelska 6, 01-447 Warsaw, Poland. -C Last modified: February 12, 1994 -C -C -C -C -C -C *** BODY OF (PCINIT) *** -C -C -C -C WRITE(BUFFER,101) M,N,MAXM,MAXN -C 101 FORMAT(1X,'PCINIT: M=',I6,' N=',I6,' MAXM=',I6,' MAXN=',I6) -C CALL MYWRT(IOERR,BUFFER) -C DO 200 J=1,N -C WRITE(BUFFER,201) J,STAVAR(J),C(J) -C 201 FORMAT(1X,'PCINIT: cl=',I6,' st=',I6,' Cj=',D10.3) -C CALL MYWRT(IOERR,BUFFER) -C 200 CONTINUE -C -C -C -C -C IXY=2 - IF(IXY.EQ.1) THEN -C -C Here for a combination of Altman & Gondzio '92 and Mehrotra '91 -C starting point. -C -C Let Au and An denote columns of A that refer to -C UPPER bounded and UNBOUNDED variables, respectively. -C Note that modified UPPER bounds (RNTMP2 array) will be used. -C -C Before initializing primal and dual variables, set THETA -C array appropriate for an auxiliary QP problem. -C Define RNTMP2 array i.e. modified variables' UPPER bounds. -C Compute Au*THETA*upbnd and store in RMTMP2. -C Compute THETA*c and store in RNTMP1. -C - DO 1100 I=1,M - RMTMP2(I)=B(I) - 1100 CONTINUE - DO 1200 J=1,N - THETA(J)=0.0D0 - IF(VUSED(J)) THEN - THETA(J)=1.0D0 - RNTMP1(J)=C(J) - IF(VBNDED(J)) THEN - THETA(J)=0.5 - RNTMP1(J)=0.5*C(J) - RNTMP2(J)=UPBND(J) - IF(UPBND(J).LE.1.0D-2) RNTMP2(J)=1.0D-2 - IF(UPBND(J).GE.1.0D+3) RNTMP2(J)=1.0D+3 -C WRITE(BUFFER,1201) J,C(J),RNTMP1(J),UPBND(J),RNTMP2(J) -C1201 FORMAT(1X,'J=',I6,' Cj=',D10.3,' RNTMP1=',D10.3, -C X ' UP=',D10.3,' UPnew=',D10.3) -C CALL MYWRT(IOERR,BUFFER) - DP=-0.5*RNTMP2(J) - CALL GETCOL(J,RWORK,IWORK,RMAP,IMAP, - X IROW,RELT,K,MAXN,IOERR) - CALL SAXPY(IROW,RELT,K,RMTMP2,DP) - ENDIF - ENDIF - 1200 CONTINUE -C -C -C Factorize A*THETA*Atransp matrix. -C - MKSQRT=0 - CALL FACTOR(MAXM,MAXN,MAXNZA,MAXNZL,M, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK, - X IROW,RELT,HEADER,LINKFD,LINKBK,THETA,STAVAR, - X LCOEFF,LDIAG,LDSQRT,LCLPTS,LRWNBS,MKSQRT,IOERR) -C -C -C Recall that RMTMP2:=b-Au*THETA*upbnd -C Compute y - CALL SOLAAT(LCOEFF,LCLPTS,LRWNBS,LDIAG, - X MAXNZL,MAXM,M,Y,RMTMP2,IOERR) -C -C Compute z:=At*y - CALL SATY(RWORK,IWORK,RMAP,IMAP,Y,M,Z,N, - X IROW,RELT,MAXN,IOERR) -C -C Compute x:= THETA*(upbnd+At*y) - DO 1300 J=1,N - IF(VUSED(J)) THEN - X(J)=THETA(J)*Z(J) - IF(VBNDED(J)) THEN - X(J)=THETA(J)*(RNTMP2(J)+Z(J)) - S(J)=UPBND(J)-X(J) - ENDIF - ENDIF - 1300 CONTINUE -C -C -C Set up initial values of the dual variables Y, Z and W. -C -C Compute RMTMP2=A*THETA*c - CALL SAX(RWORK,IWORK,RMAP,IMAP,STAVAR,RNTMP1,N,RMTMP2,M, - X IROW,RELT,MAXN,IOERR) -C -C Compute y - CALL SOLAAT(LCOEFF,LCLPTS,LRWNBS,LDIAG, - X MAXNZL,MAXM,M,Y,RMTMP2,IOERR) -C -C Correct infeasible dual variables. - LX=0 - LS=0 - DO 1400 I=1,M - IF(Y(I).LT.P(I)) THEN -C WRITE(BUFFER,1401) I,P(I),Y(I),Q(I) -C1401 FORMAT(1X,'rw=',I6,' Pi=',D12.4,' Yi=',D12.4, -C X ' Qi=',D12.4) -C CALL MYWRT(IOERR,BUFFER) - LX=LX+1 -C Y(I)=(P(I)+Y(I))/2.0 - Y(I)=P(I) - ENDIF - IF(Y(I).GT.Q(I)) THEN -C WRITE(BUFFER,1402) I,P(I),Y(I),Q(I) -C1402 FORMAT(1X,'rw=',I6,' Pi=',D12.4,' Yi=',D12.4, -C X ' Qi=',D12.4) -C CALL MYWRT(IOERR,BUFFER) - LS=LS+1 -C Y(I)=(Q(I)+Y(I))/2.0 - Y(I)=Q(I) - ENDIF - 1400 CONTINUE -C -C *** DEBUGGING -C WRITE(BUFFER,1403) LX,LS -C1403 FORMAT(1X,'PCINIT: Dual var. corrected: Pi=',I6,' Qi=',I6) -C CALL MYWRT(IOERR,BUFFER) -C -C Compute z:=At*y - CALL SATY(RWORK,IWORK,RMAP,IMAP,Y,M,Z,N, - X IROW,RELT,MAXN,IOERR) -C -C Compute z:=THETA*(c-At*y) -C Compute w:= -z - DO 1500 J=1,N - IF(VUSED(J)) THEN - Z(J)=C(J)-Z(J) - IF(VBNDED(J)) THEN - Z(J)=THETA(J)*Z(J) - W(J)=-Z(J) - ENDIF -C IF(J.GT.50) GO TO 1500 -C WRITE(BUFFER,1501) J,C(J),Z(J),W(J) -C1501 FORMAT(1X,'1501F: J=',I6,' C=',D10.3, -C X ' Z=',D10.3,' W=',D10.3) -C CALL MYWRT(IOERR,BUFFER) - ENDIF - 1500 CONTINUE -C -C Compute XMIN,SMIN,ZMIN and WMIN. - XMIN=1.0D10 - ZMIN=1.0D10 - SMIN=1.0D10 - WMIN=1.0D10 - DO 1600 J=1,N - IF(VUSED(J)) THEN - IF(X(J).LT.XMIN) XMIN=X(J) - IF(Z(J).LT.ZMIN) ZMIN=Z(J) - IF(VBNDED(J)) THEN - IF(S(J).LT.SMIN) SMIN=S(J) - IF(W(J).LT.WMIN) WMIN=W(J) - ENDIF - ENDIF - 1600 CONTINUE - DP=DMAX1(-1.5*XMIN,-1.5*SMIN,0.001D0) - DD=DMAX1(-1.5*ZMIN,-1.5*WMIN,0.001D0) -C WRITE(BUFFER,1601) DP,DD -C1601 FORMAT(1X,'after 1600 loop: DP=',D10.3,' DD=',D10.3) -C CALL MYWRT(IOERR,BUFFER) -C -C Compute xzsw=(x+dp*e)t*(z+dd*e)+(s+dp*e)t*(w+dd*e) -C sx=sum_{j=1}^{n}{x(J)}, -C ss=sum_{j=1}^{n}{s(J)}, -C sz=sum_{j=1}^{n}{z(J)}, -C sw=sum_{j=1}^{n}{w(J)}. - SX=0. - SS=0. - SZ=0. - SW=0. - XZSW=0. - DO 1700 J=1,N - IF(VUSED(J)) THEN - XJP=X(J)+DP - ZJD=Z(J)+DD - SX=SX+XJP - SZ=SZ+ZJD - XZSW=XZSW+XJP*ZJD - IF(VBNDED(J)) THEN - SJP=S(J)+DP - WJD=W(J)+DD - SS=SS+SJP - SW=SW+WJD - XZSW=XZSW+SJP*WJD - ENDIF -C IF(J.GT.50) GO TO 1700 -C WRITE(BUFFER,1701) J,STAVAR(J),X(J),S(J),Z(J),W(J) -C1701 FORMAT(1X,'1701F, J=',I6,' st=',I6,' X=',D10.3,' S=', -C X D10.3,' Z=',D10.3' W=',D10.3) -C CALL MYWRT(IOERR,BUFFER) - ENDIF - 1700 CONTINUE -C WRITE(BUFFER,1702) SX,SS,SZ,SW -C1702 FORMAT(1X,'FINAL: SX=',D10.3,' SS=',D10.3, -C X ' SZ=',D10.3,' SW=',D10.3) -C CALL MYWRT(IOERR,BUFFER) - DP=DP+0.5*XZSW/(SZ+SW) - DD=DD+0.5*XZSW/(SX+SS) -C WRITE(BUFFER,1703) DP,DD -C1703 FORMAT(1X,'after 1700 loop: DP=',D10.3,' DD=',D10.3) -C CALL MYWRT(IOERR,BUFFER) - DO 1800 J=1,N - IF(VUSED(J)) THEN - X(J)=X(J)+DP - Z(J)=Z(J)+DD - IF(VBNDED(J)) THEN - S(J)=S(J)+DP - W(J)=W(J)+DD - ENDIF -C WRITE(BUFFER,1801) J,STAVAR(J),X(J),S(J),Z(J),W(J) -C1801 FORMAT(1X,'1801F, J=',I6,' st=',I6,' X=',D10.3,' S=', -C X D10.3,' Z=',D10.3' W=',D10.3) -C CALL MYWRT(IOERR,BUFFER) - ENDIF - 1800 CONTINUE - GO TO 8000 -C - ENDIF -C -C -C -C - IF(IXY.EQ.2) THEN -C -C Here for a new primitive starting point. -C -C Initialize primal variables: Xj, Sj = N/||Aj||. -C Initialize dual variables: Zj, Wj = ||Aj||. -C Bound them all away from zero. -C - DP=DBLE(N) - XMIN=1.0D0 - ZMIN=1.0D0 - SMIN=1.0D0 - WMIN=1.0D0 - DO 2100 J=1,N - IF(VUSED(J)) THEN - X(J)=DP/COLNRM(J) - IF(X(J).LE.XMIN) X(J)=XMIN - Z(J)=COLNRM(J) - IF(Z(J).LE.ZMIN) Z(J)=ZMIN - IF(VBNDED(J)) THEN - S(J)=UPBND(J)-X(J) - IF(S(J).LE.X(J)) S(J)=X(J) - W(J)=COLNRM(J) - IF(W(J).LE.WMIN) W(J)=WMIN - ENDIF - ENDIF - 2100 CONTINUE -C -C -C Initialize dual variables: Yi = 0.0 and correct -C if infeasible. - LX=0 - LS=0 - DO 2200 I=1,M - Y(I)=0.0D0 - IF(Y(I).LT.P(I)) THEN -C WRITE(BUFFER,2201) I,P(I),Y(I),Q(I) -C2201 FORMAT(1X,'rw=',I6,' Pi=',D12.4,' Yi=',D12.4, -C X ' Qi=',D12.4) -C CALL MYWRT(IOERR,BUFFER) - LX=LX+1 -C Y(I)=(P(I)+Y(I))/2.0 - Y(I)=P(I) - ENDIF - IF(Y(I).GT.Q(I)) THEN -C WRITE(BUFFER,2202) I,P(I),Y(I),Q(I) -C2202 FORMAT(1X,'rw=',I6,' Pi=',D12.4,' Yi=',D12.4, -C X ' Qi=',D12.4) -C CALL MYWRT(IOERR,BUFFER) - LS=LS+1 -C Y(I)=(Q(I)+Y(I))/2.0 - Y(I)=Q(I) - ENDIF - 2200 CONTINUE -C -C *** DEBUGGING - WRITE(BUFFER,2203) LX,LS - 2203 FORMAT(1X,'PCINIT: Dual var. corrected: Pi=',I6,' Qi=',I6) - CALL MYWRT(IOERR,BUFFER) - GO TO 8000 -C - ENDIF -C -C -C -C - IF(IXY.EQ.4) THEN -C -C Here for FAP starting point. -C -C Initialize primal variables: Xj = 0.5, Sj = Uj-Xj -C and bound them away from zero. -C - DP=0.5D0 - DO 4100 J=1,N - IF(VUSED(J)) THEN - X(J)=DP - IF(STAVAR(J).EQ.0) X(J)=2.0D1 - IF(VBNDED(J)) THEN - IF(UPBND(J).GE.1.0D+2) X(J)=2.0D1 - S(J)=UPBND(J)-X(J) - IF(S(J).LE.DP) S(J)=DP - ENDIF - ENDIF - 4100 CONTINUE -C -C Initialize dual variables: Yi = 0.0 - DO 4200 I=1,M - Y(I)=0.0D0 - 4200 CONTINUE -C -C Initialize dual slack variables: Zj - Wj = Cj -C and bound them both away from zero. - DP=0.2D0 - DO 4300 J=1,N - IF(VUSED(J)) THEN - IF(C(J).GE.DP) THEN - Z(J)=C(J) - ELSE - Z(J)=DP - ENDIF - IF(VBNDED(J)) THEN - IF(C(J).GE.0.0D0) THEN - W(J)=DP - Z(J)=C(J)+W(J) - ELSE - Z(J)=DP - W(J)=Z(J)-C(J) - ENDIF - ENDIF - ENDIF - 4300 CONTINUE - GO TO 8000 -C - ENDIF -C -C -C -C -C Zero all unused components of DELTAs. - 8000 DO 8500 I=1,LORD - DO 8400 J=1,N - DELTAX(J,I)=0.0 - DELTAZ(J,I)=0.0 - DELTAS(J,I)=0.0 - DELTAW(J,I)=0.0 -C IF(I.NE.1) GO TO 8400 -C WRITE(BUFFER,8001) J,STAVAR(J),X(J),S(J),Z(J),W(J) -C8001 FORMAT(1X,'J=',I6,' st=',I6,' X=',D10.3,' S=',D10.3, -C X ' Z=',D10.3' W=',D10.3) -C CALL MYWRT(IOERR,BUFFER) - 8400 CONTINUE - 8500 CONTINUE -C -C -C - RETURN -C -C -C *** LAST CARD OF (PCINIT) *** - END //GO.SYSIN DD hopdm.src/pcinit.f echo hopdm.src/pcpdm.f 1>&2 sed >hopdm.src/pcpdm.f <<'//GO.SYSIN DD hopdm.src/pcpdm.f' 's/^-//' -C************************************************************** -C *** PCPDM ... PREDICTOR-CORRECTOR PRIMAL-DUAL METHOD *** -C *** DRIVER ROUTINE OF THE HOPDM LIBRARY *** -C *** Release 2.11, April 6, 1995 *** -C************************************************************** -C - SUBROUTINE PCPDM(TCODE,LORD,MAXM,MAXN,MAXNZA,MAXNZL, - X M,MFINAL,N,NSTRCT,NZA, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X INTMP1,IXCHNG,ISCHNG,IMTMP1,IMTMP2, - X RMTMP1,RMTMP2,RMTMP3,RNTMP1,RNTMP2,RNTMP3, - X PERM,INVP,HEADER,LINKFD,LINKBK, - X VUSED,VBNDED,C,UPBND,B,RANGES, - X THETA,XIB,XIC,XIU,DDD,GGG,HHH,FNEW, - X COLNRM,X,S,Y,Z,W, - X DELTAX,DELTAS,DELTAY,DELTAZ,DELTAW,YPROX, - X LCOEFF,LDIAG,LDSQRT,LCLPTS,LRWNBS,LLINKS, - X RSCALE,CSCALE,STAVAR,P,Q,STAROW,RWSTAT,RWNAME,IOERR) -C -C -C -C *** PARAMETERS - INTEGER*4 LORD,MAXM,MAXN,MAXNZA,MAXNZL,M,MFINAL,N,NSTRCT,NZA - INTEGER*4 TCODE,LIWORK,LRWORK,IOERR -C - INTEGER*4 INTMP1(MAXN),IROW(MAXN) - INTEGER*2 IXCHNG(MAXN),ISCHNG(MAXN) - DOUBLE PRECISION RELT(MAXN) - INTEGER*4 IMTMP1(MAXM+1),IMTMP2(MAXM+1) - DOUBLE PRECISION RMTMP1(MAXM),RMTMP2(MAXM),RMTMP3(MAXM) - DOUBLE PRECISION RNTMP1(MAXN),RNTMP2(MAXN),RNTMP3(MAXN) -C -C *** The following arrays can be half-length integer. - INTEGER*2 PERM(MAXM),INVP(MAXM) - INTEGER*2 HEADER(MAXM+1),LINKFD(MAXM+1),LINKBK(MAXM+1) -C - LOGICAL VUSED(MAXN),VBNDED(MAXN) - DOUBLE PRECISION C(MAXN),B(MAXM),UPBND(MAXN),RANGES(MAXM) - DOUBLE PRECISION THETA(MAXN),XIB(MAXM),XIC(MAXN),XIU(MAXN) - DOUBLE PRECISION DDD(MAXM),GGG(MAXN),HHH(MAXN),FNEW(MAXN) - DOUBLE PRECISION COLNRM(MAXN) - DOUBLE PRECISION X(MAXN),S(MAXN),Y(MAXM),Z(MAXN),W(MAXN) - DOUBLE PRECISION DELTAX(MAXN,LORD),DELTAS(MAXN,LORD) - DOUBLE PRECISION DELTAY(MAXM,LORD),YPROX(MAXM) - DOUBLE PRECISION DELTAZ(MAXN,LORD),DELTAW(MAXN,LORD) - DOUBLE PRECISION RSCALE(MAXM),CSCALE(MAXN),P(MAXM),Q(MAXM) - INTEGER*2 STAVAR(MAXN),STAROW(MAXM),RWSTAT(MAXM) - CHARACTER*8 RWNAME(MAXM) -C -C -C *** DATA STRUCTURES FOR CHOLESKY FACTOR - DOUBLE PRECISION LCOEFF(MAXNZL) - DOUBLE PRECISION LDIAG(MAXM),LDSQRT(MAXM) - INTEGER*4 LCLPTS(MAXM+1),LLINKS(MAXNZL) - INTEGER*2 LRWNBS(MAXNZL) -C -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(LIWORK),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(LRWORK) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,ISTEP,ITER,IDIR,IRUN,IPRTRB,ITREF,IXY,IPUSH - INTEGER*4 IALARM,IORDER,MAXORD,IFREE - INTEGER*4 J,K,LX,LS,LZ,LW,LTIME,MKSQRT,M0,MOUT,NFIX,NOUT - INTEGER*4 ELMFRQ - DOUBLE PRECISION ERR0,ERRB,ERRU,ERRC - DOUBLE PRECISION OLDGAP,DLGAP,DP,OBJ,POBJ,DOBJ,POBJ0,DOBJ0 - DOUBLE PRECISION BARR,OLDBAR,PDBARR,BARPAR,BARRMX,T,AX,AS,AZ,AW - DOUBLE PRECISION DX,DS,DZ,DW,XTZSTW,XZSW,GPMN - DOUBLE PRECISION ALPHA0,ALPHAP,ALPHAD,THMIN,THMAX - DOUBLE PRECISION SAVEP,SAVED,STEP0,STEP1 - DOUBLE PRECISION BETA,RESX,RESY,OSCL2 - CHARACTER*100 BUFFER -C -C Tolerances. - DOUBLE PRECISION STEPMX,DINF,SMALLX,SMALLZ,SMALLT - DOUBLE PRECISION XFIX,YFIX,PRFSBT,DLFSBT -C -C -C -C *** COMMON ARREAS -C Cholesky factorization parameters. - COMMON /CHFCT/ CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN,IDNSRW - DOUBLE PRECISION CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN - INTEGER*4 IDNSRW -C -C Optimality tolerance. - COMMON /OPTLTY/ OPTTOL - DOUBLE PRECISION OPTTOL -C -C Additional Cholesky fact. parameters (interface to HYBRID). - COMMON /CHHYB/ RO,FLOPS,IREG,NZCHL,RTCD - DOUBLE PRECISION RO,FLOPS - INTEGER*4 IREG,NZCHL,RTCD -C -C -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C -C TCODE Termination code: -C 0 OPTIMAL solution found; -C 1 Primal INFEASIBLE (or dual UNBOUNDED); -C 2 Primal UNBOUNDED (or dual INFEASIBLE); -C 3 Fatal accuracy problem; -C 4 Excess iterations/time limit. -C LORD The highest degree of computed derivatives of x,s,y,z,w -C (order of Mehrotra's method). -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C N Number of columns of the LP constraint matrix. -C NZA Current number of nonzeros of the LP constraint matrix. -C -C INTMP1 Integer work array of size MAXN. -C IXCHNG An indicator of changes of variable X. -C ISCHNG An indicator of changes of variable S. -C IMTMP1 Integer work array of size MAXM. -C IMTMP2 Integer work array of size MAXM. -C IROW and RELT are the arrays for temporary handling -C of rows/columns of the constraint matrix. They -C are primarily intended to handle sparse vectors -C (in packed form) but may also be used for storing -C dense ones. -C RMTMP1 Double precision work array of size MAXM. -C RMTMP2 Double precision work array of size MAXM. -C RMTMP3 Double precision work array of size MAXM. -C RNTMP1 Double precision work array of size MAXN. -C RNTMP2 Double precision work array of size MAXN. -C RNTMP3 Double precision work array of size MAXN. -C -C PERM Permutation resulting from the minimum degree ordering. -C INVP Inverse permutation. -C HEADER Header of the doubly linked lists. -C LINKFD Forward linked lists. -C LINKBK Backward linked lists. -C -C VUSED An indicator if a variable is active in the optimization -C process: -C .TRUE. active variable; -C .FALSE. FIXED variable. -C VBNDED An indicator if a variable has an UPPER bound: -C .TRUE. UPPER bounded variable; -C .FALSE. UNBOUNDED variable; -C C Objective function coefficients. -C UPBND Array of upper bounds. Note that the upper bound -C is changed when the variable has a lower bound. -C B Right-hand-side of the linear program. -C RANGES Array of constraint ranges. -C -C THETA Diagonal weight matrix. -C XIB Violation of primal constraints, i.e. b - A * x -C XIC Violation of dual constraints, i.e. c - At*y - z + w -C XIU Violation of variable bounds, i.e. UPBND - x - s -C DDD Work array. It stores: -C XIB (affine dir); -C zero (corr., p-c algorithm). -C zero (corr., pure p-d step). -C GGG Work array. It stores: -C -X*Z*e (affine dir.); -C BARR*e - deltaX*deltaZ*e (corr., p-c algorithm). -C BARR*e (corr., pure p-d step). -C HHH Work array. It stores: -C -S*W*e (affine dir.); -C BARR*e - deltaS*deltaW*e (corr., p-c algorithm). -C BARR*e (corr., pure p-d step). -C FNEW Work array. It stores: -C XIC-X**(-1)*GGG+S**(-1)*HHH-S**(-1)*W*XIU (affine dir); -C -X**(-1)*GGG+S**(-1)*HHH (any corrector step). -C -C COLNRM Infinity morms of columns of A. -C X Primal variables of the linear program. -C S Primal slack variables of the linear program. -C Y Dual variables of the linear program. -C Z Dual slack variables of the linear program. -C W Dual slack variables of the linear program. -C DELTAX(*,L) L-th component of deltaX. -C DELTAS(*,L) L-th component of deltaS. -C DELTAY(*,L) L-th component of deltaY. -C DELTAZ(*,L) L-th component of deltaZ. -C DELTAW(*,L) L-th component of deltaW. -C YPROX Dual proximal point. -C -C LCOEFF Off-diagonal nonzero coefficients of Cholesky matrix. -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C LLINKS Linked lists for Cholesky factor. -C LDIAG Diagonal elements of Cholesky factor. -C LDSQRT Square roots of the diagonal elements of Cholesky factor. -C -C RSCALE Current row scaling factors. -C CSCALE Current column scaling factors. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C 7 (or larger) PRESUMED OPTIMAL variable i.e.: x = x0; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C P LOWER bounds on shadow prices (dual variables). -C Q UPPER bounds on shadow prices (dual variables). -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C RWSTAT Array of row types: -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C RWNAME Array of row names. -C -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real work array containing almost all real -C LP problem data. -C IWORK Integer work array containing almost all integer -C LP problem data. -C RMAP Map of RWORK. -C IMAP Map of IWORK. -C -C Map of IWORK array: -C IMAP(1) Points to CLPNTS array. -C IMAP(2) Points to RWNMBS array. -C IMAP(3) Points to RWHEAD array. -C IMAP(4) Points to RWLINK array. -C IMAP(5) Points to CLNMBS array. -C IMAP(6) Points to LENCOL array. -C IMAP(7) Points to the first empty cell of IWORK array. -C -C Map of RWORK array: -C RMAP(1) Points to ACOEFF array. -C RMAP(2) Points to COBJ array. -C RMAP(3) Points to RHS array. -C RMAP(4) Points to the first empty cell of RWORK array. -C -C -C -C *** LOCAL VARIABLES DESCRIPTION -C -C SMALLX The smallest acceptable value of primal variables (x or s). -C SMALLZ The smallest acceptable value of reduced costs (z or w). -C SMALLT The smallest acceptable value of denominator in theta. -C DINF Acceptable infeasibility of the primal and dual variables. -C It is used to ensure that none of X,S,Z,W gets zero value. -C ERR0 ERRB+ERRU+ERRC for the initial point. -C ERRB max{|xib(i)|:i=1,...,m}. -C ERRU max{|xiu(j)|:i=1,...,n}. -C ERRC max{|xic(j)|:j=1,...,n}. -C PRFSBT Primal feasibility tolerance. As soon as the maximum of -C infinity norms of XIB and XIU is smaller than PRFSBT, -C the current primal solution is presumed feasible. -C DLFSBT Dual feasibility tolerance. As soon as the infinity norm -C of XIC is smaller than DLFSBT, the current dual solution -C is presumed feasible. -C MKSQRT Parameter indicating if square roots of LDIAG are to be -C computed: -C 0 no square roots necessary; -C 1 compute square roots of diagonal matrix. -C ELMFRQ Elimination frequency (elimination is done once ELMFRQ -C iterations). -C BARR Current barrier parameter. -C BARPAR The parameter used in definition of BARR. -C OPTTOL Relative optimality tolerance (duality gap is normalized -C with the dual objective function). -C POBJ Primal objective. -C DOBJ Dual objective. -C DLGAP Duality gap. -C ITER Iteration counter. -C ITREF Number of steps of the iterative refinement process -C to be done to improve the accuracy of solutions -C with the Cholesky factorization of A*THETA*Atransp. -C XFIX Threshold value for fixing primal variables. As soon -C as the primal variable is smaller than XFIX (and the -C appropriate dual slack variable is bounded away from -C zero), the variable is presumed to approach a zero -C optimal value. It is then fixed and eliminated from -C the problem. -C YFIX Threshold value for eliminating LP constraints. As soon -C as the dual variable is smaller than YFIX (and the -C appropriate primal slack variable is bounded away from -C zero), the constraint is presumed to be inactive at the -C optimum. It is then eliminated from the problem. -C RESX Error in the direction (part refering to deltaX). -C RESY Error in the direction (part refering to deltaY). -C -C -C -C -C *** SUBROUTINES CALLED: -C LIMTIM,FACTOR,SAX(FSAX),SATY(FSATY),DABS,DBLE,MYWRT, -C PCINIT,PCCHCK,PCDIR,PCSTEP,PCELIM. -C -C -C -C -C *** PURPOSE: -C This is a driver routine of the HOPDM library. It -C implements a Predictor-Corrector Primal-Dual logarithmic -C barrier interior point Method. Multiple corrections of -C centrality are done to reduce the number of iterations -C on difficult problems. -C -C -C -C *** REFERENCES: -C Altman A., Gondzio J. (1993). An efficient implementation of -C a higher order primal-dual interior point method for large -C sparse linear programs, Archives of Control Sciences 2, -C No 1-2, pp. 23-40. -C Altman A., Gondzio J. (1993). HOPDM - A higher order primal- -C dual method for large scale linear programmming, European -C Journal of Operational Research 66 (1993) pp 158-160. -C Gondzio J. (1992). Splitting dense columns of the constraint -C matrix in interior point methods for large scale linear -C programming, Optimization 24, pp. 285-297. -C Gondzio J. (1993). Implementing Cholesky factorization for -C interior point methods of linear programming, Optimization -C 27, pp. 121-140. -C Gondzio J. (1994). Presolve analysis of linear programs prior -C to applying an interior point method, Technical Report -C No 1994.3, Department of Management Studies, University -C of Geneva, 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, -C February 1994, revised in December 1994. -C Gondzio J. (1994). Multiple centrality corrections in a primal- -C dual method for linear programming, Technical Report -C No 1994.?, Department of Management Studies, University -C of Geneva, 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, -C November 1994. -C Gondzio J., Makowski M. (1995). Solving a class of LP problems -C with a primal-dual logarithmic barrier method, European -C Journal of Operational Research 80, pp. 184-192. -C Gondzio J., Tachat D. (1994). The design and application of -C IPMLO - a FORTRAN library for linear optimization with -C interior point methods, RAIRO Recherche Operationnelle 28, -C No 1, pp. 37-56. -C Lustig I., Marsten R., Shanno D.F. (1992). On implementing -C Mehrotra's predictor-corrector interior point method for -C linear programming, SIAM Journal on Optimization 2, -C No 3, pp. 435-449. -C Mehrotra S. (1992): On the Implementation of a Primal-Dual -C Interior Point Method, SIAM Journal on Optimization 2, -C No 4, pp. 575-601. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, -C Systems Research Institute, -C Polish Academy of Sciences, -C Newelska 6, 01-447 Warsaw, Poland. -C Last modified: April 6, 1995 -C -C -C -C -C -C *** BODY OF (PCPDM) *** -C -C -C -C -C -C Initialize. -C *********** -C -C Set up indicators of variable changes. - DO 20 J=1,N - IXCHNG(J)=0 - ISCHNG(J)=0 - 20 CONTINUE -C -C Define the type of diagonal in LDLt decomposition and the -C required number of steps of the iterative refinement. -C Initialize perturbation counter and an indicator for -C pushing variables away from zero. - MKSQRT=0 - ITREF=2 - IPRTRB=0 - IPUSH=0 - IRUN=0 -C -C Initialize regularizaton parameters. - IREG=0 - RO=1.0D-10 -C -C Save the initial problem size. - M0=M - NOUT=0 -C -C Set up tolerances. - DINF= 1.0D-12 - SMALLX=1.0D-14 - SMALLZ=1.0D-14 - SMALLT=1.0D-20 - STEPMX=1.0D0 - BARPAR=1.1 -C -C Set primal and dual feasibility tolerances. - PRFSBT=1.0D-6 - DLFSBT=1.0D-6 -C -C Define variables for the logic of rows/cols elimination. - ELMFRQ=200 - XFIX=1.0D-6 - YFIX=0.2D-6 - ERRB=0.0 - ERRU=0.0 - ERRC=0.0 - XZSW=1.0D+1*DBLE(N) -C -C Define maximum order of corrector. - MAXORD=2 - AX=FLOPS/DBLE(2*NZCHL+12*N) - IF(AX.GE.0.9D+1) MAXORD=3 - IF(AX.GE.3.0D+1) MAXORD=4 - IF(AX.GE.5.0D+1) MAXORD=5 - IF(AX.GE.1.0D+2) MAXORD=6 - IF(AX.GE.1.5D+2) MAXORD=7 - IF(AX.GE.2.0D+2) MAXORD=8 - IF(AX.GE.2.5D+2) MAXORD=9 - IF(AX.GE.3.0D+2) MAXORD=10 - IF(AX.GE.4.0D+2) MAXORD=11 - IF(AX.GE.5.0D+2) MAXORD=12 - IF(NZCHL.LE.5000) MAXORD=2 - WRITE(BUFFER,41) - 41 FORMAT(1X) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,42) AX,MAXORD-2 - 42 FORMAT(1X,'PCPDM: flopsL/flopsS=',1PD8.2,' MAXORD=',I4) - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) -C -C -C -C Go define a starting point. - IXY=1 - CALL PCINIT(IXY,LORD,MAXM,MAXN,MAXNZA,MAXNZL,M,N, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X LCOEFF,LCLPTS,LRWNBS,LDIAG,LDSQRT, - X VUSED,VBNDED,HEADER,LINKFD,LINKBK, - X COLNRM,C,STAVAR,P,Q,B,UPBND,THETA,X,Y,S,Z,W, - X DELTAX,DELTAS,DELTAY,DELTAZ,DELTAW, - X INTMP1,RMTMP1,RMTMP2,RNTMP1,RNTMP2,IOERR) -C -C Initialize for proximal point algorithm. - IREG=0 - DO 40 I=1,M - YPROX(I)=Y(I) - 40 CONTINUE -C -C -C -C -C -C -C -C Main loop begins here. - ITER=0 - IFREE=0 - 50 ITER=ITER+1 - ALPHA0=0.99995D0 - IF(ITER.GT.200) THEN - WRITE(BUFFER,51) - 51 FORMAT(1X) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,52) - 52 FORMAT(1X,'PCPDM: Excess iterations limit.') - CALL ERRWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) - TCODE=3 - GO TO 2000 - ENDIF -C - CALL LIMTIM(LTIME) - IF(LTIME.NE.0) THEN - WRITE(BUFFER,53) - 53 FORMAT(1X) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,54) ITER-1 - 54 FORMAT(1X,'PDPDM: Excess time limit after ',I4, - X ' iterations.') - CALL ERRWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) - TCODE=3 - GO TO 2000 - ENDIF -C -C -C -C Compute the duality gap and the primal and dual objectives. -C Primal objective POBJ=ct*x -C Dual objective DOBJ=bt*y-upbndt*w -C Duality gap DLGAP=POBJ-DOBJ -C Save the best possible estimate of primal and dual objectives. -C - POBJ=0.0D0 - DO 60 J=1,NSTRCT - IF(VUSED(J)) POBJ=POBJ+C(J)*X(J) - 60 CONTINUE - OBJ=POBJ - DOBJ=0.0D0 - DO 80 I=1,M - DOBJ=DOBJ+B(I)*Y(I) - 80 CONTINUE - DO 90 J=1,N - IF(VUSED(J).AND.VBNDED(J)) DOBJ=DOBJ-UPBND(J)*W(J) - 90 CONTINUE - IF(ITER.EQ.1) THEN - POBJ0=DABS(POBJ)+1.0D-1 - DOBJ0=DABS(DOBJ)+1.0D-1 - OLDGAP=DABS(POBJ-DOBJ)+1.0D0 -C WRITE(BUFFER,81) POBJ0,DOBJ0 -C 81 FORMAT(1X,'init est: POBJ0=',1PD20.12,' DOBJ0=',1PD20.12) -C CALL MYWRT(IOERR,BUFFER) - ELSE - DLGAP=POBJ-DOBJ - IF(DABS(DLGAP).LE.OLDGAP) THEN - POBJ0=DABS(POBJ)+1.0D-6 - DOBJ0=DABS(DOBJ)+1.0D-6 -C WRITE(BUFFER,82) POBJ0,DOBJ0 -C 82 FORMAT(1X,'obj est: POBJ0=',1PD20.12,' DOBJ0=',1PD20.12) -C CALL MYWRT(IOERR,BUFFER) - OLDGAP=DABS(DLGAP) - ENDIF - ENDIF -C -C -C -C Check if the problem is UNBOUNDED/INFEASIBLE. - DP=DABS(POBJ)/POBJ0 - IF(DP.GE.1.0D+4) THEN - WRITE(BUFFER,91) - 91 FORMAT(1X,'PCPDM: Primal is UNBOUNDED (or dual INFEASIBLE)') - CALL ERRWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) - TCODE=2 - GO TO 2000 - ENDIF - DP=DABS(DOBJ)/DOBJ0 - IF(DP.GE.1.0D+4) THEN - WRITE(BUFFER,92) - 92 FORMAT(1X,'PCPDM: Dual is UNBOUNDED (or primal INFEASIBLE)') - CALL ERRWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) - TCODE=1 - GO TO 2000 - ENDIF -C -C -C -C Optimality test. -C WRITE(BUFFER,93) POBJ,DOBJ -C 93 FORMAT(1X,'PCPDM: POBJ=',1PD20.12,' DOBJ=',1PD20.12) -C CALL MYWRT(IOERR,BUFFER) - DP=DABS(DOBJ)+1.0 - DLGAP=POBJ-DOBJ - T=DABS(DLGAP)/DP - IF(ITER.LE.2) T=T+0.5D0 - IF(T.LE.OPTTOL) GO TO 1000 -C -C -C -C -C -C Compute T indicating how far from the optimum we are. - DP=DABS(POBJ)+DABS(DOBJ)+1.0 - T=DABS(DLGAP)/DP - BETA=1.0D0 -C -C -C -C -C Bound the variables away from zero. -C IPUSH indicates if the last direction was accurate. -C Use AS to measure average complementarity gap. -C Use AW to measure average duality gap. -C Use AX to move primal variables X and S. -C Use AZ to move dual variables Z and W. - IF(IPUSH.GE.1) THEN -C -C Here if the previous direction was inaccurate. -C Use stronger perturbation to push variables away from zero. - WRITE(BUFFER,101) - 101 FORMAT(1X,'PCPDM: Errors in the previous direction.') - CALL MYWRT(IOERR,BUFFER) - AS=5.0D-3*XZSW/DBLE(N) - AW=5.0D-4*DABS(DLGAP)/DBLE(N) - IF(AS.LE.AW) AS=AW - IF(IPUSH.GE.2) AS=2.0D0*AS - IF(AS.GT.1.0D0) AS=1.0D0 - AX=1.0D-3*T - IF(AX.LE.1.0D-10) AX=1.0D-10 - IF(IPUSH.GE.2) AX=1.0D+1*AX - AZ=1.0D0*AX - IF(AZ.GE.1.0D-5) AZ=1.0D-5 - RO=1.0D-6 - IF(IPUSH.GE.2) RO=1.0D-5 - IPUSH=0 - GO TO 130 - ELSE -C -C Here if the previous direction was sufficiently accurate. -C Use small perturbation to push variables away from zero. - AS=1.0D-3*XZSW/DBLE(N) - AW=1.0D-4*DABS(DLGAP)/DBLE(N) - IF(AS.LE.AW) AS=AW - IF(ITER.EQ.1.AND.AS.GT.1.0D1) AS=1.0D1 - AX=1.0D-4*T - IF(DABS(POBJ)+DABS(DOBJ).LE.1.0D+2) AX=1.0D-1*AX - IF(DABS(POBJ)+DABS(DOBJ).LE.1.0D+1) AX=1.0D-1*AX - IF(AX.LE.1.0D-12) AX=1.0D-12 - AZ=1.0D0*AX - IF(AZ.GE.1.0D-6) AZ=1.0D-6 - RO=1.0D-8 - IF(T.LE.1.0D-2) RO=1.0D-9 - IF(T.LE.1.0D-4) RO=1.0D-10 - GO TO 130 - ENDIF -C -C -C Here if there were errors in the affine-scaling direction. -C Bound away from zero all components of complementarity gap. -C It is necessary if large errors in Cholesky factors appear. - 110 IPUSH=0 - DO 120 J=1,N - IF(VUSED(J)) THEN - X(J)=X(J)+AX - Z(J)=Z(J)+AZ - IF(VBNDED(J)) THEN - S(J)=S(J)+AX - W(J)=W(J)+AZ - ENDIF - ENDIF - 120 CONTINUE -C WRITE(BUFFER,121) AX,AZ -C 121 FORMAT(1X,'AX=',D9.3,' AZ=',D9.3,' all xszw corrected.') -C CALL MYWRT(IOERR,BUFFER) - GO TO 150 -C -C -C Bound away from zero small components of complementarity gap. -C It prevents blocking the algorithm and improves the accuracy. - 130 CONTINUE -C WRITE(BUFFER,131) T,RO -C 131 FORMAT(1X,'PCPDM: T=',1PD10.4,' penalty term, RO=',1PD10.4) -C CALL MYWRT(IOERR,BUFFER) - LX=0 - LS=0 - LZ=0 - LW=0 - K=0 - DO 140 J=1,N - IF(VUSED(J)) THEN - DP=X(J)*Z(J) - IF(DP.LE.AS) THEN - K=K+1 - IF(X(J).LE.Z(J)) THEN - X(J)=AS/Z(J) - ELSE - Z(J)=AS/X(J) - ENDIF -C WRITE(BUFFER,141) J,STAVAR(J),DP,X(J),Z(J) -C 141 FORMAT(1X,'J=',I6,' st=',I6,' cmpl=',D12.4, -C X ' X=',1PD12.4,' Z=',1PD12.4) -C CALL MYWRT(IOERR,BUFFER) - ENDIF -C IF(DP.GE.1.0D1*XZSW/DBLE(N)) THEN -C WRITE(BUFFER,7141) J,STAVAR(J),DP,X(J),Z(J) -C7141 FORMAT(1X,'J=',I6,' st=',I6,' cmpl=',D12.4, -C X ' X=',1PD12.4,' Z=',1PD12.4) -C CALL MYWRT(IOERR,BUFFER) -C ENDIF - IF(X(J).LE.AX) THEN - LX=LX+1 - X(J)=X(J)+AX/COLNRM(J) - ENDIF - IF(Z(J).LE.AZ) THEN - LZ=LZ+1 - Z(J)=Z(J)+AZ - ENDIF - IF(VBNDED(J)) THEN - DP=S(J)*W(J) - IF(DP.LE.AS) THEN - K=K+1 - IF(S(J).LE.W(J)) THEN - S(J)=AS/W(J) - ELSE - W(J)=AS/S(J) - ENDIF -C WRITE(BUFFER,142) J,STAVAR(J),DP,S(J),W(J) -C 142 FORMAT(1X,'J=',I6,' st=',I6,' cmpl=',D12.4, -C X ' S=',1PD12.4,' W=',1PD12.4) -C CALL MYWRT(IOERR,BUFFER) - ENDIF -C IF(DP.GE.1.0D1*XZSW/DBLE(N)) THEN -C WRITE(BUFFER,7142) J,STAVAR(J),DP,S(J),W(J) -C7142 FORMAT(1X,'J=',I6,' st=',I6,' cmpl=',D12.4, -C X ' S=',1PD12.4,' W=',1PD12.4) -C CALL MYWRT(IOERR,BUFFER) -C ENDIF - IF(S(J).LE.AX) THEN - LS=LS+1 - S(J)=S(J)+AX/COLNRM(J) - ENDIF - IF(W(J).LE.AZ) THEN - LW=LW+1 - W(J)=W(J)+AZ - ENDIF - ENDIF - ENDIF - 140 CONTINUE -C WRITE(BUFFER,146) AS,AW,LX,LS,LZ,LW,K -C 146 FORMAT(1X,'AS=',D9.3,' AW=',D9.3,' xszw=',4(I6,1X),' K=',I6) -C CALL MYWRT(IOERR,BUFFER) -C WRITE(BUFFER,147) AX,AZ -C 147 FORMAT(1X,'AX=',D9.3,' AZ=',D9.3,' xszw.') -C CALL MYWRT(IOERR,BUFFER) -C -C -C -C Compute the residuals of the current solution. - 150 CONTINUE -C -C -C -C Scale columns of A. - IF(IRUN.EQ.0.AND.T.GE.1.0D-2.OR. - X IRUN.EQ.1.AND.T.GE.1.0D-3.OR. - X IRUN.GE.2.AND.T.GE.1.0D-4.OR. - X MOD(ITER,2).NE.0.OR.IRUN.GE.5) GO TO 159 - AX=0.0D0 - IRUN=IRUN+1 - DO 151 J=1,N - IF(VUSED(J)) THEN - IF(DABS(X(J)).GE.AX) AX=DABS(X(J)) - ENDIF - 151 CONTINUE - IF(AX.LE.1.0D+4) GO TO 159 - DO 154 J=1,N - RNTMP1(J)=1.0D0 - IF(DABS(X(J)).GE.1.0D+4) THEN - RNTMP1(J)=1.0D+1 - X(J)=X(J)/RNTMP1(J) - S(J)=S(J)/RNTMP1(J) - Z(J)=Z(J)*RNTMP1(J) - W(J)=W(J)*RNTMP1(J) - COLNRM(J)=COLNRM(J)*RNTMP1(J) - CSCALE(J)=CSCALE(J)/RNTMP1(J) - RNTMP1(J)=1.0D0/RNTMP1(J) - ENDIF - 154 CONTINUE - OSCL2=1.0D0 - CALL SCLCOL(MAXN,MAXNZA,N, - X IWORK(IMAP(1)),IWORK(IMAP(6)),RWORK(RMAP(1)), - X RNTMP1,OSCL2,RWORK(RMAP(2)),UPBND,IOERR) - 159 CONTINUE -C -C -C -C XIB := b - A * x -C - CALL FSAX(MAXM,MAXN,MAXNZA,X,N,XIB,M, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)),IWORK(IMAP(6)), - X VUSED,IOERR) - DO 160 I=1,M - XIB(I)=B(I)-XIB(I) - 160 CONTINUE -C -C XIC := c - At*y - z + w -C XIU := UPBND - x - s -C - CALL FSATY(MAXM,MAXN,MAXNZA,Y,M,XIC,N, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)),IWORK(IMAP(6)), - X VUSED,IOERR) - AS=5.0D0*XZSW/DBLE(N) - AW=1.0D-3*T - DO 180 J=1,N - IF(VUSED(J)) THEN - K=STAVAR(J) - IF(K.LT.0) THEN - IF(IFREE.EQ.0) THEN - IFREE=1 - WRITE(BUFFER,161) - 161 FORMAT(1X,'PCPDM: FREE variables present.') - CALL MYWRT(99,BUFFER) - ENDIF -C -C Treat split FREE variables specially. -C Keep their difference unchanged, but do not let them grow. -C Keep reduced costs sufficiently bounded away from zero. - IF(ITER/3*3.NE.ITER) GO TO 170 - IF(J.GT.-K) GO TO 170 - DP=X(-K)-X(J) -C WRITE(BUFFER,171) -K,J,DP -C 171 FORMAT(1X,' J1=',I6,' J2=',I6,' X1-X2=',1PD10.2) -C CALL MYWRT(IOERR,BUFFER) - AX=5.0D0 - IF(DABS(DP).GE.1.0D+1) AX=1.0D+1 - IF(T.LE.1.0D-4) AX=AX/10.0 - IF(DP.GT.0.0) THEN - IF(X(J).LE.2.0D+1) GO TO 165 - X(J)=0.01*DP+AX - X(-K)=X(J)+DP - ELSE - IF(X(-K).LE.2.0D+1) GO TO 165 - X(-K)=-0.01*DP+AX - X(J)=X(-K)-DP - ENDIF - 165 Z(J)=AS/X(J)+AW - Z(-K)=AS/X(-K)+AW -C WRITE(BUFFER,172) Z(-K),Z(J),X(-K),X(J) -C 172 FORMAT(1X,' Zj1=',1PD10.2,' Zj2=',1PD10.2, -C X ' Xj1=',1PD10.2,' Xj2=',1PD10.2) -C CALL MYWRT(IOERR,BUFFER) - ENDIF - 170 XIC(J)=C(J)-XIC(J)-Z(J) - IF(VBNDED(J)) THEN - XIC(J)=XIC(J)+W(J) - XIU(J)=UPBND(J)-X(J)-S(J) - ENDIF - ENDIF - 180 CONTINUE -C -C -C -C Check the feasibility of the current solution. -C - CALL PCCHCK(MAXM,MAXN,M,N,IOERR, - X ERRB,ERRU,ERRC, - X VUSED,VBNDED,XIB,XIC,XIU) -C -C -C -C Save the initial primal residual. It will later be used -C to determine if a sufficient progress has been made to -C try the rows/columns elimination. - IF(ITER.EQ.1) ERR0=ERRB+ERRU+ERRC -C -C -C -C Eliminate the variables approaching their optimal values -C and the constraints that are inactive at the optimum. -C - IF(MOD(ITER,ELMFRQ).NE.0) GO TO 200 - IF(ERRB+ERRU+ERRC.GT.ERR0*1.0D-4) GO TO 200 - IF(T.GT.1.0D-1) GO TO 200 -C -C CALL PCELIM(LORD,MAXM,MAXN,MAXNZA,MAXNZL, -C X M,N,NSTRCT,NFIX,MOUT, -C X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, -C X LDSQRT,LCLPTS,LRWNBS,LLINKS, -C X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)), -C X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)), -C X INTMP1,IXCHNG,ISCHNG,IMTMP1,IMTMP2,RNTMP1, -C X PERM,INVP,HEADER,LINKFD,LINKBK, -C X PRFSBT,DLFSBT,XIB,XIU,XIC,XFIX,YFIX, -C X X,Y,S,Z,W,DELTAX,DELTAS,DELTAY,DELTAZ,DELTAW,YPROX, -C X VUSED,VBNDED,C,UPBND,P,Q,B,RANGES, -C X RSCALE,CSCALE,STAVAR,STAROW,RWSTAT,RWNAME,IOERR) -C - NOUT=NOUT+NFIX - WRITE(BUFFER,201) NFIX - 201 FORMAT(1X,'PCPDM: Optimal variables ',I13) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,202) MOUT - 202 FORMAT(1X,' Inactive constraints',I13) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C -C -C -C Compute THETA: = (z/x + w/s)**(-1) - 200 THMAX=0.0D0 - THMIN=1.0D+10 - DO 220 J=1,N - IF(.NOT.VUSED(J)) GO TO 220 - IF(VBNDED(J)) THEN -C -C Here for UPPER bounded variable. - DP=Z(J)*S(J)+W(J)*X(J) - IF(DP.LE.SMALLT) THEN - WRITE(BUFFER,221) ITER,J,DP - 221 FORMAT(1X,'PCPDM: Iter=',I6,', J=',I6,' DP=',1PD10.2) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,222) X(J),S(J),Z(J),W(J) - 222 FORMAT(1X,' X(J)=',1PD10.2,' S(J)=',1PD10.2, - X ' Z(J)=',1PD10.2,' W(J)=',1PD10.2) - CALL ERRWRT(IOERR,BUFFER) - TCODE=3 - GO TO 2000 - ENDIF -C IF(Z(J).LE.1.0D-2.OR.W(J).LE.1.0D-2) THEN -C WRITE(BUFFER,223) J,X(J),S(J),Z(J),W(J) -C 223 FORMAT(1X,'J=',I6,' X=',1PD10.2,' S=',1PD10.2, -C X ' Z=',1PD10.2,' W=',1PD10.2) -C CALL MYWRT(IOERR,BUFFER) -C WRITE(BUFFER,224) J,X(J)*Z(J),S(J)*W(J) -C 224 FORMAT(1X,'J=',I6,' XZ=',1PD10.2,' SW=',1PD10.2) -C CALL MYWRT(IOERR,BUFFER) -C ENDIF - THETA(J)=S(J)*X(J)/DP - ELSE -C -C Here for unbounded variable. - DP=Z(J) - IF(DP.LE.SMALLT) THEN - WRITE(BUFFER,226) ITER,J,Z(J) - 226 FORMAT(1X,'PCPDM: Iter=',I6,' Z(',I6,')=',1PD10.2) - CALL ERRWRT(IOERR,BUFFER) - TCODE=3 - GO TO 2000 - ENDIF - THETA(J)=X(J)/DP - ENDIF -C -C Find the largest and the smallest elements of THETA. - IF(THETA(J).LE.THMIN) THMIN=THETA(J) - IF(THETA(J).GE.THMAX) THMAX=THETA(J) - 220 CONTINUE -C -C -C *** DEBUGGING -C WRITE(BUFFER,241) THMIN,THMAX -C 241 FORMAT(1X,'PCPDM: THMIN=',D9.2,' THMAX=',D9.2) -C CALL MYWRT(IOERR,BUFFER) - THMAX=1.0D+10 - DO 240 J=1,N - IF(THETA(J).GE.THMAX) THEN - THETA(J)=DSQRT(THMAX*THETA(J)) - ENDIF - IF(THETA(J).GE.THMAX) THEN - THETA(J)=DSQRT(THMAX*THETA(J)) - ENDIF - 240 CONTINUE -C -C -C -C Factorize A*THETA*Atransp matrix. -C - RO=RO*OPTTOL/1.0D-8 - CALL FACTOR(MAXM,MAXN,MAXNZA,MAXNZL,M, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK, - X INTMP1,RMTMP1, - X HEADER,LINKFD,LINKBK, - X THETA,STAVAR, - X LCOEFF,LDIAG,LDSQRT,LCLPTS,LRWNBS,MKSQRT,IOERR) -C -C -C -C Compute the primal-dual affine scaling direction. -C - XTZSTW=0.0D0 - DO 248 J=1,N - IF(VUSED(J)) THEN - XTZSTW=XTZSTW+X(J)*Z(J) - IF(VBNDED(J)) THEN - XTZSTW=XTZSTW+S(J)*W(J) - ENDIF - ENDIF - 248 CONTINUE - PDBARR=XTZSTW/DBLE(N) - BARR=1.0D-3*PDBARR -C - K=0 - DO 249 J=1,N - IF(VUSED(J)) THEN - DP=X(J)*Z(J) - IF(DP.GE.1.0D+1*PDBARR) THEN - IF(DP.GE.5.0D+1*PDBARR) K=K+1 -C WRITE(BUFFER,246) J,X(J),Z(J),DP/PDBARR -C 246 FORMAT(1X,'J=',I6,' X=',1PD10.2,' Z=',1PD10.2, -C X ' ZX/AVR=',1PD10.2) -C CALL MYWRT(IOERR,BUFFER) - ENDIF - IF(VBNDED(J)) THEN - DP=S(J)*W(J) - IF(DP.GE.1.0D+1*PDBARR) THEN - IF(DP.GE.5.0D+1*PDBARR) K=K+1 -C WRITE(BUFFER,247) J,S(J),W(J),DP/PDBARR -C 247 FORMAT(1X,'J=',I6,' S=',1PD10.2,' W=',1PD10.2, -C X ' SW/AVR=',1PD10.2) -C CALL MYWRT(IOERR,BUFFER) - ENDIF - ENDIF - ENDIF - 249 CONTINUE -C -C -C - IDIR=4 - IORDER=1 - OLDBAR=0.0D0 - ALPHAP=0.0D0 - ALPHAD=0.0D0 -C - CALL PCDIR(IDIR,BARR,OLDBAR,ALPHAP,ALPHAD,SMALLX, - X MAXM,MAXN,MAXNZA,MAXNZL,M,N,ITREF,IALARM, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X LCOEFF,LCLPTS,LRWNBS,LDIAG,LDSQRT, - X STAVAR,VUSED,VBNDED,THETA,XIB,XIC,XIU,DDD,GGG,HHH,FNEW, - X X,Y,S,Z,W,DELTAX,DELTAS,DELTAY,DELTAZ,DELTAW,YPROX, - X RMTMP1,RMTMP2,RMTMP3,RNTMP1,RNTMP2,RNTMP3, - X RESX,RESY,IOERR) - OLDBAR=BARR -C - IF(IALARM.EQ.1) IPUSH=IPUSH+1 - IF(RESX+RESY.GE.1.0D-6) IPUSH=1 - IF(RESX+RESY.GE.1.0D-5) IPUSH=2 - IF(RESX+RESY.GE.1.0D-3) IPUSH=3 -C -C -C -C Check if the primal-dual affine scaling direction is -C computed with sufficient accuracy. If not, then perturb -C the problem and recompute direction. - IF(RESX+RESY.GE.1.0D-5) THEN - IPRTRB=IPRTRB+1 - IF(IPRTRB.GE.5) THEN - WRITE(BUFFER,251) - 251 FORMAT(1X) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,252) - 252 FORMAT(1X,'PCPDM: Exit due to numerical errors.') - CALL ERRWRT(IOERR,BUFFER) - TCODE=3 - GO TO 2000 - ENDIF - WRITE(BUFFER,253) - 253 FORMAT(1X,'PCPDM: Errors in affine-scaling direction.') - CALL MYWRT(IOERR,BUFFER) - AX=1.0D+0*T - AZ=AX - RO=1.0D-5 - IF(RESX+RESY.GE.1.0D-3) RO=1.0D-4 - IF(RESX+RESY.GE.1.0D-1) RO=1.0D-3 - GO TO 110 - ENDIF -C -C -C -C Determine the stepsizes for the primal-dual affine direction. -C -C ax := min{x(j)/deltax(j,1): deltax(j,1)<0, j=1,...,n} -C as := min{s(j)/deltas(j,1): deltas(j,1)<0, j=1,...,n} -C az := min{z(j)/deltaz(j,1): deltaz(j,1)<0, j=1,...,n} -C aw := min{w(j)/deltaw(j,1): deltaw(j,1)<0, j=1,...,n} -C - 260 CONTINUE - CALL PCSTEP(N,LX,AX,X,DELTAX(1,1),IOERR) - CALL PCSTEP(N,LS,AS,S,DELTAS(1,1),IOERR) - CALL PCSTEP(N,LZ,AZ,Z,DELTAZ(1,1),IOERR) - CALL PCSTEP(N,LW,AW,W,DELTAW(1,1),IOERR) -C -C ALPHAP := min{AX,AS,STEPMX} - ALPHAP=AX - IF(AS.LT.ALPHAP) ALPHAP=AS - IF(STEPMX.LT.ALPHAP) ALPHAP=STEPMX -C -C ALPHAD := min{AZ,AW,STEPMX} - ALPHAD=AZ - IF(AW.LT.ALPHAD) ALPHAD=AW - IF(STEPMX.LT.ALPHAD) ALPHAD=STEPMX -C -C *** DEBUGGING - SAVEP=ALPHAP - SAVED=ALPHAD - STEP0=ALPHAP - IF(ALPHAD.LT.STEP0) STEP0=ALPHAD -C WRITE(BUFFER,261) AX,AS,AZ,AW -C 261 FORMAT(1X,'Affine: AX,AS,AZ,AW: ',4D10.2) -C CALL MYWRT(IOERR,BUFFER) -C WRITE(BUFFER,262) ALPHAP,ALPHAD -C 262 FORMAT(1X,' ALPHAP,ALPHAD: ',2D10.2) -C CALL MYWRT(IOERR,BUFFER) -C -C -C -C Compute the current complementarity gap: -C XTZSTW=Xt*Z+St*W. -C -C Compute the minimum complementarity gap that can be achieved -C when moving in a primal-dual affine scaling direction: -C GPMN=(x+ALPHAP*dx)t*(z+ALPHAD*dz)+(s+ALPHAP*ds)t*(w+ALPHAD*dw). -C -C Compute the sum of weighted lengths of dx, ds, dz, dw: -C AZ=dx*theta**(-1)*dx+ds*theta**(-1)*ds+dz*theta*dz+dw*theta*dw. -C - XTZSTW=0.0D0 - GPMN=0.0D0 - AZ=0.0D0 - DO 320 J=1,N - IF(VUSED(J)) THEN - DX=DELTAX(J,1) - DZ=DELTAZ(J,1) - XTZSTW=XTZSTW+X(J)*Z(J) - GPMN=GPMN+(X(J)+ALPHAP*DX)*(Z(J)+ALPHAD*DZ) - AZ=AZ+DX*DX/THETA(J)+DZ*DZ*THETA(J) - IF(VBNDED(J)) THEN - DS=DELTAS(J,1) - DW=DELTAW(J,1) - XTZSTW=XTZSTW+S(J)*W(J) - GPMN=GPMN+(S(J)+ALPHAP*DS)*(W(J)+ALPHAD*DW) - AZ=AZ+DS*DS/THETA(J)+DW*DW*THETA(J) - ENDIF - ENDIF - 320 CONTINUE -C WRITE(BUFFER,321) ITER,XTZSTW,GPMN -C 321 FORMAT(1X,'Iter=',I6,' cmpl=',1PD10.3,' new cmpl=',1PD10.3) -C CALL MYWRT(IOERR,BUFFER) -C -C -C -C -C Set the barrier parameter (Mehrotra, 1992). -C ------------------------------------------- - IF(IORDER.GE.2) GO TO 330 - BARR=GPMN*GPMN*GPMN/(XTZSTW*XTZSTW*DBLE(N)) - BARRMX=3.33D-1 - IF(STEP0.GE.1.0D-1) BARRMX=2.0D-1 - IF(STEP0.GE.2.0D-1) BARRMX=1.0D-1 - IF(BARR.GE.BARRMX*GPMN/DBLE(N)) BARR=BARRMX*GPMN/DBLE(N) - PDBARR=0.5D0*GPMN/DBLE(N) - IF(AZ.GT.BARPAR*XTZSTW) THEN - DX=ALPHAP - IF(ALPHAD.LT.DX) DX=ALPHAD - IF(DX.LE.2.0D-1) DX=2.0D-1 - BARR=BARR/DX - ENDIF -C -C -C -C Compute the corrector direction. -C - 330 IDIR=5 -C -C -C -C Check if the stepsizes in affine-scaling direction are -C sufficiently large. - IF(IORDER.EQ.1.AND.ALPHAP+ALPHAD.LE.5.0D-2) THEN - WRITE(BUFFER,332) - 332 FORMAT(1X,'PCPDM: Bad affine-scaling dir., centering added.') - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(0,BUFFER) - BARR=0.2D0*PDBARR - IPUSH=1 - IDIR=6 - ENDIF - IF(IORDER.GE.2) IDIR=6 - 340 CONTINUE -C - CALL PCDIR(IDIR,BARR,OLDBAR,ALPHAP,ALPHAD,SMALLX, - X MAXM,MAXN,MAXNZA,MAXNZL,M,N,ITREF,IALARM, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X LCOEFF,LCLPTS,LRWNBS,LDIAG,LDSQRT, - X STAVAR,VUSED,VBNDED,THETA,XIB,XIC,XIU,DDD,GGG,HHH,FNEW, - X X,Y,S,Z,W,DELTAX,DELTAS,DELTAY,DELTAZ,DELTAW,YPROX, - X RMTMP1,RMTMP2,RMTMP3,RNTMP1,RNTMP2,RNTMP3, - X RESX,RESY,IOERR) - OLDBAR=BARR -C - IF(IALARM.EQ.1) IPUSH=IPUSH+1 - IF(RESX+RESY.GE.1.0D-6.AND.IPUSH.LE.0) IPUSH=1 - IF(RESX+RESY.GE.1.0D-5.AND.IPUSH.LE.1) IPUSH=2 - IF(RESX+RESY.GE.1.0D-3.AND.IPUSH.LE.2) IPUSH=3 -C -C -C -C Check if the predictor-corrector mechanism produces -C sufficiently accurate direction. If not, then use pure -C primal-dual log barrier direction. - IF(RESX+RESY.GE.1.0D-7) THEN - IF(IDIR.EQ.6) GO TO 350 -C -C Try pure primal-dual log barrier direction. - WRITE(BUFFER,341) - 341 FORMAT(1X,'PCPDM: Errors in p-c dir., try target following.') - CALL MYWRT(IOERR,BUFFER) - IDIR=6 - BARR=PDBARR - GO TO 340 -C -C Try pure primal-dual affine scaling direction. -C Push variables away from zero in the next iteration. - 350 CONTINUE - WRITE(BUFFER,351) - 351 FORMAT(1X,'PCPDM: Errors in p-d dir., try affine scaling.') - CALL MYWRT(IOERR,BUFFER) - ALPHA0=0.95D0 - ISTEP=1 - GO TO 800 - ENDIF -C -C -C -C Compute the primal-dual predictor-corrector direction. - DO 360 J=1,N - IF(VUSED(J)) THEN - DELTAX(J,2)=DELTAX(J,2)+DELTAX(J,1) - DELTAZ(J,2)=DELTAZ(J,2)+DELTAZ(J,1) - IF(VBNDED(J)) THEN - DELTAS(J,2)=DELTAS(J,2)+DELTAS(J,1) - DELTAW(J,2)=DELTAW(J,2)+DELTAW(J,1) - ENDIF - ENDIF - 360 CONTINUE - DO 380 I=1,M - DELTAY(I,2)=DELTAY(I,2)+DELTAY(I,1) - 380 CONTINUE -C -C -C -C Determine the stepsizes for the primal-dual -C predictor-corrector direction. -C -C ax := min{x(j)/deltax(j,2): deltax(j,2)<0, j=1,...,n} -C as := min{s(j)/deltas(j,2): deltas(j,2)<0, j=1,...,n} -C az := min{z(j)/deltaz(j,2): deltaz(j,2)<0, j=1,...,n} -C aw := min{w(j)/deltaw(j,2): deltaw(j,2)<0, j=1,...,n} -C - CALL PCSTEP(N,LX,AX,X,DELTAX(1,2),IOERR) - CALL PCSTEP(N,LS,AS,S,DELTAS(1,2),IOERR) - CALL PCSTEP(N,LZ,AZ,Z,DELTAZ(1,2),IOERR) - CALL PCSTEP(N,LW,AW,W,DELTAW(1,2),IOERR) -C -C ALPHAP := min{AX,AS,STEPMX} - ALPHAP=AX - IF(AS.LT.ALPHAP) ALPHAP=AS - IF(STEPMX.LT.ALPHAP) ALPHAP=STEPMX -C -C ALPHAD := min{AZ,AW,STEPMX} - ALPHAD=AZ - IF(AW.LT.ALPHAD) ALPHAD=AW - IF(STEPMX.LT.ALPHAD) ALPHAD=STEPMX -C -C *** DEBUGGING - STEP1=ALPHAP - IF(ALPHAD.LT.STEP1) STEP1=ALPHAD -C WRITE(BUFFER,381) AX,AS,AZ,AW -C 381 FORMAT(1X,'P-Corr: AX,AS,AZ,AW: ',4D10.2) -C CALL MYWRT(IOERR,BUFFER) -C WRITE(BUFFER,382) ALPHAP,ALPHAD -C 382 FORMAT(1X,' ALPHAP,ALPHAD: ',2D10.2) -C CALL MYWRT(IOERR,BUFFER) -C -C -C -C -C Here to control computing higher order correcting terms. -C The predictor-corrector step of order IORDER has already been -C determined. - IORDER=IORDER+1 - IF(STEP1.LE.STEP0*1.01D0.AND.IORDER.GE.3) THEN -C -C Stop correcting. - ISTEP=1 - ALPHAP=SAVEP - ALPHAD=SAVED - STEP1=STEP0 - IORDER=IORDER-1 - GO TO 800 - ELSE -C -C Save the step and try higher order corrector. - DO 460 J=1,N - IF(VUSED(J)) THEN - DELTAX(J,1)=DELTAX(J,2) - DELTAZ(J,1)=DELTAZ(J,2) - IF(VBNDED(J)) THEN - DELTAS(J,1)=DELTAS(J,2) - DELTAW(J,1)=DELTAW(J,2) - ENDIF - ENDIF - 460 CONTINUE - DO 480 I=1,M - DELTAY(I,1)=DELTAY(I,2) - 480 CONTINUE - IF(IORDER.GE.MAXORD) GO TO 780 - GO TO 260 - ENDIF -C -C -C -C Reduce the stepsizes. Choose the type of step. - 780 ISTEP=2 - 800 ALPHAP=ALPHA0*ALPHAP - ALPHAD=ALPHA0*ALPHAD -C - WRITE(BUFFER,861) ITER,IORDER-2,DLGAP,BARR,ALPHAP,ALPHAD - 861 FORMAT(1X,'PCPDM: It=',I4,' O=',I2,' GP=',1PD9.2, - X ' BRR=',1PD9.2,' AP=',1PD8.2,' AD=',1PD8.2) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,863) - 863 FORMAT(1X) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C -C -C -C Compute the new iterate and the complementarity gap. -C Update the indicators of variable changes. -C -C X := X+ALPHAP*DELTAX(ISTEP) -C S := S+ALPHAP*DELTAS(ISTEP) -C Y := Y+ALPHAD*DELTAY(ISTEP) -C Z := Z+ALPHAD*DELTAZ(ISTEP) -C W := W+ALPHAD*DELTAW(ISTEP) -C - XZSW=0.0D0 - DO 900 J=1,N - If(VUSED(J)) THEN - X(J)=X(J)+ALPHAP*DELTAX(J,ISTEP) - Z(J)=Z(J)+ALPHAD*DELTAZ(J,ISTEP) - XZSW=XZSW+X(J)*Z(J) - IF(DELTAX(J,ISTEP).LE.0.0D0) THEN - IF(IXCHNG(J).LE.0) THEN - IXCHNG(J)=IXCHNG(J)-1 - ELSE - IXCHNG(J)=0 - ENDIF - ELSE - IF(IXCHNG(J).GE.0) THEN - IXCHNG(J)=IXCHNG(J)+1 - ELSE - IXCHNG(J)=0 - ENDIF - ENDIF -C IF(X(J).LE.0D0.OR.Z(J).LE.0D0) THEN -C WRITE(BUFFER,901) J,X(J),J,Z(J) -C 901 FORMAT(1X,'X(',I6,')=',1PD10.2,' Z(',I6,')=',1PD10.2) -C CALL ERRWRT(IOERR,BUFFER) -C TCODE=3 -C GO TO 2000 -C ENDIF - IF(VBNDED(J)) THEN - S(J)=S(J)+ALPHAP*DELTAS(J,ISTEP) - W(J)=W(J)+ALPHAD*DELTAW(J,ISTEP) - XZSW=XZSW+S(J)*W(J) - IF(DELTAS(J,ISTEP).LE.0.0D0) THEN - IF(ISCHNG(J).LE.0) THEN - ISCHNG(J)=ISCHNG(J)-1 - ELSE - ISCHNG(J)=0 - ENDIF - ELSE - IF(ISCHNG(J).GE.0) THEN - ISCHNG(J)=ISCHNG(J)+1 - ELSE - ISCHNG(J)=0 - ENDIF - ENDIF -C IF(S(J).LE.0D0.OR.W(J).LE.0D0) THEN -C WRITE(BUFFER,902) J,S(J),J,W(J) -C 902 FORMAT(1X,'S(',I6,')=',1PD10.2,' W(',I6,')=',1PD10.2) -C CALL ERRWRT(IOERR,BUFFER) -C TCODE=3 -C GO TO 2000 -C ENDIF -C IF(Z(J).LE.1.0D-2.OR.W(J).LE.1.0D-2) THEN -C WRITE(BUFFER,911) J,X(J),S(J),Z(J),W(J) -C 911 FORMAT(1X,'J=',I6,' X=',1PD10.2,' S=',1PD10.2, -C X ' Z=',1PD10.2,' W=',1PD10.2) -C CALL MYWRT(IOERR,BUFFER) -C WRITE(BUFFER,912) J,X(J)*Z(J),S(J)*W(J) -C 912 FORMAT(1X,'J=',I6,' XZ=',1PD10.2,' SW=',1PD10.2) -C CALL MYWRT(IOERR,BUFFER) -C ENDIF - ENDIF - ENDIF - 900 CONTINUE -C WRITE(BUFFER,905) XZSW/DBLE(N) -C 905 FORMAT(1X,'after 900 loop, average XZSW=',1PD10.2) -C CALL MYWRT(IOERR,BUFFER) -C AS=1.0D1*XZSW/DBLE(N) -C XZSW=0.0D0 -C DO 910 J=1,N -C If(VUSED(J)) THEN -C DP=X(J)*Z(J) -C IF(DP.LE.AS) XZSW=XZSW+DP -C IF(VBNDED(J)) THEN -C DP=S(J)*W(J) -C IF(DP.LE.AS) XZSW=XZSW+DP -C ENDIF -C ENDIF -C 910 CONTINUE -C WRITE(BUFFER,915) XZSW/DBLE(N) -C 915 FORMAT(1X,'after 910 loop, average XZSW=',1PD10.2) -C CALL MYWRT(IOERR,BUFFER) - DO 920 I=1,M - Y(I)=Y(I)+ALPHAD*DELTAY(I,ISTEP) - 920 CONTINUE - DO 930 I=1,M - YPROX(I)=(1.0D0-BETA)*YPROX(I)+BETA*Y(I) - 930 CONTINUE -C -C Push infeasible dual variables towards their bounds. - LX=0 - LS=0 - IF(ITER.GE.0) GO TO 950 - DO 940 I=1,M - IF(Y(I).LT.P(I)) THEN -C WRITE(BUFFER,942) I,P(I),Y(I),Q(I) -C 942 FORMAT(1X,'rw=',I6,' Pi=',D12.4,' Yi=',D12.4,' Qi=',D12.4) -C CALL MYWRT(IOERR,BUFFER) - LX=LX+1 - Y(I)=(P(I)+Y(I))/2.0 - ENDIF - IF(Y(I).GT.Q(I)) THEN -C WRITE(BUFFER,943) I,P(I),Y(I),Q(I) -C 943 FORMAT(1X,'rw=',I6,' Pi=',D12.4,' Yi=',D12.4,' Qi=',D12.4) -C CALL MYWRT(IOERR,BUFFER) - LS=LS+1 - Y(I)=(Q(I)+Y(I))/2.0 - ENDIF - 940 CONTINUE -C WRITE(BUFFER,945) LX,LS -C 945 FORMAT(1X,'PCPDM: Dual variables corrected: Pi=',I6,' Qi=',I6) -C CALL MYWRT(IOERR,BUFFER) - 950 CONTINUE -C -C -C -C -C -C -C End of main loop. - GO TO 50 -C -C -C -C -C -C -C Here when optimal solution found. - 1000 TCODE=0 - WRITE(BUFFER,1001) - 1001 FORMAT(1X) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,1002) ITER-1 - 1002 FORMAT(1X,'PCPDM: Optimal solution found after ',I4, - X ' iterations.') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) - WRITE(BUFFER,1003) DLGAP,OBJ - 1003 FORMAT(9X,'GAP=',1PD9.2,' (partial)OBJ=',1PD14.6) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C -C -C -C Report the history of variables changes. -C DO 1020 J=1,N -C If(VUSED(J)) THEN -C WRITE(BUFFER,1021) J,STAVAR(J),IXCHNG(J),ISCHNG(J) -C1021 FORMAT(1X,'J=',I6,' st=',I6, -C X ' ixchng=',I3,' ischng=',I3) -C CALL MYWRT(IOERR,BUFFER) -C ENDIF -C1020 CONTINUE -C -C -C -C Check the feasibility of the optimal solution. -C -C CALL PCCHCK(MAXM,MAXN,M,N,IOERR, -C X ERRB,ERRU,ERRC, -C X VUSED,VBNDED,XIB,XIC,XIU) -C -C -C -C Restore the original problem size. - 2000 CONTINUE - MFINAL=M - M=M0 -C - RETURN -C -C -C *** LAST CARD OF (PCPDM) *** - END //GO.SYSIN DD hopdm.src/pcpdm.f echo hopdm.src/pcstep.f 1>&2 sed >hopdm.src/pcstep.f <<'//GO.SYSIN DD hopdm.src/pcstep.f' 's/^-//' -C******************************************************************* -C * PCSTEP ... COMPUTE THE LARGEST FIISBLE STEP IN A DIRECTION * -C******************************************************************* -C - SUBROUTINE PCSTEP(N,JMIN,XMIN,X,DELTA,IOERR) -C -C *** PARAMETERS - INTEGER*4 N,JMIN,IOERR - DOUBLE PRECISION XMIN,X(N),DELTA(N) -C -C *** LOCAL VARIABLES - INTEGER*4 J - DOUBLE PRECISION STEPJ - CHARACTER*100 BUFFER -C -C *** PARAMETERS DESCRIPTION -C ON INPUT: -C N Dimension of arrays X and DELTA. -C X Current strictly feasible point. -C DELTA Direction to make step along. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C ON OUTPUT: -C JMIN Subscript of J such that X(J)/DELTA(J)=XMIN. -C XMIN Stepsize. -C -C *** SUBROUTINES CALLED: -C NONE -C -C *** PURPOSE: -C This routine computes the largest feasible step in direction -C DELTA that does not violate the nonnegativity of variables. -C -C *** NOTES: -C This routine exploits the fact that DELTA(j)>=0 for all j -C such that stavar(j)>=6 (FIXED variables). -C Be sure to set DELTAs associated with FIXED variables to the -C nonnegative values if calling this routine from HOPDM library. -C -C *** HISTORY: -C Written by: Jacek Gondzio, -C Systems Research Institute, -C Polish Academy of Sciences, -C Newelska 6, 01-447 Warsaw, Poland. -C Last modified: November 16, 1993 -C -C -C *** BODY OF (PCSTEP) *** -C -C - JMIN=0 - XMIN=1.0D+20 - DO 100 J=1,N - IF(DELTA(J).GE.0.0D0) GO TO 100 - STEPJ=-X(J)/DELTA(J) - IF(STEPJ.GE.XMIN) GO TO 100 - JMIN=J - XMIN=STEPJ - 100 CONTINUE -C - RETURN -C -C -C *** LAST CARD OF (PCSTEP) *** - END //GO.SYSIN DD hopdm.src/pcstep.f echo hopdm.src/postsl.f 1>&2 sed >hopdm.src/postsl.f <<'//GO.SYSIN DD hopdm.src/postsl.f' 's/^-//' -C****************************************************** -C *** POSTSL ... POST_OPTIMIZATION PROCESSING *** -C****************************************************** -C - SUBROUTINE POSTSL(IOERR,MSGLEV, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X RWORK,IWORK,RMAP,IMAP,IROW,RELT, - X IMTMP1,INTMP1,INTMP2,RNTMP1, - X B,RANGES,C,LOBND,UPBND, - X ACOEFF,CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X PRLVAR,STAVAR,RWSTAT,STAROW,RWNAME,CLNAME) -C -C -C -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(*),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(*) -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real array that contains real LP problem data. -C IWORK Integer array that contains integer LP problem data. -C RMAP Map of RWORK array. -C IMAP Map of IWORK array. -C -C -C -C -C *** PARAMETERS - INTEGER*4 IOERR,MSGLEV,MAXM,MAXN,MAXNZA - INTEGER*4 M,N,NSTRCT,LNHIST,MXHIST - INTEGER*2 INHIST(MXHIST) - DOUBLE PRECISION DPHIST(MXHIST) - INTEGER*4 IROW(MAXN),IMTMP1(MAXM),INTMP1(MAXN) - INTEGER*2 INTMP2(MAXN) - DOUBLE PRECISION RELT(MAXN),RNTMP1(MAXN) - DOUBLE PRECISION ACOEFF(MAXNZA),B(MAXM),RANGES(MAXM) - DOUBLE PRECISION C(MAXN),LOBND(MAXN),UPBND(MAXN) - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM+1),RWLINK(MAXNZA) - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) - DOUBLE PRECISION PRLVAR(MAXN) - CHARACTER*8 RWNAME(MAXM),CLNAME(MAXN) - INTEGER*2 STAVAR(MAXN),STAROW(MAXM),RWSTAT(MAXM) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,IENTRY,IPOS,J,JCOL,KBEG - DOUBLE PRECISION DP,VALUE - CHARACTER*100 BUFFER -C -C -C -C -C *** PARAMETERS DESCRIPTION -C -C *** ON INPUT: -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C MSGLEV The level of PRE_SOLVE information desired: -C 0 only final problem dimensions are printed; -C 1 numbers of eliminated rows and columns are printed; -C 2 names of eliminated rows and columns are printed; -C 3 detailed DEBUGGING information is printed. -C MAXM Maximum number of constraints. -C MAXN Maximum number of variables. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of constraints. -C N Number of variables (total, i.e. including slacks, -C surplus and artificials). -C NSTRCT Number of structural variables (excluding slacks, -C surplus and artificials). -C LNHIST Length of the PRE_SOLVE history list. -C MXHIST Maximum number of entries in the PRE_SOLVE history list. -C INHIST Integer PRE_SOLVE history information. -C DPHIST Double precision PRE_SOLVE history information. -C ACOEFF Array of nonzero elements for each column. -C B Right hand side of the linear program. -C RANGES Array of constraint ranges. -C C Objective function coefficients. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C LENCOL Lengths of (sparse) columns of matrix A. -C LOBND Array of lower bounds. -C UPBND Array of upper bounds. Note that the upper bound -C is changed when the variable has a lower bound. -C PRLVAR Primal variables of the linear program. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C RWSTAT Array of row types: -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 objective row; -C 5 other free row. -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C RWNAME Array of row names (increasing order sort). -C CLNAME Array of column names (unordered). -C -C *** ON OUTPUT: -C -C -C -C -C *** WORK ARRAYS: -C IROW and RELT are the arrays for temporary handling of rows -C and columns of the constraint matrix. They are primarily -C intended to handle sparse vectors (in packed form) -C but may also be used for storing dense ones. -C IMTMP1 Integer work array of size MAXM. -C INTMP1 Integer work array of size MAXN -C INTMP2 Half-length integer work array of size MAXN. -C RNTMP1 Double precision work array of size MAXN. -C -C -C -C -C *** PURPOSE -C This routine does POST_PROCESSING on the optimal solution. -C It performs an 'undo' operation on a stack-type PRE_SOLVE -C history list. -C Recall that PRE_SOLVE history contains two types of entries. -C -C Positive entries of INHIST array indicate eliminated FREE -C (or implied FREE) variables. Appropriate DPHIST entries -C store pivot elements. -C -C Negative entries of INHIST array indicate variables for -C which LOWER bound has been pushed. DPHIST entries hadle -C bound corrections in such a case. -C -C -C -C *** SUBROUTINES CALLED -C MYWRT,DABS -C -C -C *** NOTES -C This routine is given direct access to the matrix A -C but it does not alter hidden data structures. -C -C -C -C *** REFERENCES: -C Gondzio J. (1994). Analysis of linear programs prior to applying -C the interior point method, Technical Report, -C Department of Management Studies, University of Geneva, -C 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, February 1994. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: January 9, 1994 -C -C -C -C -C *** BODY OF (POSTSL) *** -C -C -C -C -C -C - IF(MSGLEV.LE.3) GO TO 140 - DO 130 J=1,N - IF(STAVAR(J).LT.6) GO TO 130 - WRITE(BUFFER,131) J,LENCOL(J),STAVAR(J), - X LOBND(J),UPBND(J),PRLVAR(J) - 131 FORMAT(1X,'col=',I6,' ln=',I4,' st=',I6,' LO=',D10.3, - X ' UP=',D10.3,' X=',D10.3) - CALL MYWRT(IOERR,BUFFER) - 130 CONTINUE - 140 CONTINUE -C -C -C -C Prepare data structures used to update optimal values -C of the primal variables. -C RNTMP1 array handles (updated) primal solution. - DO 200 J=1,N - RNTMP1(J)=PRLVAR(J) - 200 CONTINUE -C -C -C -C -C -C -C Main loop begins here. -C Loop over all PRE_SOLVE history list. - DO 1000 IENTRY=LNHIST,1,-1 - J=INHIST(IENTRY) - IF(J.LE.0) THEN -C -C -C -C Here if the variable has its LOWER BOUND pushed. -C Add the bound's contibution to the variable. - J=-J - RNTMP1(J)=RNTMP1(J)+DPHIST(IENTRY) - IF(STAVAR(J).EQ.15) LOBND(J)=LOBND(J)-DPHIST(IENTRY) -C - ELSE -C -C -C -C Here if the variable has been made FREE (or implied FREE). -C Look for pivot element. - KBEG=CLPNTS(J) - I=RWNMBS(KBEG) - IF(MSGLEV.LE.2) GO TO 310 - WRITE(BUFFER,301) I,RWNAME(I),RWSTAT(I) - 301 FORMAT(1X,'POSTSL: Row ',I6,' (name=',A8, - X ') RWSTAT=',I6) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,302) J,I,ACOEFF(KBEG),DPHIST(IENTRY) - 302 FORMAT(1X,'cl=',I6,' rw=',I6,' elt=',D10.3, - X ' dphist=',D10.3) - CALL MYWRT(IOERR,BUFFER) - 310 CONTINUE -C -C Restore objective and compute the value of the variable. - VALUE=B(I) - IPOS=RWHEAD(I) - DP=C(J)/DPHIST(IENTRY) - 500 IF(IPOS.EQ.0) GO TO 700 - JCOL=CLNMBS(IPOS) - IF(JCOL.EQ.J) GO TO 600 -C WRITE(BUFFER,501) IPOS,JCOL,C(JCOL),-DP*ACOEFF(IPOS) -C 501 FORMAT(1X,'ipos=',I6,' j=',I6,' c=',D10.3, -C X ' corr.=',D10.3) -C CALL MYWRT(IOERR,BUFFER) - C(JCOL)=C(JCOL)+DP*ACOEFF(IPOS) - VALUE=VALUE-RNTMP1(JCOL)*ACOEFF(IPOS) - 600 IPOS=RWLINK(IPOS) - GO TO 500 - 700 CONTINUE - RNTMP1(J)=VALUE/DPHIST(IENTRY) -C - ENDIF -C -C -C -C End of main loop. - 1000 CONTINUE -C -C -C -C -C -C -C Recover optimal values of all FREE variables. - DO 1200 J=1,NSTRCT - IF(STAVAR(J).EQ.15) PRLVAR(J)=RNTMP1(J) - 1200 CONTINUE -C -C -C -C - RETURN -C -C -C -C *** LAST CARD OF (POSTSL) *** - END //GO.SYSIN DD hopdm.src/postsl.f echo hopdm.src/prepro.f 1>&2 sed >hopdm.src/prepro.f <<'//GO.SYSIN DD hopdm.src/prepro.f' 's/^-//' -C************************************************************* -C **** PREPRO ... PREPROCESSING THE LP PROBMEM **** -C************************************************************* -C - SUBROUTINE PREPRO(MAXM,MAXN,MAXNZA,MAXNZL,M,N, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X INTMP1,IMTMP1,IMTMP2,RMTMP1, - X DHEAD,PERM0,INVP0,NBRHD,QSIZE,QLINK, - X PERM,INVP,HEADER,LINKFD,LINKBK, - X LCLPTS,LRWNBS,LLINKS, - X STAVAR,P,Q,RWNAME,STAROW,RWSTAT,RANGES, - X NZL,ICALL,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXM,MAXN,MAXNZA,MAXNZL,M,N,LIWORK,LRWORK - INTEGER*4 NZL,ICALL,IOERR - INTEGER*4 INTMP1(MAXN),IROW(MAXN) - DOUBLE PRECISION RMTMP1(MAXM),RELT(MAXN) - INTEGER*4 IMTMP1(MAXM+1),IMTMP2(MAXM+1) - INTEGER*4 DHEAD(MAXM),PERM0(MAXM),INVP0(MAXM) - INTEGER*4 NBRHD(MAXM),QSIZE(MAXM),QLINK(MAXM) - INTEGER*2 PERM(MAXM),INVP(MAXM) - INTEGER*2 HEADER(MAXM+1),LINKFD(MAXM+1),LINKBK(MAXM+1) - CHARACTER*8 RWNAME(MAXM) - DOUBLE PRECISION P(MAXM),Q(MAXM),RANGES(MAXM) - INTEGER*2 STAVAR(MAXN),STAROW(MAXM),RWSTAT(MAXM) -C -C *** DATA STRUCTURES FOR CHOLESKY FACTOR -C DOUBLE PRECISION LCOEFF(MAXNZL) -C DOUBLE PRECISION LDIAG(MAXM) - INTEGER*4 LCLPTS(MAXM+1),LLINKS(MAXNZL) - INTEGER*2 LRWNBS(MAXNZL) -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(LIWORK),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(LRWORK) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,IMDO,NZAAT,TRIANG - CHARACTER*100 BUFFER -C -C *** VARIABLES FOR MMD ROUTINE - INTEGER*4 IDELTA,MAXINT,NOFSUB -C -C -C *** COMMON ARREAS -C Markers for linking rows. - COMMON /ICGRAD/ MSPLIT(100000) - INTEGER*2 MSPLIT -C -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C N Number of columns of the LP constraint matrix. -C INTMP1 Integer work array of size MAXN. -C IMTMP1 Integer work array of size MAXM. -C IMTMP2 Integer work array of size MAXM. -C IROW and RELT are the arrays for temporary handling of rows -C and columns of the constraint matrix. They are primarily -C intended to handle sparse vectors (in packed form) -C but may also be used for storing dense ones. -C dense ones. -C RMTMP1 Double precision work array of size MAXM. -C PERM Permutation resulting from the minimum degree ordering. -C INVP Inverse permutation. -C HEADER Header of the doubly linked lists. -C LINKFD Forward linked lists. -C LINKBK Backward linked lists. -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C LLINKS Linked lists for Cholesky factor. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C RWNAME Array of row names (increasing order sort). -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C RWSTAT Array of row types (sort as before): -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 row type is objective or free. -C P LOWER bounds on shadow prices (dual variables). -C Q UPPER bounds on shadow prices (dual variables). -C RANGES Array of constraint ranges. -C ICALL Number of call of this routine: -C 0 means that sufficient storage is allocated -C to complete preprocessing phase; -C 1 means that number of nonzeros in adjacency -C structure A*Atransp is only to be computed; -C 2 means that adjacency structure of A*Atransp -C is to be determined and minimum degree ordering -C is to be found; -C 3 means that symbolic factorization is to be done. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C NZL Number of nonzeros of the Cholesky factor. -C Data structures for Cholesky matrix: -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C -C -C -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real work array containing almost all real -C LP problem data. -C IWORK Integer work array containing almost all integer -C LP problem data. -C RMAP Map of RWORK. -C IMAP Map of IWORK. -C -C Map of IWORK array: -C IMAP(1) Points to CLPNTS array. -C IMAP(2) Points to RWNMBS array. -C IMAP(3) Points to RWHEAD array. -C IMAP(4) Points to RWLINK array. -C IMAP(5) Points to CLNMBS array. -C IMAP(6) Points to LENCOL array. -C IMAP(7) Points to the first empty cell of IWORK array. -C -C Map of RWORK array: -C RMAP(1) Points to ACOEFF array. -C RMAP(2) Points to C array. -C RMAP(3) Points to RHS array. -C RMAP(4) Points to the first empty cell of RWORK array. -C -C -C -C -C *** SUBROUTINES CALLED: -C MYWRT,CNTAAT,DEFAAT,MDO,REORDA,REORDI,REORDV,SYMFCT,DTSRTA -C -C -C *** PURPOSE: -C This routine preprocesses the linear programming problem. -C It does the following steps: -C (i) building and analysis of the sparsity pattern -C of A*Atransp (a minimum degree heuristic is used -C to find a row permutation of A that leads to the -C sparsest possible Cholesky factor of A*Atransp); -C (ii) permutation of rows of A according to the reordering -C resulting from the mininmum degree heuristic; -C (iii) setting up data structures for sparse Cholesky -C decomposition (symbolic factorization); -C (iv) permutation of nonzero elements in each column of A -C to ensure their increasing order. -C -C -C *** NOTES: -C -C -C *** REFERENCES: -C Altman A., Gondzio J. (1993). An efficient implementation of -C a higher order primal-dual interior point method for large -C sparse linear programs, Archives of Control Sciences 2, -C No 1-2, pp. 23-40. -C Altman A., Gondzio J. (1993). HOPDM - A higher order primal- -C dual method for large scale linear programmming, European -C Journal of Operational Research 66 (1993) pp 158-160. -C Duff I.S., Erisman A.M., Reid J.K. (1989). Direct methods -C for sparse matrices, Clarendon Press, Oxford 1989. -C Gondzio J. (1992). Splitting dense columns of the constraint -C matrix in interior point methods for large scale linear -C programming, Optimization 24, pp. 285-297. -C Gondzio J. (1993). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization 27, pp. 121-140. -C Gondzio J. (1994). Presolve analysis of linear programs prior -C to applying an interior point method, Technical Report -C No 1994.3, Department of Management Studies, University -C of Geneva, 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, -C February 1994, revised in December 1994. -C Gondzio J. (1994). Multiple centrality corrections in a primal- -C dual method for linear programming, Technical Report -C No 1994.20, Department of Management Studies, University -C of Geneva, 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, -C November 1994. -C Gondzio J., Makowski M. (1995). Solving a class of LP problems -C with a primal-dual logarithmic barrier method, European -C Journal of Operational Research 80, pp. 184-192. -C Gondzio J., Tachat D. (1994). The design and application of -C IPMLO - a FORTRAN library for linear optimization with -C interior point methods, RAIRO Recherche Operationnelle 28, -C No 1, pp. 37-56. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: May 11, 1991 -C Last modified: March 31, 1995 -C -C -C -C *** BODY OF (PREPRO) *** -C -C - IF(ICALL.EQ.2) GO TO 200 - IF(ICALL.EQ.3) GO TO 400 -C -C -C -C Reorder rows of the LP constraint matrix to minimize -C the fill-in of the Cholesky factor. -C -C Determine how much space is needed for A*Atransp. -C -C TRIANG=0 -C CALL CNTAAT(M,MAXM,MAXN,MAXNZA,NZL, -C X TRIANG,LCLPTS,IMTMP1,IMTMP2,STAVAR, -C X IWORK(IMAP(1)),IWORK(IMAP(2)),IWORK(IMAP(3)), -C X IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)),IOERR) -C - NZL=2*NZL - NZAAT=NZL - IF(ICALL.EQ.1) GO TO 1000 -C -C Check if there is enough room for adjacency structure. - IF(NZL.GT.MAXNZL) GO TO 9000 -C -C -C -C Determine the sparsity structure of A*Atransp. -C - 200 TRIANG=0 - CALL DEFAAT(LRWNBS,LCLPTS,LLINKS, - X MAXNZL,MAXM,MAXN,MAXNZA,M,TRIANG, - X IMTMP1,IMTMP2,STAVAR, - X IWORK(IMAP(1)),IWORK(IMAP(2)),IWORK(IMAP(3)), - X IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)),IOERR) -C -C -C Perform the mininmum degree heuristic. -C Print the current date, time and elapsed time. - WRITE(BUFFER,201) - 201 FORMAT(1X,'PREPRO: Minimum degree ordering starts.') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C -C CALL MYTIME(1,IOERR) -C CALL MYTIME(1,0) -C -C Use very cheap ordering. -C CALL CHEAP(LRWNBS,LCLPTS,LLINKS,MAXNZL,MAXM,M,NZL, -C X PERM,INVP,HEADER,LINKFD,LINKBK, -C X INTMP1,IMTMP1,IMTMP2,IROW,IOERR) -C -C Decide which ordering will be used. - IMDO=0 - DO 210 I=1,M - IF(MSPLIT(I).EQ.1) IMDO=1 - 210 CONTINUE - IF(IMDO.EQ.1) THEN -C -C Use the minimum degree ordering. - CALL MDO(LRWNBS,LCLPTS,LLINKS,MAXNZL,MAXM,M,NZL, - X PERM,INVP,HEADER,LINKFD,LINKBK, - X INTMP1,IMTMP1,IMTMP2,IROW,IOERR) -C - ELSE -C -C Use the multiple minimum degree ordering. - IDELTA=10 - MAXINT=100000000 - NOFSUB=100000000 - DO 220 I=1,MAXNZL - LLINKS(I)=LRWNBS(I) - 220 CONTINUE -C -C MMD routine is Joseph Liu's implementation of the Multiple -C Minimum Degree ordering. See: "The evolution of the minimum -C degree ordering algorithm", SIAM Review 33 (89), 1, pp. 1-19. -C NOTE: This routine can be used EXCLUSIVELY for research -C purposes. - CALL MMD(M,LCLPTS,LLINKS,INVP0,PERM0,IDELTA, - X DHEAD,QSIZE,IMTMP1,IMTMP2,MAXINT,NOFSUB) -C -C GENQMD routine is an implementation of the Quotient tree -C Minimum Degree ordering available from SPARSPAK (via Netlib). -C This routine is based on the book "Computer Solution of Large -C Sparse Positive Definite Systems" by George and Liu, Prentice -C Hall 1981. -C CALL GENQMD(M,LCLPTS,LLINKS,PERM0,INVP0,DHEAD, -C X IMTMP1,IMTMP2,NBRHD,QSIZE,QLINK,NOFSUB) -C - DO 240 I=1,M - INVP(I)=INVP0(I) - PERM(I)=PERM0(I) - 240 CONTINUE - ENDIF -C -C Print the current date, time and elapsed time. - WRITE(BUFFER,241) - 241 FORMAT(1X,'PREPRO: Minimum degree ordering done.') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C -C CALL MYTIME(1,IOERR) -C CALL MYTIME(1,0) -C -C *** DEBUGGING -C WRITE(BUFFER,251) -C 251 FORMAT(1X,'PREPRO: Permutations after MDO') -C CALL MYWRT(IOERR,BUFFER) -C DO 253 I=1,M -C WRITE(BUFFER,252) I,PERM(I),INVP(I) -C 252 FORMAT(1X,'PREPRO: row=',I6,' perm=',I6,' invp=',I6) -C CALL MYWRT(IOERR,BUFFER) -C 253 CONTINUE -C -C -C -C Reorder the rows of the LP constraint matrix with -C the permutation resulting from the minimum degree heuristic. -C - CALL REORDA(MAXM,MAXN,MAXNZA,M,N, - X IWORK(IMAP(1)),IWORK(IMAP(2)), - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)), - X PERM,INVP,IMTMP1,IMTMP2,RMTMP1, - X RWNAME,STAROW,RWSTAT,RANGES,RWORK(RMAP(3)),IOERR) -C -C Reorder P, Q and MSPLIT arrays. -C - CALL REORDV(MAXM,M, - X PERM,INVP,P,RMTMP1,IOERR) - CALL REORDV(MAXM,M, - X PERM,INVP,Q,RMTMP1,IOERR) - CALL REORDI(MAXM,M, - X PERM,INVP,MSPLIT,IMTMP1(1),IOERR) -C -C -C NZL=2*NZL -C IF(NZL.LE.NZAAT) NZL=NZAAT - IF(ICALL.EQ.2) GO TO 1000 -C -C -C Check if there is enough room for Cholesky factor. - IF(NZL.GT.MAXNZL) GO TO 9000 -C -C -C Perform the symbolic factorization. - 400 CONTINUE -C - CALL SYMFCT(LLINKS,IROW, - X LCLPTS,LRWNBS,MAXNZL,MAXM,MAXN,MAXNZA,M, - X HEADER,LINKFD,LINKBK,IMTMP1,IMTMP2,STAVAR, - X IWORK(IMAP(1)),IWORK(IMAP(2)),IWORK(IMAP(3)), - X IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)),IOERR) -C -C Permute nonzero elements in columns of A to ensure -C their increasing order. -C -C SUBROUTINE DTSRTA(MAXM,MAXN,MAXNZA,M,N, -C X ACOEFF,CLPNTS,RWNMBS,LENCOL, -C X RWHEAD,RWLINK,CLNMBS, -C X ACOPY,CPCOPY,STAVAR,IOERR) -C - CALL DTSRTA(MAXM,MAXN,MAXNZA,M,N, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)),IWORK(IMAP(6)), - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)), - X LLINKS(1),INTMP1,STAVAR,IOERR) -C -C -C -C - 1000 CONTINUE - RETURN -C -C -C Here to write error message. - 9000 WRITE(BUFFER,9001) NZL - 9001 FORMAT(1X,'PREPRO ERROR: Cholesky factor overflow ',I10) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9002) MAXNZL - 9002 FORMAT(1X,' space was provided for only ',I10, - X ' nonzeros.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C -C -C *** LAST CARD OF (PREPRO) *** - END //GO.SYSIN DD hopdm.src/prepro.f echo hopdm.src/presol.f 1>&2 sed >hopdm.src/presol.f <<'//GO.SYSIN DD hopdm.src/presol.f' 's/^-//' -C************************************************************** -C **** PRESOL ... PRESOLVE ANALYSIS OF THE LP PROBMEM **** -C************************************************************** -C - SUBROUTINE PRESOL(MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X IWORK,RWORK,IMAP,RMAP,LIWORK,LRWORK,IROW,RELT, - X X,B,C,CLNAME,UPBND,LOBND, - X INTMP1,INTMP2,INTMP3,IMTMP1,IMTMP2, - X RMTMP1,P,Q,RNTMP1,RNTMP2,RNTMP3, - X PERM,INVP,HEADER,LINKFD,LINKBK, - X STAVAR,RWNAME,STAROW,RWSTAT,RANGES, - X MAXCOL,MSGLEV,LEVPRS,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXM,MAXN,MAXNZA,M,N,NSTRCT,LIWORK,LRWORK - INTEGER*4 LNHIST,MXHIST,MAXCOL,MSGLEV,LEVPRS,IOERR - INTEGER*4 INTMP1(MAXN),IROW(MAXN),IMTMP1(MAXM+1),IMTMP2(MAXM+1) - INTEGER*2 INTMP2(MAXN),INTMP3(MAXN) - DOUBLE PRECISION RMTMP1(MAXM),P(MAXM),Q(MAXM),RELT(MAXN) - DOUBLE PRECISION RNTMP1(MAXN),RNTMP2(MAXN),RNTMP3(MAXN) - INTEGER*2 PERM(MAXM),INVP(MAXM) - INTEGER*2 HEADER(MAXM+1),LINKFD(MAXM+1),LINKBK(MAXM+1) - CHARACTER*8 RWNAME(MAXM),CLNAME(MAXN) - DOUBLE PRECISION X(MAXN),B(MAXM),RANGES(MAXM) - DOUBLE PRECISION C(MAXN),UPBND(MAXN),LOBND(MAXN) - INTEGER*2 STAVAR(MAXN),STAROW(MAXM),RWSTAT(MAXM) - INTEGER*2 INHIST(MXHIST) - DOUBLE PRECISION DPHIST(MXHIST) -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(LIWORK),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(LRWORK) -C -C -C -C *** LOCAL VARIABLES - DOUBLE PRECISION BNDBIG - INTEGER*4 I,IRUN,NPASS - INTEGER*4 M0,N0,NZ0,M1,N1,NZ1,MC,NC,NZC - INTEGER*4 MJ0,NJ0,NZJ0,MJ1,NJ1,NZJ1,MKSP - CHARACTER*100 BUFFER -C -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C N Number of columns of the LP constraint matrix. -C NSTRCT Number of structural variables (excluding slacks, surplus -C and artificials). -C LNHIST Length of the PRE_SOLVE history list; -C MXHIST Maximum number of entries in the PRE_SOLVE history list. -C INHIST Integer PRE_SOLVE history information. -C DPHIST Double precision PRE_SOLVE history information. -C IROW and RELT are the arrays for temporary handling of rows -C and columns of the constraint matrix. They are primarily -C intended to handle sparse vectors (in packed form) -C but may also be used for storing dense ones. -C INTMP1 Integer work array of size MAXN. -C INTMP2 Half-length integer work array of size MAXN. -C INTMP3 Half-length integer work array of size MAXN. -C IMTMP1 Integer work array of size MAXM. -C IMTMP2 Integer work array of size MAXM. -C RMTMP1 Double precision work array of size MAXM. -C RNTMP1 Double precision work array of size MAXN. -C RNTMP2 Double precision work array of size MAXN. -C RNTMP3 Double precision work array of size MAXN. -C X Primal variables of the linear program. -C B Right hand side of the linear program. -C C Objective function coefficients. -C UPBND Array of upper bounds. Note that the upper bound -C is changed when the variable has a lower bound. -C LOBND Array of lower bounds. -C PERM Permutation of rows of A. -C INVP Inverse permutation. -C HEADER Header of the doubly linked lists. -C LINKFD Forward linked lists. -C LINKBK Backward linked lists. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C RWNAME Array of row names (increasing order sort). -C CLNAME Array of column names (unordered). -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C RWSTAT Array of row types (sort as before): -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 row type is objective or free. -C RANGES Array of constraint ranges. -C MAXCOL Threshold length for columns to be split. -C MSGLEV The level of PRE_SOLVE information desired: -C 0 only final problem dimensions are printed; -C 1 numbers of eliminated rows and columns are printed; -C 2 names of eliminated rows and columns are printed; -C 3 detailed DEBUGGING information is printed. -C LEVPRS The level of PRE_SOLVE desired: -C 0 only splitting dense columns; -C 1 incomplete analysis (no tightening UPPER bounds); -C 2 maximum analysis possible. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C P LOWER bounds on shadow prices (dual variables). -C Q UPPER bounds on shadow prices (dual variables). -C -C -C -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real work array containing almost all real -C LP problem data. -C IWORK Integer work array containing almost all integer -C LP problem data. -C RMAP Map of RWORK. -C IMAP Map of IWORK. -C -C Map of IWORK array: -C IMAP(1) Points to CLPNTS array. -C IMAP(2) Points to RWNMBS array. -C IMAP(3) Points to RWHEAD array. -C IMAP(4) Points to RWLINK array. -C IMAP(5) Points to CLNMBS array. -C IMAP(6) Points to LENCOL array. -C IMAP(7) Points to the first empty cell of IWORK array. -C -C Map of RWORK array: -C RMAP(1) Points to ACOEFF array. -C RMAP(2) Points to COBJ array. -C RMAP(3) Points to RHS array. -C RMAP(4) Points to the first empty cell of RWORK array. -C -C -C -C -C *** SUBROUTINES CALLED: -C MYWRT,GETDIM,FDIDEN,ELVRBL,ELCNST,RCLSNG,RRWSNG,FDAGGR, -C MKSPAR,DETSPL,SPLIT -C -C -C *** PURPOSE: -C This routine preprocesses the linear programming problem. -C The following actions are performed: -C CLEAN: -C - determine (and later tighten) bounds on shadow prices, -C - eliminate dominated (and weakly dominated) variables, -C - eliminate singleton rows, -C - eliminate singleton columns (implied FREE variables), -C - find identical columns and aggregate them, -C - find hidden split FREE variables, -C - eliminate redundant (dominated or forcing) constraints, -C - tighten bounds on variables, -C MAKE SPARSER: -C - pivot out some nonzero entries of A, -C SPLIT: -C - split dense columns into shorter pieces. -C -C -C *** NOTES: -C -C -C *** REFERENCES: -C Gondzio J. (1992). Splitting dense columns of the constraint -C matrix in interior point methods for large scale linear -C programming, Optimization 24, pp. 285-297. -C Gondzio J. (1993). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization 27, pp. 121-140. -C Gondzio J. (1994). Presolve analysis of linear programs prior -C to applying an interior point method, Technical Report -C No 1994.3, Department of Management Studies, University -C of Geneva, 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, -C February 1994, revised in December 1994. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: March 15, 1993 -C Last modified: March 31, 1995 -C -C -C -C *** BODY OF (PRESOL) *** -C -C -C -C -C Set large values of M0, N0 and NZ0 to force at least -C one pass of presolve analysis. - M0=10000000 - N0=10000000 - NZ0=100000000 -C -C -C Determine problem dimensions. - CALL GETDIM(IOERR, - X MAXM,MAXN,M,N,NSTRCT, - X M1,N1,NZ1,B,C,IWORK(IMAP(6)),STAVAR) -C -C Save initial problem dimensions. - MJ0=M1 - NJ0=N1 - NZJ0=NZ1 -C -C -C -C -C Main loop begins here. - IRUN=1 - 100 DO 1000 NPASS=1,10 - BNDBIG=-1.0D0 - IF(NPASS.GE.2) BNDBIG=1.0D-6 -C -C -C -C Print statistics on the current formulation of the problem. - IF(MSGLEV.LT.0) GO TO 110 - WRITE(BUFFER,101) NPASS-1,M1,N1,NZ1 - 101 FORMAT(1X,'PRESOL: PASS=',I2,' M=',I7,' N=',I7,' NZ=',I12) - CALL MYWRT(0,BUFFER) - CALL MYWRT(99,BUFFER) - CALL MYWRT(IOERR,BUFFER) - 110 CONTINUE - IF(LEVPRS.EQ.0) GO TO 2000 -C -C -C -C Check if the last pass reduced the problem size. - IF(M1.EQ.M0.AND.N1.EQ.N0.AND.NZ1.EQ.NZ0) GO TO 1100 - IF(M1.EQ.0) GO TO 3000 -C -C -C -C Save problem dimensions and continue the analysis. - M0=M1 - N0=N1 - NZ0=NZ1 -C -C -C -C Eliminate dominated (and weakly dominated) variables. -C - IF(NPASS.GT.1) GO TO 200 - I=NPASS+IRUN-1 - CALL ELVRBL(IOERR,MSGLEV,I, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X IMTMP1,IROW,RELT, - X RWORK(RMAP(3)),RANGES,RWORK(RMAP(2)),UPBND, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)), - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)), - X P,Q,X,STAVAR,RWSTAT,STAROW,RWNAME,CLNAME, - X PERM,INVP,LINKFD) -C -C -C -C Eliminate singleton FREE variables. - 200 CONTINUE -C - CALL RCLSNG(IOERR,MSGLEV, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X RWORK,IWORK,RMAP,IMAP,IROW,RELT, - X IMTMP1,INTMP1,INTMP2,RNTMP1, - X RWORK(RMAP(3)),RANGES,RWORK(RMAP(2)),LOBND,UPBND, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)), - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)), - X P,Q,X,STAVAR,RWSTAT,STAROW,RWNAME,CLNAME, - X PERM,INVP,HEADER) -C -C -C -C Determine current problem dimensions. - CALL GETDIM(IOERR, - X MAXM,MAXN,M,N,NSTRCT, - X MC,NC,NZC,B,C,IWORK(IMAP(6)),STAVAR) -C -C -C -C Eliminate singleton constraints. -C - CALL RRWSNG(IOERR,MSGLEV, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X RWORK,IWORK,RMAP,IMAP,IROW,RELT,IMTMP1,IMTMP2, - X RWORK(RMAP(3)),RANGES,LOBND,UPBND, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)), - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)), - X P,Q,X,STAVAR,RWSTAT,STAROW,RWNAME,CLNAME, - X PERM,INVP,INTMP1,LINKFD,LINKBK) -C -C -C -C If RRWSNG routine reduced the problem size, then try singleton -C variables elimination again (uniquely in the first pass). - IF(NPASS.GT.1) GO TO 300 - IF(M.EQ.MC) GO TO 300 -C - CALL RCLSNG(IOERR,MSGLEV, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X RWORK,IWORK,RMAP,IMAP,IROW,RELT, - X IMTMP1,INTMP1,INTMP2,RNTMP1, - X RWORK(RMAP(3)),RANGES,RWORK(RMAP(2)),LOBND,UPBND, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)), - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)), - X P,Q,X,STAVAR,RWSTAT,STAROW,RWNAME,CLNAME, - X PERM,INVP,HEADER) -C -C -C -C Eliminate dominated (and weakly dominated) variables. - 300 CONTINUE -C - I=2 - CALL ELVRBL(IOERR,MSGLEV,I, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X IMTMP1,IROW,RELT, - X RWORK(RMAP(3)),RANGES,RWORK(RMAP(2)),UPBND, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)), - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)), - X P,Q,X,STAVAR,RWSTAT,STAROW,RWNAME,CLNAME, - X PERM,INVP,LINKFD) -C -C -C -C Find variables of identical structure. -C Do it only in the first PASS (expensive search). - IF(NPASS.GE.2) GO TO 400 - IF(NC.GE.5*MC) GO TO 400 -C - CALL FDIDEN(IOERR,MSGLEV, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X RWORK(RMAP(3)),RWORK(RMAP(2)),LOBND,UPBND, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)), - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)), - X P,Q,X,STAVAR,RWSTAT,CLNAME,RANGES, - X PERM,INVP,RMTMP1) -C -C -C -C Determine current problem dimensions. - 400 CONTINUE - CALL GETDIM(IOERR, - X MAXM,MAXN,M,N,NSTRCT, - X M1,N1,NZ1,B,C,IWORK(IMAP(6)),STAVAR) -C -C -C -C Eliminate redundant constraints. - IF(M1.EQ.M0.AND.N1.EQ.N0.AND.NZ1.EQ.NZ0) THEN -C -C Enable tightening UPPER bounds if no other reduction -C possibility exists. - IF(NPASS.GE.2) BNDBIG=1.0D+2 - ENDIF -C - CALL ELCNST(IOERR,MSGLEV,LEVPRS, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X RWORK,IWORK,RMAP,IMAP,IROW,RELT, - X IMTMP1,INTMP1,INTMP2,RMTMP1,RNTMP1, - X RWORK(RMAP(3)),RANGES,RWORK(RMAP(2)),LOBND,UPBND,BNDBIG, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)), - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)), - X P,Q,X,STAVAR,RWSTAT,STAROW,RWNAME,CLNAME, - X PERM,INVP,HEADER) -C -C -C -C Find aggregate variables. -C Do it only in the first two PASSes (expensive search). - IF(NPASS.GE.3) GO TO 500 - IF(N1.GE.100*M1.AND.IRUN.EQ.2) GO TO 500 -C - CALL FDAGGR(IOERR,MSGLEV,LEVPRS, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X RWORK,IWORK,RMAP,IMAP,IROW,RELT, - X IMTMP1,RMTMP1,INTMP1,RNTMP1,RNTMP2,RNTMP3, - X RWORK(RMAP(3)),RANGES,RWORK(RMAP(2)),LOBND,UPBND,BNDBIG, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)), - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)), - X P,Q,X,STAVAR,RWSTAT,STAROW,RWNAME,CLNAME, - X INTMP2,PERM,INVP) -C -C -C -C Determine current problem dimensions. - 500 CONTINUE - CALL GETDIM(IOERR, - X MAXM,MAXN,M,N,NSTRCT, - X M1,N1,NZ1,B,C,IWORK(IMAP(6)),STAVAR) -C -C -C -C -C End of main loop. - 1000 CONTINUE - 1100 CONTINUE -C -C -C -C Save problem dimensions and continue the analysis. - M0=M1 - N0=N1 - NZ0=NZ1 -C -C -C -C Make the LP constraint matrix sparser. -C Analyse EQUALITY type constraints. - IF(IRUN.EQ.2) GO TO 2000 -C - CALL MKSPAR(IOERR,MSGLEV, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X M1,N1,NZ1,IROW,RELT, - X IMTMP1,INTMP1,INTMP2, - X RWORK(RMAP(3)),RANGES, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)), - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)), - X P,Q,STAVAR,RWSTAT,STAROW,RWNAME, - X PERM,INVP,HEADER,LINKFD,LINKBK) -C -C Save the number of nonzeros removed by MKSPAR routine. - IF(IRUN.EQ.1) MKSP=NZ0-NZ1 -C -C -C -C Check if the MKSPAR routine reduced the problem size. - IF(M1.EQ.M0.AND.N1.EQ.N0.AND.NZ1.EQ.NZ0) THEN -C -C Further reduction is not possible. - GO TO 2000 - ELSE -C -C Repeat the analysis. - IRUN=IRUN+1 - GO TO 100 - ENDIF -C -C -C -C Split long columns of the constraint matrix if there are any. - 2000 CONTINUE -C -C -C -C Determine optimal length for split columns. - CALL DETSPL(IOERR, - X MAXM,MAXN,M,N,NSTRCT, - X MAXCOL,IWORK(IMAP(6)),STAVAR) -C -C -C - CALL SPLIT(MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X RWORK(RMAP(1)),IWORK(IMAP(1)),IWORK(IMAP(2)), - X IWORK(IMAP(3)),IWORK(IMAP(4)),IWORK(IMAP(5)),IWORK(IMAP(6)), - X HEADER,LINKFD,LINKBK,INTMP1,IROW, - X MAXCOL,IMTMP1,RMTMP1,IMTMP2,RELT, - X P,Q,CLNAME,STAVAR,X,RWORK(RMAP(2)),UPBND,LOBND, - X RWNAME,STAROW,RWSTAT,RANGES,RWORK(RMAP(3)),IOERR) -C -C - 3000 CONTINUE -C -C -C Determine final problem dimensions. - CALL GETDIM(IOERR, - X MAXM,MAXN,M,N,NSTRCT, - X M1,N1,NZ1,B,C,IWORK(IMAP(6)),STAVAR) -C -C Save final problem dimensions. - MJ1=M1 - NJ1=N1 - NZJ1=NZ1 -C -C WRITE(BUFFER,3001) MJ0,NJ0,NZJ0,MJ1,NJ1,NZJ1,MKSP -C3001 FORMAT(1X,'qqqa',I5,' &',I6,' &',I7, -C X ' &',I5,' &',I6,' &',I7,' &',I5) -C CALL MYWRT(99,BUFFER) -C CALL MYWRT(IOERR,BUFFER) -C -C -C Check if there are any FREE variables in the LP problem. - NJ0=0 - DO 3100 I=1,N - IF(STAVAR(I).LT.0) NJ0=NJ0+1 - 3100 CONTINUE -C WRITE(BUFFER,3101) NJ0/2 -C3101 FORMAT(1X,'qqqc there are',I5,' FREE variables.') -C CALL MYWRT(99,BUFFER) -C CALL MYWRT(IOERR,BUFFER) -C -C -C -C - RETURN -C -C -C -C *** LAST CARD OF (PRESOL) *** - END //GO.SYSIN DD hopdm.src/presol.f echo hopdm.src/rclsng.f 1>&2 sed >hopdm.src/rclsng.f <<'//GO.SYSIN DD hopdm.src/rclsng.f' 's/^-//' -C***************************************************************** -C *** RCLSNG ... ELIMINATE FREE COLUMN SINGLETONS FROM A *** -C *** If you love somebody, set them FREE *** -C***************************************************************** -C - SUBROUTINE RCLSNG(IOERR,MSGLEV, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X RWORK,IWORK,RMAP,IMAP,IROW,RELT, - X IMTMP1,INTMP1,INTMP2,RNTMP1, - X B,RANGES,C,LOBND,UPBND, - X ACOEFF,CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X P,Q,PRLVAR,STAVAR,RWSTAT,STAROW,RWNAME,CLNAME, - X PERM,INVP,LENROW) -C -C -C -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(*),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(*) -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real array that contains real LP problem data. -C IWORK Integer array that contains integer LP problem data. -C RMAP Map of RWORK array. -C IMAP Map of IWORK array. -C -C -C -C -C *** PARAMETERS - INTEGER*4 IOERR,MSGLEV,MAXM,MAXN,MAXNZA - INTEGER*4 M,N,NSTRCT,LNHIST,MXHIST - INTEGER*2 INHIST(MXHIST) - DOUBLE PRECISION DPHIST(MXHIST) - INTEGER*4 IROW(MAXN),IMTMP1(MAXM),INTMP1(MAXN) - INTEGER*2 INTMP2(MAXN) - DOUBLE PRECISION RELT(MAXN),RNTMP1(MAXN) - DOUBLE PRECISION ACOEFF(MAXNZA),B(MAXM),RANGES(MAXM) - DOUBLE PRECISION C(MAXN),LOBND(MAXN),UPBND(MAXN) - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM+1),RWLINK(MAXNZA) - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) - DOUBLE PRECISION P(MAXM),Q(MAXM),PRLVAR(MAXN) - CHARACTER*8 RWNAME(MAXM),CLNAME(MAXN) - INTEGER*2 STAVAR(MAXN),STAROW(MAXM),RWSTAT(MAXM) - INTEGER*2 INVP(MAXM),PERM(MAXM),LENROW(MAXM) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 ROWLEN,NELIM,NFREE - INTEGER*4 I,IKX,IPOS,IRUN,J,JCOL,K,KOK,KOUT - INTEGER*4 KBEG,KEND,MNEW,SNGLHD - DOUBLE PRECISION BIG,BIGNEW,DP,BNDJLO,BNDJUP,OLDBND - DOUBLE PRECISION BLOWER,BUPPER,FSBTOL,SMALLA - CHARACTER*100 BUFFER - CHARACTER*2 RTYPE -C -C -C -C -C *** PARAMETERS DESCRIPTION -C -C *** ON INPUT: -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C MSGLEV The level of PRE_SOLVE information desired: -C 0 only final problem dimensions are printed; -C 1 numbers of eliminated rows and columns are printed; -C 2 names of eliminated rows and columns are printed; -C 3 detailed DEBUGGING information is printed. -C MAXM Maximum number of constraints. -C MAXN Maximum number of variables. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of constraints. -C N Number of variables (total, i.e. including slacks, -C surplus and artificials). -C NSTRCT Number of structural variables (excluding slacks, -C surplus and artificials). -C LNHIST Length of the PRE_SOLVE history list. -C MXHIST Maximum number of entries in the PRE_SOLVE history list. -C INHIST Integer PRE_SOLVE history information. -C DPHIST Double precision PRE_SOLVE history information. -C ACOEFF Array of nonzero elements for each column. -C B Right hand side of the linear program. -C RANGES Array of constraint ranges. -C C Objective function coefficients. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C LENCOL Lengths of (sparse) columns of matrix A. -C LOBND Array of lower bounds. -C UPBND Array of upper bounds. Note that the upper bound -C is changed when the variable has a lower bound. -C P LOWER bounds on shadow prices (dual variables). -C Q UPPER bounds on shadow prices (dual variables). -C PRLVAR Primal variables of the linear program. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C RWSTAT Array of row types: -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 objective row; -C 5 other free row. -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C RWNAME Array of row names (increasing order sort). -C CLNAME Array of column names (unordered). -C -C *** ON OUTPUT: -C -C -C -C -C *** WORK ARRAYS: -C IROW and RELT are the arrays for temporary handling of rows -C and columns of the constraint matrix. They are primarily -C intended to handle sparse vectors (in packed form) -C but may also be used for storing dense ones. -C IMTMP1 Integer work array of size MAXM. -C INTMP1 Integer work array of size MAXN -C INTMP2 Half-length integer work array of size MAXN. -C RNTMP1 Double precision work array of size MAXN. -C PERM Half-length integer work array of size MAXM. -C INVP Half-length integer work array of size MAXM. -C LENROW Half-length integer work array of size MAXM. -C -C -C -C -C *** PURPOSE -C This routine looks for FREE (and implied FREE) singleton -C columns. If such a variable is found, then the constraint -C with an entry in it can be made FREE. It is thus removed -C from the problem formulation. The information about each -C such event is stored on a stack-type history list, which -C makes possible recovering full PRIMAL solution in a -C POST_SOLVE processing. -C -C -C -C *** SUBROUTINES CALLED -C MYWRT,DABS,EMPTYR,REORDA,REORDI,REORDV -C -C -C *** NOTES -C This routine is given direct access to the matrix A. -C It alters hidden data structures. -C -C -C -C *** REFERENCES: -C Gondzio J. (1994). Presolve analysis of linear programs prior -C to applying an interior point method, Technical Report -C No 1994.3, Department of Management Studies, University -C of Geneva, 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, -C February 1994, revised in December 1994. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: January 12, 1994 -C Last modified: March 29, 1995 -C -C -C -C -C *** BODY OF (RCLSNG) *** -C -C -C -C Initialize. - BIG=1.0D+30 - BIGNEW=1.0D+20 - FSBTOL=1.0D-7 - SMALLA=1.0D-8 - NELIM=0 - NFREE=0 -C - IF(MSGLEV.LE.3) GO TO 140 - DO 130 J=1,N - IF(STAVAR(J).LT.6) GO TO 130 - WRITE(BUFFER,131) J,LENCOL(J),STAVAR(J), - X LOBND(J),UPBND(J),PRLVAR(J) - 131 FORMAT(1X,'col=',I6,' ln=',I4,' st=',I6,' LO=',D10.3, - X ' UP=',D10.3,' X=',D10.3) - CALL MYWRT(IOERR,BUFFER) - 130 CONTINUE - 140 CONTINUE -C -C -C -C Prepare data structures used in a search for singleton columns. -C INTMP1 array handles (dynamically changing) column lengths. -C INTMP2 array handles linked list of singleton columns. - SNGLHD=0 - DO 200 J=1,NSTRCT - INTMP1(J)=LENCOL(J) - IF(LENCOL(J).NE.1) GO TO 200 - IF(STAVAR(J).GE.6) GO TO 200 - IF(STAVAR(J).LT.0) THEN - K=-STAVAR(J) - IF(J.GE.K) GO TO 200 - ENDIF - INTMP2(J)=SNGLHD - SNGLHD=J - 200 CONTINUE -C -C -C -C -C -C -C Main loop begins here. -C Loop over all singleton columns. - 1000 CONTINUE - IF(SNGLHD.EQ.0) GO TO 2100 -C -C -C Pick up a singleton column. - J=SNGLHD - SNGLHD=INTMP2(SNGLHD) - IF(INTMP1(J).NE.1) GO TO 2000 - IF(STAVAR(J).GE.6) GO TO 2000 -C -C Look for still active element in a column. - KBEG=CLPNTS(J) - KEND=CLPNTS(J)+LENCOL(J)-1 - DO 1040 K=KBEG,KEND - I=RWNMBS(K) - IF(RWHEAD(I).GT.0) GO TO 1060 - 1040 CONTINUE - WRITE(BUFFER,1041) J - 1041 FORMAT(1X,'RCLSNG: Column ',I8,' has no entries.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C Save singleton position. - 1060 KBEG=K -C -C Treat original FREE variable specially. - IF(STAVAR(J).LT.0) THEN - K=-STAVAR(J) - IF(J.GE.K) GO TO 2000 - GO TO 1400 - ENDIF -C -C -C Analyse if the singleton column can be made FREE. -C Compute LOWER and UPPER limits of the LP constraint. -C Loop over nonzero entries of row I. Omit column J. - ROWLEN=0 - IPOS=RWHEAD(I) - BLOWER=0.0D0 - BUPPER=0.0D0 - 1100 IF(IPOS.EQ.0) GO TO 1140 - ROWLEN=ROWLEN+1 - JCOL=CLNMBS(IPOS) - IF(JCOL.EQ.J) GO TO 1120 - K=STAVAR(JCOL) - IF(K.GE.6) GO TO 1120 - BNDJUP=BIG - IF(K.EQ.1.OR.K.EQ.3) BNDJUP=UPBND(JCOL) - IF(ACOEFF(IPOS).LT.0.0D0) THEN - BLOWER=BLOWER+BNDJUP*ACOEFF(IPOS) - ELSE - BUPPER=BUPPER+BNDJUP*ACOEFF(IPOS) - ENDIF - 1120 IPOS=RWLINK(IPOS) - GO TO 1100 -C - 1140 CONTINUE - IF(MSGLEV.LE.2) GO TO 1144 - WRITE(BUFFER,1141) I,RWNAME(I),ROWLEN,RWSTAT(I) - 1141 FORMAT(1X,'RCLSNG: Row ',I6,' (name=',A8, - X ') len=',I6,' RWSTAT=',I6) - CALL MYWRT(IOERR,BUFFER) -C WRITE(BUFFER,1142) BLOWER,B(I),BUPPER -C1142 FORMAT(1X,'RCLSNG: blower=',D12.5,' Bi=',D12.5, -C X ' bupper=',D12.5) -C CALL MYWRT(IOERR,BUFFER) - 1144 CONTINUE -C -C Compute implied LOWER and UPPER bounds of the variable J. - K=STAVAR(J) - OLDBND=BIG - IF(K.EQ.1.OR.K.EQ.3) OLDBND=UPBND(J) - IF(ACOEFF(KBEG).LT.0.0D0) THEN - BNDJLO=(B(I)-BLOWER)/ACOEFF(KBEG) - BNDJUP=(B(I)-BUPPER)/ACOEFF(KBEG) - ELSE - BNDJLO=(B(I)-BUPPER)/ACOEFF(KBEG) - BNDJUP=(B(I)-BLOWER)/ACOEFF(KBEG) - ENDIF - IF(MSGLEV.LE.2) GO TO 1164 - WRITE(BUFFER,1161) OLDBND - 1161 FORMAT(38X,' oldUPj=',D10.3) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,1162) J,STAVAR(J),BNDJLO,BNDJUP - 1162 FORMAT(1X,'cl=',I6,' st=',I6,' newLOj=',D10.3, - X ' newUPj=',D10.3) - CALL MYWRT(IOERR,BUFFER) - 1164 CONTINUE -C -C Check if the implied bounds are at least as tight as -C the original ones. - IF(BNDJLO.LE.-FSBTOL) GO TO 2000 - IF(BNDJUP.GE.BIGNEW) BNDJUP=BIGNEW - IF(BNDJUP.GT.OLDBND+FSBTOL) GO TO 2000 -C -C -C Singleton FREE column found. - 1400 CONTINUE - IF(MSGLEV.LE.1) GO TO 1404 - WRITE(BUFFER,1401) I,RWNAME(I) - 1401 FORMAT(1X,'RCLSNG: Row ',I6,' (name=',A8, - X ') is eliminated (it became FREE).') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,1402) J,CLNAME(J) - 1402 FORMAT(1X,'RCLSNG: Variable ',I6,' (name=',A8, - X ') is a sinleton FREE one.') - CALL MYWRT(IOERR,BUFFER) - 1404 CONTINUE -C IF(MSGLEV.LE.2) GO TO 1406 -C WRITE(BUFFER,1405) I,RWNAME(I),RWSTAT(I) -C1405 FORMAT(1X,'RCLSNG: Row ',I6,' (name=',A8,') RWSTAT=',I6) -C CALL MYWRT(IOERR,BUFFER) -C1406 CONTINUE -C -C -C Eliminate row I from matrix A. Update objective function, -C column lengths and the linked list of singleton columns. - NELIM=NELIM+1 - NFREE=NFREE+1 - IPOS=RWHEAD(I) - RWHEAD(I)=-RWHEAD(I) - DP=C(J)/ACOEFF(KBEG) - 1500 IF(IPOS.EQ.0) GO TO 1540 - JCOL=CLNMBS(IPOS) - IF(JCOL.EQ.J) GO TO 1520 - IF(JCOL.GT.NSTRCT) GO TO 1520 -C WRITE(BUFFER,1501) JCOL,C(JCOL),-DP*ACOEFF(IPOS) -C1501 FORMAT(1X,'RCLSNG: j=',I6,' obj=',D10.3,' corr.=',D10.3) -C CALL MYWRT(IOERR,BUFFER) - C(JCOL)=C(JCOL)-DP*ACOEFF(IPOS) - INTMP1(JCOL)=INTMP1(JCOL)-1 - IF(INTMP1(JCOL).EQ.1) THEN - IF(STAVAR(JCOL).LT.0) THEN - IF(JCOL.GE.-STAVAR(JCOL)) GO TO 1520 - ENDIF - INTMP2(JCOL)=SNGLHD - SNGLHD=JCOL - ENDIF - 1520 IPOS=RWLINK(IPOS) - GO TO 1500 -C -C -C Remove column J from the active part of the LP constraint -C matrix. If it was original FREE variable, then remove also -C its brother. Save position of the pivot element. - 1540 INTMP1(J)=KBEG - K=STAVAR(J) - STAVAR(J)=5 - IF(K.LT.0) THEN - K=-K - STAVAR(K)=4 - PRLVAR(K)=0.0D0 - ENDIF -C -C Fix the slack variable if there is any. -C Eliminate slack column from the row linked list. -C It is required for compatibility with SFSM library as its -C CRASH routine reconstructs all logical part of matrix A. - IF(RWSTAT(I).GE.2) THEN - KOK=-RWHEAD(I) - JCOL=CLNMBS(KOK) - PRLVAR(JCOL)=0.0D0 - STAVAR(JCOL)=14 - RWHEAD(I)=-RWLINK(KOK) -C WRITE(BUFFER,1541) I,RWSTAT(I),JCOL -C1541 FORMAT(1X,'RCLSNG: rw=',I6,' rw_st=',I6,' slack=',I6) -C CALL MYWRT(IOERR,BUFFER) - ENDIF -C -C Save the new FREE variable in a PRE_SOLVE history list. - IF(LNHIST.GE.MXHIST) GO TO 9200 - LNHIST=LNHIST+1 - INHIST(LNHIST)=J - DPHIST(LNHIST)=ACOEFF(KBEG) -C -C -C -C End of main loop. - 2000 GO TO 1000 - 2100 CONTINUE -C -C -C -C -C -C -C -C Determine the permutation that puts all empty and inactive -C rows at the end of the list. -C - IRUN=3 - IF(MSGLEV.LE.1) IRUN=4 - CALL EMPTYR(MAXM,M,MNEW,IRUN, - X RWHEAD,STAROW,PERM,INVP,IOERR) -C -C -C Reorder the rows of the LP constraint matrix according to -C the permutation resulting from the analysis of EMPTYR. - IF(MNEW.LT.M) THEN -C - CALL REORDA(MAXM,MAXN,MAXNZA,M,N, - X CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X PERM,INVP,IMTMP1,IROW,RELT, - X RWNAME,STAROW,RWSTAT,RANGES,B,IOERR) -C -C Reorder bounds on shadow prices P and Q. - CALL REORDV(MAXM,M, - X PERM,INVP,P,RELT,IOERR) - CALL REORDV(MAXM,M, - X PERM,INVP,Q,RELT,IOERR) -C -C Reorder elements within each column of the LP constraint -C matrix in such a way that those of the active part of A -C are at the beginning of the lists. The column lengths will -C later be decreased to forget inactive part of matrix A. -C Set the new row linked lists of nonzero elements of matrix A. -C Recall that CLPNTS(j) indicates the first entry of column j. -C Zero RWHEAD and LENROW arrays. - DO 5200 I=1,M - RWHEAD(I)=0 - LENROW(I)=0 - 5200 CONTINUE -C -C Reorder nonzero elements within each column. - DO 5500 J=1,N - IF(STAVAR(J).GE.6) GO TO 5500 - KBEG=CLPNTS(J)-1 - KOK=0 - KOUT=0 -C -C Put the pivot element just behind the active part of every -C FREE (or implied FREE) singleton column. Observe that we put -C it at the last position so as 5300 loop could do the rest. - IF(STAVAR(J).EQ.5) THEN - IPOS=INTMP1(J) - I=RWNMBS(IPOS) - DP=ACOEFF(IPOS) - KEND=KBEG+LENCOL(J) - RWNMBS(IPOS)=RWNMBS(KEND) - ACOEFF(IPOS)=ACOEFF(KEND) - RWNMBS(KEND)=I - ACOEFF(KEND)=DP - ENDIF -C - DO 5300 IKX=1,LENCOL(J) - K=KBEG+IKX - I=RWNMBS(K) - IF(I.LE.MNEW) THEN - KOK=KOK+1 - IROW(KOK)=RWNMBS(K) - RELT(KOK)=ACOEFF(K) - ELSE - IPOS=LENCOL(J)-KOUT - KOUT=KOUT+1 - IROW(IPOS)=RWNMBS(K) - RELT(IPOS)=ACOEFF(K) - ENDIF - 5300 CONTINUE -C -C Set the row linked lists. -C Count nonzero elements in all rows of A. - DO 5400 IKX=1,LENCOL(J) - K=KBEG+IKX - I=IROW(IKX) - RWNMBS(K)=I - ACOEFF(K)=RELT(IKX) - RWLINK(K)=RWHEAD(I) - RWHEAD(I)=K - LENROW(I)=LENROW(I)+1 - 5400 CONTINUE - LENCOL(J)=KOK -C -C Set status for eliminated variables. - IF(STAVAR(J).EQ.4) THEN - IF(J.LE.NSTRCT) THEN - STAVAR(J)=15 - ELSE - STAVAR(J)=14 - ENDIF - ENDIF - IF(STAVAR(J).EQ.5) STAVAR(J)=15 - 5500 CONTINUE -C -C Set the new number of rows of the constraint matrix. - M=MNEW -C - ENDIF -C -C -C -C -C -C -C -C Here if a successful run of the loop has been completed. - IF(MSGLEV.LE.0) GO TO 5010 - WRITE(BUFFER,5001) NELIM - 5001 FORMAT(1X,'RCLSNG: Constraints eliminated: ',I9) -C CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,5002) NFREE - 5002 FORMAT(1X,' Singleton FREE variables:',I8) -C CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - 5010 CONTINUE -C -C -C - RETURN -C -C - 9010 WRITE(BUFFER,9011) RWNAME(I),RTYPE,BLOWER,BUPPER,B(I) - 9011 FORMAT(1X,'RCLSNG: Row=',A8,' type=',A2, - X ' BLO=',D10.3,' BUP=',D10.3,' RHS=',D10.3) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9012) - 9012 FORMAT(1X,'RCLSNG: Problem is infeasible.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9030 WRITE(BUFFER,9031) I,RWNAME(I),B(I) - 9031 FORMAT(1X,'RCLSNG: Constraint ',I6,' (name=',A8, - X ') is violated, B=',D12.6) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9032) - 9032 FORMAT(1X,'RCLSNG: Problem is infeasible.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9200 WRITE(BUFFER,9201) - 9201 FORMAT(1X,'RCLSNG: Please increase space for PRE_SOLVE ', - X 'history list.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C -C -C -C -C *** LAST CARD OF (RCLSNG) *** - END //GO.SYSIN DD hopdm.src/rclsng.f echo hopdm.src/rdmps1.f 1>&2 sed >hopdm.src/rdmps1.f <<'//GO.SYSIN DD hopdm.src/rdmps1.f' 's/^-//' -C**************************************************** -C **** RDMPS1 ... READ THE MPS FILE **** -C**************************************************** -C - SUBROUTINE rdmps1(MAXM,MAXN,MAXNZA, - X M,N,NZA,IROBJ,INMPS,IOERR, - X BIG,DLOBND,DUPBND, - X NAMEC,NAMEB,NAMRAN,NAMBND,NAMMPS,FILMPS, - X RWNAME,CLNAME,STAVAR,RWSTAT, - X HDRWCD,LNKRW,HDCLCD,LNKCL, - X RWNMBS,CLPNTS,IROW, - X ACOEFF,RHS,RANGES, - X UPBND,LOBND,RELT) -C -C -C -C *** PARAMETERS - INTEGER*4 MAXM,MAXN,MAXNZA,M,N,NZA - INTEGER*4 IROBJ,IOERR,INMPS - DOUBLE PRECISION BIG,DLOBND,DUPBND - CHARACTER*9 NAMEC,NAMEB,NAMRAN,NAMBND,NAMMPS - CHARACTER*13 FILMPS - CHARACTER*8 RWNAME(MAXM),CLNAME(MAXN) - INTEGER*2 STAVAR(MAXN),RWSTAT(MAXM),RWNMBS(MAXNZA) - INTEGER*2 HDRWCD(MAXM+1),LNKRW(MAXM+1) - INTEGER*2 HDCLCD(MAXN+1),LNKCL(MAXN+1) - INTEGER*4 CLPNTS(MAXN+1),IROW(MAXN) - DOUBLE PRECISION ACOEFF(MAXNZA),RHS(MAXM),RANGES(MAXM) - DOUBLE PRECISION UPBND(MAXN),LOBND(MAXN),RELT(MAXN) -C -C -C -C *** PARAMETERS DESCRIPTION -C MAXM Maximum current number of constraints. -C MAXN Maximum current number of variables. -C MAXNZA Maximum current number of nonzeros of the LP constraint matrix. -C M Current number of constraints. -C N Current number of variables. -C NZA Current number of nonzeros of the LP constraint matrix. -C IROBJ Index of the objective row. -C IOERR Output unit number for messages. -C INMPS Input unit number for the input MPS file. -C BIG "Big" number. -C DUPBND Default UPPER bound. -C DLOBND Default LOWER bound. -C NAMEC Name of the objective row. -C NAMEB Name of the right hand side section. -C NAMRAN Name of the ranges section. -C NAMBND Name of the bounds section. -C NAMMPS Name of the LP problem. -C FILMPS Name of the MPS input file. -C RWNAME Array of row names. -C CLNAME Array of column names. -C STAVAR Work array for (local) variable status. -C RWSTAT Array of row types: -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 objective row; -C 5 other free row. -C HDRWCD Header to the linked list of rows with the same codes. -C LNKRW Linked list of rows with the same codes. -C HDCLCD Header to the linked list of columns with the same codes. -C LNKCL Linked list of columns with the same codes. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C CLPNTS Pointers to the beginning of columns of matrix A. -C IROW Integer work array. -C ACOEFF Array of nonzero elements for each column. -C RHS Right hand side of the linear program. -C RANGES Array of constraint ranges. -C UPBND Array of upper bounds. -C LOBND Array of lower bounds. -C RELT Real work array. -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 LINE,I,J,COLLEN,INDEX,IPOS,STATUS,NSTRCT,KCODE - DOUBLE PRECISION SMALLA,VAL1,VAL2 - CHARACTER*8 NAME0,NAMRW1,NAMRW2,NAMCLN - CHARACTER*2 TYPROW,BNDTYP - CHARACTER*4 NM - CHARACTER*100 BUFFER - CHARACTER SECT -C -C -C -C *** PURPOSE -C This routine reads the MPS input file. -C -C *** SUBROUTINES CALLED -C LKINDX,RDRHS,MYCODE,LKCODE -C -C *** NOTES -C 1. RANGES section is read but not yet well tested. -C -C -C *** REFERENCES: -C Altman A., Gondzio J. (1993). An efficient implementation of -C a higher order primal-dual interior point method for large -C sparse linear programs, Archives of Control Sciences 2, -C No 1-2, pp. 23-40. -C Altman A., Gondzio J. (1993). HOPDM - A higher order primal- -C dual method for large scale linear programmming, European -C Journal of Operational Research 66 (1993) pp 158-160. -C Gondzio J., Tachat D. (1994). The design and application of -C IPMLO - a FORTRAN library for linear optimization with -C interior point methods, RAIRO Recherche Operationnelle 28, -C No 1, pp. 37-56. -C Murtagh B. (1981). Advanced Linear Programming, McGrew-Hill, -C New York, 1981. -C Murtagh B., Saunders M. (1983). MINOS 5.0 User's guide, -C Technical Report SOL 83-20, Department of Operations Research, -C Stanford University, Stanford, 1983. -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: November 15, 1992 -C Last modified: October 27, 1994 -C -C -C -C -C -C -C *** BODY OF (RDMPS1) *** -C - SMALLA=1.0D-10 -C -C -C -C -C Open the MPS input file. - OPEN(INMPS,FILE=FILMPS,STATUS='OLD',ERR=9300) -C -C -C -C Initialize. - M=0 - LINE=0 - IROBJ=-1 -C - DO 20 I=1,MAXM - RWNAME(I)=' ' - RWSTAT(I)=0 - 20 CONTINUE -C -C Initialize linked lists of rows/cols with the same codes. - DO 40 I=1,MAXM - HDRWCD(I)=0 - LNKRW(I)=0 - 40 CONTINUE - DO 50 J=1,MAXN - HDCLCD(J)=0 - LNKCL(J)=0 - 50 CONTINUE -C -C -C -C Read the problem name. - 60 LINE=LINE+1 - READ(INMPS,61,ERR=9000) NM,NAMMPS - 61 FORMAT(A4,10X,A8) - IF(NM.NE.'NAME'.AND.NM.NE.'name') GO TO 60 - LINE=LINE+1 - READ(INMPS,62,ERR=9000) SECT - 62 FORMAT(A1) - IF(SECT.NE.'R'.AND.SECT.NE.'r') GO TO 9000 -C -C -C -C -C -C -C Read the ROWS section. - 100 LINE=LINE+1 - READ(INMPS,101,ERR=9000) SECT,TYPROW,NAMRW1 - 101 FORMAT(A1,A2,1X,A8) - IF(SECT.NE.' ') GO TO 200 -C -C Here if a constraint has been found. Determine its type. -C Check if there is enough space for a new row. - M=M+1 - IF(M.GE.MAXM) GO TO 9010 -C - IF(TYPROW.EQ.' E'.OR.TYPROW.EQ.'E '.OR. - X TYPROW.EQ.' e'.OR.TYPROW.EQ.'e ') THEN - RWSTAT(M)=1 - GO TO 120 - ENDIF -C - IF(TYPROW.EQ.' G'.OR.TYPROW.EQ.'G '.OR. - X TYPROW.EQ.' g'.OR.TYPROW.EQ.'g ') THEN - RWSTAT(M)=2 - GO TO 120 - ENDIF -C - IF(TYPROW.EQ.' L'.OR.TYPROW.EQ.'L '.OR. - X TYPROW.EQ.' l'.OR.TYPROW.EQ.'l ') THEN - RWSTAT(M)=3 - GO TO 120 - ENDIF -C - IF(TYPROW.EQ.' N'.OR.TYPROW.EQ.'N '.OR. - X TYPROW.EQ.' n'.OR.TYPROW.EQ.'n ') THEN - IF(NAMRW1.EQ.NAMEC(1:8)) THEN -C -C Save index of the objective row. - IROBJ=M - RWSTAT(M)=4 - ELSE - RWSTAT(M)=5 -C -C The first free row is a default objective. - IF(NAMEC(1:8).EQ.' ') THEN - IROBJ=M - RWSTAT(M)=4 - NAMEC(1:8)=NAMRW1 - ENDIF - ENDIF - GO TO 120 - ENDIF -C -C Invalid row type. - GO TO 9050 -C -C Here to save the row name. - 120 RWNAME(M)=NAMRW1 -C -C Continue reading of the ROWS section. - GO TO 100 -C -C -C -C -C -C -C Read COLUMNS section. - 200 CONTINUE - INDEX=1 -C -C ENCODE all row names and create linked lists of rows -C with the same codes. - DO 210 I=1,M - CALL MYCODE(IOERR,RWNAME(I),KCODE,M) - LNKRW(I)=HDRWCD(KCODE) - HDRWCD(KCODE)=I - 210 CONTINUE -C - IF(SECT.NE.'C'.AND.SECT.NE.'c') GO TO 9000 - NAME0=' ' - 220 LINE=LINE+1 - READ(INMPS,221,ERR=9000) SECT,NAMCLN,NAMRW1,VAL1,NAMRW2,VAL2 - 221 FORMAT(A1,3X,A8,2X,A8,2X,D12.0,3X,A8,2X,D12.0) -C - IF(NAMCLN.EQ.NAME0) GO TO 260 -C -C Here if the new column has been found. -C Save the previous column in the LP data structures. -C -C Check if this is the first column. - IF(NAME0.EQ.' ') THEN - NAME0=NAMCLN - COLLEN=0 - NZA=0 - N=1 - GO TO 260 - ENDIF -C - IF(NZA+COLLEN.GT.MAXNZA) GO TO 9020 -C - CLPNTS(N)=NZA+1 - CLNAME(N)=NAME0 - DO 240 I=1,COLLEN - IPOS=NZA+I - RWNMBS(IPOS)=IROW(I) - ACOEFF(IPOS)=RELT(I) - 240 CONTINUE - NZA=NZA+COLLEN -C -C Check if there are still columns to be read. - IF(SECT.NE.' ') THEN - CLPNTS(N+1)=NZA+1 - NSTRCT=N - GO TO 300 - ELSE -C -C Initialize the new column. - N=N+1 - IF(N.GE.MAXN) GO TO 9030 - NAME0=NAMCLN - COLLEN=0 - GO TO 260 - ENDIF -C -C -C Find the position of the nonzero element. -C 260 CALL LKINDX(RWNAME,M,NAMRW1,INDEX) - 260 CALL LKCODE(RWNAME,M,NAMRW1,INDEX,HDRWCD,LNKRW,IOERR) - IF(INDEX.EQ.0) GO TO 9040 -C -C -C Save nonzero element of the N-th column. - IF(DABS(VAL1).LE.SMALLA) GO TO 280 - COLLEN=COLLEN+1 - IROW(COLLEN)=INDEX - RELT(COLLEN)=VAL1 -C -C Check if there is another nonzero read in the analysed line. - 280 IF(NAMRW2.NE.' ') THEN - NAMRW1=NAMRW2 - VAL1=VAL2 - NAMRW2=' ' - GO TO 260 - ELSE - GO TO 220 - ENDIF -C -C -C -C -C Initialize RHS and RANGES arrays. - 300 DO 320 I=1,M - RHS(I)=0.0 - RANGES(I)=BIG - 320 CONTINUE -C -C -C -C Set the default bounds for all structural variables. - DO 520 J=1,N - STAVAR(J)=0 - LOBND(J)=DLOBND - UPBND(J)=DUPBND - 520 CONTINUE -C -C -C -C -C -C -C Read the RHS section. -C - IF(SECT.NE.'R'.AND.SECT.NE.'r') GO TO 9000 - CALL RDRHS(MAXM,M,LINE, - X HDRWCD,LNKRW,HDCLCD,LNKCL, - X NAMEB,RHS,RWNAME,SECT,INMPS,IOERR) -C -C -C -C -C Check if there is a RANGES section to be read. - IF(SECT.NE.'R'.AND.SECT.NE.'r') GO TO 400 -C -C -C -C -C -C -C Read the RANGES section. -C - CALL RDRHS(MAXM,M,LINE, - X HDRWCD,LNKRW,HDCLCD,LNKCL, - X NAMRAN,RANGES,RWNAME,SECT,INMPS,IOERR) -C -C -C - 400 CONTINUE - IF(SECT.NE.'B'.AND.SECT.NE.'b') GO TO 600 -C -C -C -C -C -C -C Read the BOUNDS section. -C - INDEX=1 - 550 LINE=LINE+1 -C -C ENCODE all column names and create linked lists of columns -C with the same codes. -C DO 560 J=1,N -C CALL MYCODE(IOERR,CLNAME(J),KCODE,N) -C LNKCL(J)=HDCLCD(KCODE) -C HDCLCD(KCODE)=J -C 560 CONTINUE -C - READ(INMPS,561,ERR=9000) SECT,BNDTYP,NAME0,NAMCLN,VAL1 - 561 FORMAT(A1,A2,1X,A8,2X,A8,2X,D12.0) -C - IF(SECT.NE.' ') GO TO 600 -C -C First record met defines default section name. - IF(NAMBND(1:8).EQ.' ') THEN - NAMBND(1:8)=NAME0 - ENDIF -C -C Ignore the record that define unimportant bound. - IF(NAME0.NE.NAMBND(1:8)) GO TO 550 -C -C Determine index of the variable to which the bound refers. - CALL LKINDX(CLNAME,N,NAMCLN,INDEX) -C CALL LKCODE(CLNAME,N,NAMCLN,INDEX,HDCLCD,LNKCL,IOERR) - IF(INDEX.EQ.0) GO TO 9060 -C -C -C Here to detect the type of the bound read. - STATUS=STAVAR(INDEX) -C -C -C - IF(BNDTYP.EQ.'UP'.OR.BNDTYP.EQ.'up') THEN -C -C Here when an UPPER bound is being defined. -C Accept multiple definition of the UPPER bound. -C The last definition is valid. - IF(STATUS.EQ.6) GO TO 9070 - IF(STATUS.EQ.-1) GO TO 9080 -C - IF(STATUS.EQ.0.OR.STATUS.EQ.1) THEN -C -C Not yet bounded variable (or multiple UPPER bound). - UPBND(INDEX)=VAL1 - STAVAR(INDEX)=1 - GO TO 550 - ENDIF -C - IF(STATUS.EQ.2.OR.STATUS.EQ.3) THEN -C -C Already LOWER bounded variable. - UPBND(INDEX)=VAL1 - STAVAR(INDEX)=3 - GO TO 550 - ENDIF -C - ENDIF -C -C -C - IF(BNDTYP.EQ.'LO'.OR.BNDTYP.EQ.'lo') THEN -C -C Here when a LOWER bound is being defined. - IF(STATUS.EQ.2.OR.STATUS.EQ.3.OR.STATUS.EQ.6) GO TO 9070 - IF(STATUS.EQ.-1) GO TO 9080 -C - IF(STATUS.EQ.0) THEN -C -C Not yet bounded variable. - LOBND(INDEX)=VAL1 - STAVAR(INDEX)=2 - GO TO 550 - ENDIF -C - IF(STATUS.EQ.1) THEN -C -C Already UPPER bounded variable. - LOBND(INDEX)=VAL1 - STAVAR(INDEX)=3 - GO TO 550 - ENDIF -C - ENDIF -C -C -C - IF(BNDTYP.EQ.'FR'.OR.BNDTYP.EQ.'fr') THEN -C -C Here when a FREE variable is being defined. - IF(STATUS.GT.0) GO TO 9090 -C -C Not yet bounded variable. - LOBND(INDEX)=-BIG - UPBND(INDEX)=BIG - STAVAR(INDEX)=-1 - GO TO 550 -C - ENDIF -C -C -C - IF(BNDTYP.EQ.'FX'.OR.BNDTYP.EQ.'fx') THEN -C -C Here when a FIXED variable is being defined. - IF(STATUS.EQ.-1) GO TO 9080 - IF(STATUS.NE.0) GO TO 9100 -C -C Not yet bounded variable. - LOBND(INDEX)=VAL1 - UPBND(INDEX)=VAL1 - STAVAR(INDEX)=6 - GO TO 550 -C - ENDIF -C -C -C - IF(BNDTYP.EQ.'PL'.OR.BNDTYP.EQ.'pl') THEN -C -C Here when a PLUS INFINITY bound is being defined. - IF(STATUS.EQ.-1) GO TO 9080 - IF(STATUS.NE.0) GO TO 9070 -C -C Not yet bounded variable. -C LOBND(INDEX)=VAL1 - UPBND(INDEX)=BIG - STAVAR(INDEX)=2 - GO TO 550 -C - ENDIF -C -C -C - IF(BNDTYP.EQ.'MI'.OR.BNDTYP.EQ.'mi') THEN -C -C Here when a MINUS INFINITY bound is being defined. - IF(STATUS.EQ.-1) GO TO 9080 - IF(STATUS.NE.0) GO TO 9070 -C -C Not yet bounded variable. - LOBND(INDEX)=-BIG -C UPBND(INDEX)=VAL1 - STAVAR(INDEX)=1 - GO TO 550 -C - ENDIF -C - GO TO 9110 -C -C -C - 600 CONTINUE - IF(SECT.NE.'E'.AND.SECT.NE.'e') GO TO 9000 -C -C -C -C -C -C -C The ENDATA card has been found. -C - IF(IROBJ.EQ.-1) GO TO 9130 -C -C -C Close the MPS input file. - CLOSE(INMPS) - RETURN -C -C -C -C -C -C Here when error occurs. - 9000 WRITE(BUFFER,9001) LINE - 9001 FORMAT(1X,'RDMPS1: Error while reading line',I10, - X ' of the MPS file.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9010 WRITE(BUFFER,9011) - 9011 FORMAT(1X,'RDMPS1 ERROR: Number of constraints', - X ' in the MPS file exceeds MAXM.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9020 WRITE(BUFFER,9021) - 9021 FORMAT(1X,'RDMPS1 ERROR: Number of nonzeros', - X ' of matrix A exceeds MAXNZA.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9030 WRITE(BUFFER,9031) - 9031 FORMAT(1X,'RDMPS1 ERROR: Number of variables', - X ' in the MPS file exceeds MAXN.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9040 WRITE(BUFFER,9041) LINE - 9041 FORMAT(1X,'RDMPS1 ERROR: Unknown row found', - X ' at line',I10,' of the MPS file.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9050 WRITE(BUFFER,9051) TYPROW,LINE - 9051 FORMAT(1X,'RDMPS1 ERROR: Unknown row type=',A2, - X ' at line',I10,' of the MPS file.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9060 WRITE(BUFFER,9061) LINE - 9061 FORMAT(1X,'RDMPS1 ERROR: Unknown column found', - X ' at line',I10,' of the MPS file.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9070 WRITE(BUFFER,9071) LINE,BNDTYP - 9071 FORMAT(1X,'RDMPS1 ERROR: Line',I10,' in MPS file', - X ' defines ',A2,' bound') - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9072) NAMCLN - 9072 FORMAT(14X,'for variable ',A8, - X ' that has already been bounded.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9080 WRITE(BUFFER,9081) LINE,BNDTYP - 9081 FORMAT(1X,'RDMPS1 ERROR: Line',I10,' in MPS file', - X ' defines ',A2,' bound') - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9082) NAMCLN - 9082 FORMAT(14X,'for variable ',A8, - X ' that has earlier been declared FREE.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9090 WRITE(BUFFER,9091) LINE - 9091 FORMAT(1X,'RDMPS1 ERROR: Line',I10,' in MPS file', - X ' declares as FREE') - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9092) NAMCLN - 9092 FORMAT(14X,' variable ',A8, - X ' that has earlier been bounded.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9100 WRITE(BUFFER,9101) LINE - 9101 FORMAT(1X,'RDMPS1 ERROR: Line',I10,' in MPS file', - X ' declares as FIXED') - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9102) NAMCLN - 9102 FORMAT(14X,' variable ',A8, - X ' that has earlier been bounded.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9110 WRITE(BUFFER,9111) LINE,BNDTYP - 9111 FORMAT(1X,'RDMPS1 ERROR: Line',I10,' in MPS file', - X ' has invalid bound type ',A2) - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9130 WRITE(BUFFER,9131) NAMEC(1:8) - 9131 FORMAT(1X,'RDMPS1 ERROR: Objective row =',A8, - X ' has no entries.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9300 WRITE(BUFFER,9301) FILMPS - 9301 FORMAT(1X,'RDMPS1 ERROR: Cannot open file = ',A13) - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C -C -C *** LAST CARD OF (RDMPS1) *** - END //GO.SYSIN DD hopdm.src/rdmps1.f echo hopdm.src/rdmps2.f 1>&2 sed >hopdm.src/rdmps2.f <<'//GO.SYSIN DD hopdm.src/rdmps2.f' 's/^-//' -C**************************************************** -C **** RDMPS2 ... READ THE MPS FILE **** -C**************************************************** -C - SUBROUTINE RDMPS2(C,B,RANGES, - X CLPNTS,RWNMBS,ACOEFF, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X MAXM,MAXN,MAXNZA,M,N,NZA,NSTRCT,MULT, - X IMTMP1,IMTMP2,IMTMP3, - X STAVAR,UPBND,LOBND,BIG,IROBJ, - X NAMMPS,RWNAME,RWSTAT,STAROW,CLNAME, - X RWORK,IWORK,RMAP,IMAP,IROW,RELT, - X PRLVAR,IOERR) -C -C -C -C *** VARIABLES AND ARRAYS ASSOCIATED WITH THE MPS FILE - INTEGER*4 MAXM,MAXN,MAXNZA,M,N,NZA,NSTRCT,IROBJ - CHARACTER*9 NAMMPS - CHARACTER*8 RWNAME(MAXM),CLNAME(MAXN) - INTEGER*2 STAVAR(MAXN),STAROW(MAXM),RWSTAT(MAXM) - DOUBLE PRECISION RANGES(MAXM),UPBND(MAXN),LOBND(MAXN),BIG,MULT -C -C *** MPS VARIABLES DESCRIPTION -C MAXM Maximum number of constraints. -C MAXN Maximum number of variables. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Current number of constraints. -C N Number of variables (total, i.e. including slacks, surplus -C and artificials). -C NZA Current number of nonzeros of the LP constraint matrix. -C NSTRCT Number of structural variables (excluding slacks, surplus -C and artificials). -C MULT Direction of optimization: -C +1 means minimization; -C -1 means maximization. -C NAMMPS The name of the LP problem. -C RWNAME Array of row names. -C RWSTAT Array of row types: -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 objective row; -C 5 other free row. -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C CLNAME Array of column names. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C RANGES Array of constraint ranges. -C UPBND Array of upper bounds. Note that the upper bound -C is changed when the variable has a lower bound. -C LOBND Array of lower bounds. -C -C -C -C *** INPUT/OUTPUT FILES - INTEGER*4 IOERR -C -C *** INPUT/OUTPUT FILES DESCRIPTION -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(*),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(*) -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real work array containing almost all real -C LP problem data. -C IWORK Integer work array containing almost all integer -C LP problem data. -C RMAP Map of RWORK. -C IMAP Map of IWORK. -C -C Map of IWORK array: -C IMAP(1) Points to CLPNTS array. -C IMAP(2) Points to RWNMBS array. -C IMAP(3) Points to RWHEAD array. -C IMAP(4) Points to RWLINK array. -C IMAP(5) Points to CLNMBS array. -C IMAP(6) Points to LENCOL array. -C IMAP(7) Points to the first empty cell of IWORK array. -C -C Map of RWORK array: -C RMAP(1) Points to ACOEFF array. -C RMAP(2) Points to COBJ array. -C RMAP(3) Points to RHS array. -C RMAP(4) Points to the first empty cell of RWORK array. -C -C -C -C *** LP DATA - DOUBLE PRECISION ACOEFF(MAXNZA),C(MAXN),B(MAXM) - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM),RWLINK(MAXNZA) - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) -C -C *** LP DATA DESCRIPTION -C ACOEFF Array of nonzero elements for each column. -C C Objective function coefficients. -C B Right hand side of the linear program. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C LENCOL Lengths of (sparse) columns of matrix A. -C -C -C -C *** WORK ARRAYS - INTEGER*4 IMTMP1(MAXM),IMTMP2(MAXM),IMTMP3(MAXM) - INTEGER*4 IROW(MAXN) - DOUBLE PRECISION RELT(MAXN),PRLVAR(MAXN) -C -C *** WORK ARRAYS DESCRIPTION -C IMTMP1 Integer work array of size MAXM. -C IMTMP2 Integer work array of size MAXM. -C IMTMP3 Integer work array of size MAXM -C IROW and RELT are the arrays for temporary handling of rows -C and columns of the constraint matrix. They are primarily -C intended to handle sparse vectors (in packed form) -C but may also be used for storing dense ones. -C PRLVAR Primal variables of the LP problem. -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 MEQ,MGE,MLE,MFREE,MNEW,I,J,COLLEN,INDEX - INTEGER*4 ITRACE,IKX,IPOS,K,KBEG,KEND,KNEW,KOK,KOUT - DOUBLE PRECISION BIGNEW,VAL1 - CHARACTER*100 BUFFER -C -C An indicator if a stronger barrier is to be used. - COMMON /LBARR/ IBARR - INTEGER*4 IBARR -C -C -C -C *** LOCAL VARIABLES DESCRIPTION -C MEQ Number of equality constraints. -C MGE Number of constraints of type greater or equal. -C MLE Number of constraints of type less or equal. -C MFREE Number of free constraints. -C MNEW Number of constraints after removing the free ones. -C ITRACE Trace parameter: -C 0 means no message at all; -C 1 means writing MPS file statistics; -C 2 means detailed tracing the MPS file input. -C -C -C -C *** PURPOSE -C This routine reads the MPS input file. -C -C -C -C *** SUBROUTINES CALLED -C SDOT,GETCOL,GETROW -C -C -C -C *** NOTES -C 1. RANGES section is read but not yet well tested. -C -C -C -C *** REFERENCES: -C Altman A., Gondzio J. (1993). An efficient implementation of -C a higher order primal-dual interior point method for large -C sparse linear programs, Archives of Control Sciences 2, -C No 1-2, pp. 23-40. -C Altman A., Gondzio J. (1993). HOPDM - A higher order primal- -C dual method for large scale linear programmming, European -C Journal of Operational Research 66 (1993) pp 158-160. -C Gondzio J., Tachat D. (1994). The design and application of -C IPMLO - a FORTRAN library for linear optimization with -C interior point methods, RAIRO Recherche Operationnelle 28, -C No 1, pp. 37-56. -C Murtagh B. (1981). Advanced Linear Programming, McGrew-Hill, -C New York, 1981. -C Murtagh B., Saunders M. (1983). MINOS 5.0 User's guide, -C Technical Report SOL 83-20, Department of Operations Research, -C Stanford University, Stanford, 1983. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: November 15, 1992 -C Last modified: October 27, 1994 -C -C -C -C -C -C -C *** BODY OF (RDMPS2) *** -C -C -C -C Initialize. - ITRACE=1 - MEQ=0 - MGE=0 - MLE=0 - MFREE=0 - BIGNEW=0.999*BIG -C -C -C Count constraints of different types. - DO 100 I=1,M - STAROW(I)=0 -C - IF(RWSTAT(I).EQ.1) THEN - MEQ=MEQ+1 - GO TO 100 - ENDIF -C - IF(RWSTAT(I).EQ.2) THEN - MGE=MGE+1 - GO TO 100 - ENDIF -C - IF(RWSTAT(I).EQ.3) THEN - MLE=MLE+1 - GO TO 100 - ENDIF -C - IF(RWSTAT(I).GE.4) THEN - MFREE=MFREE+1 - GO TO 100 - ENDIF - 100 CONTINUE -C -C -C Write the MPS statistics. - IF(ITRACE.EQ.0) GO TO 120 -C - WRITE(BUFFER,101) NAMMPS(1:8) - 101 FORMAT(1X,'RDMPS: ',A8,' MPS file statistics:') - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) - WRITE(BUFFER,102) M-1 - 102 FORMAT(8X,I9,' constraints in the LP problem:') - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) - WRITE(BUFFER,103) MEQ - 103 FORMAT(8X,I9,' of equality type,') - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) - WRITE(BUFFER,104) MGE - 104 FORMAT(8X,I9,' of type greater or equal to,') - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) - WRITE(BUFFER,105) MLE - 105 FORMAT(8X,I9,' of type less or equal to,') - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) - WRITE(BUFFER,106) MFREE-1 - 106 FORMAT(8X,I9,' free rows (excluding objective);') - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) - WRITE(BUFFER,107) N - 107 FORMAT(8X,I9,' variables in the LP problem;') - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) - NZA=CLPNTS(N+1)-1 - WRITE(BUFFER,108) NZA - 108 FORMAT(8X,I9,' nonzero elts in the LP problem.') - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) -C - 120 CONTINUE -C -C -C Initialize objective function. - DO 160 J=1,MAXN - C(J)=0.0D0 - 160 CONTINUE -C -C -C Retrieve objective function from the constraint matrix. -C Count nonzero elements in all LP constraints. - DO 200 J=1,N - KBEG=CLPNTS(J) - KEND=CLPNTS(J+1)-1 - DO 180 INDEX=KBEG,KEND - I=RWNMBS(INDEX) - STAROW(I)=STAROW(I)+1 - IF(I.EQ.IROBJ) C(J)=MULT*ACOEFF(INDEX) - 180 CONTINUE -C WRITE(IOERR,181) J,C(J) -C 181 FORMAT(1X,'J=',I5,' Cj=',D14.6) - 200 CONTINUE -C -C -C Set the row linked lists of nonzero elements of matrix A. -C Set up LENCOL array (do not count entries of free rows). -C Recall that CLPNTS(j) indicates the first entry of column j. -C Zero RWHEAD array. - DO 420 I=1,M - RWHEAD(I)=0 - 420 CONTINUE -C -C Set the row linked lists. - DO 460 J=1,N - LENCOL(J)=0 - KBEG=CLPNTS(J) - KEND=CLPNTS(J+1)-1 - DO 440 K=KBEG,KEND - I=RWNMBS(K) - IF(RWSTAT(I).LE.3) LENCOL(J)=LENCOL(J)+1 - RWLINK(K)=RWHEAD(I) - CLNMBS(K)=J - RWHEAD(I)=K - 440 CONTINUE -C WRITE(IOERR,441) J,LENCOL(J),CLPNTS(J),CLPNTS(J+1) -C 441 FORMAT(1X,'J=',I5,' ln=',I6,' pnts=',I6,2X,I6) - 460 CONTINUE -C -C -C -C Modify STAROW array. Zero value indicates empty (or free) row. - DO 480 I=1,M - IF(STAROW(I).GT.0) STAROW(I)=1 - IF(RWSTAT(I).GE.4) STAROW(I)=0 - 480 CONTINUE -C -C -C -C Reorder rows of the LP constraint matrix to eliminate -C the empty ones. -C -C Determine the permutation that puts all empty (or free) -C rows at the end of the list. -C - I=1 - CALL EMPTYR(MAXM,M,MNEW,I, - X RWHEAD,STAROW,IROW(1),IMTMP1(1),IOERR) -C -C -C -C Reorder the rows of the LP constraint matrix according to -C the permutation resulting from the elimination of empty rows. -C - IF(MNEW.EQ.M) GO TO 610 - CALL REORDA(MAXM,MAXN,MAXNZA,M,N, - X CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X IROW(1),IMTMP1(1),IMTMP2,IMTMP3,RELT, - X RWNAME,STAROW,RWSTAT,RANGES,B,IOERR) -C -C -C -C Reorder elements within each column of the LP constraint -C matrix in such a way that those of the active part of A -C are at the beginning of the lists. The column lengths will -C later be decreased to forget inactive part of matrix A. -C Set the new row linked lists of nonzero elements of matrix A. -C Recall that CLPNTS(j) indicates the first entry of column j. -C Zero RWHEAD array. - DO 520 I=1,M - RWHEAD(I)=0 - 520 CONTINUE - DO 600 J=1,N - KOK=0 - KOUT=0 - KBEG=CLPNTS(J)-1 - COLLEN=CLPNTS(J+1)-CLPNTS(J) - DO 540 IKX=1,COLLEN - K=KBEG+IKX - I=RWNMBS(K) - IF(I.LE.MNEW) THEN - KOK=KOK+1 - IROW(KOK)=RWNMBS(K) - RELT(KOK)=ACOEFF(K) - ELSE - IPOS=COLLEN-KOUT - KOUT=KOUT+1 - IROW(IPOS)=RWNMBS(K) - RELT(IPOS)=ACOEFF(K) - ENDIF - 540 CONTINUE -C -C Set the row linked lists. - DO 560 IKX=1,COLLEN - K=KBEG+IKX - I=IROW(IKX) - RWNMBS(K)=I - ACOEFF(K)=RELT(IKX) - RWLINK(K)=RWHEAD(I) - RWHEAD(I)=K - 560 CONTINUE - 600 CONTINUE -C -C -C Set the new number of rows of the constraint matrix. - 610 M=MNEW -C -C -C -C -C Define variable status and transform the problem accordingly. -C -C STAVAR(j)=0 for STANDARD (nonnegative) variable. -C -C STAVAR(j)=-k for FREE variable. FREE variable is split into -C two STANDARD variables: xj-xk. Consequently, variable xk -C is added to the problem and j-th column is replicated -C with the negative sign. -C -C STAVAR(j)=1 for UPPER bounded variable. -C -C STAVAR(j)=2 for LOWER bounded variable. Such variable is -C pushed to a zero LOWER bound (it becomes a STANDARD variable) -C and the RHS vector is transformed accordingly. -C -C STAVAR(j)=3 for both LOWER and UPPER bounded variable. Such -C variable is first pushed to a zero LOWER bound, which causes -C changing its UPPER bound (and at the same time requires -C some modification of the RHS vector) and later treated as -C an UPPER bounded variable. -C -C STAVAR(j)=6 for FIXED variable. Such variable is eliminated -C from the LP problem formulation (this needs appropriate -C modification of the RHS vector). -C -C -C -C -C -C -C Analyse variable bounds and define STAVAR array. - IF(IBARR.EQ.2) BIGNEW=9999.0D0 - NSTRCT=N - NZA=CLPNTS(N+1)-1 - DO 700 J=1,NSTRCT - STAVAR(J)=0 - PRLVAR(J)=0.0D0 -C -C -C Check if the variable is FREE. - IF(LOBND(J).LE.-BIGNEW.AND.UPBND(J).GE.BIGNEW) THEN - N=N+1 - IF(N.GT.MAXN) GO TO 9030 - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - COLLEN=LENCOL(J) - IF(NZA+COLLEN.GT.MAXNZA) GO TO 9020 - DO 620 K=KBEG,KEND - KNEW=NZA+K-KBEG+1 - RWNMBS(KNEW)=RWNMBS(K) - ACOEFF(KNEW)=-ACOEFF(K) - I=RWNMBS(K) - RWLINK(KNEW)=RWHEAD(I) - CLNMBS(KNEW)=N - RWHEAD(I)=KNEW - 620 CONTINUE - C(N)=-C(J) - STAVAR(N)=-J - LOBND(N)=0.0D0 - UPBND(N)=BIG - PRLVAR(N)=0.0D0 - STAVAR(J)=-N - LOBND(J)=0.0D0 - UPBND(J)=BIG - CLPNTS(N)=NZA+1 - CLNAME(N)=' ' - LENCOL(N)=COLLEN - NZA=NZA+COLLEN - GO TO 700 - ENDIF -C -C -C Check if the variable has type MINUS INFINITY. - IF(LOBND(J).LE.-BIGNEW.AND.UPBND(J).LE.BIGNEW) THEN -C -C Observe that we only change the sign of MI type variable. -C The next section will take contribution of nonzero lower -C bound, if any. - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 640 K=KBEG,KEND - ACOEFF(K)=-ACOEFF(K) - 640 CONTINUE - C(J)=-C(J) - LOBND(J)=-UPBND(J) - UPBND(J)=BIG - ENDIF -C -C -C -C Check if the variable has nonzero LOWER bound. - IF(LOBND(J).NE.0.0D0) THEN - STAVAR(J)=2 - VAL1=LOBND(J) - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 660 K=KBEG,KEND - I=RWNMBS(K) - B(I)=B(I)-VAL1*ACOEFF(K) - 660 CONTINUE -C -C Check if the variable has also finite UPPER bound. - IF(UPBND(J).LE.BIGNEW) THEN -C -C Here if the variable has both LOWER and UPPER bounds. -C Observe that it has already been pushed to a zero LOWER bound. -C Consequently, its new UPPER bound is equal to UPBND(J)-LOBND(J). - STAVAR(J)=3 - IF(UPBND(J).LT.LOBND(J)) GO TO 9200 - UPBND(J)=UPBND(J)-LOBND(J) -C -C Check if the UPPER bound is equal to the LOWER bound. -C If so, then FIX the variable on its LOWER bound. - IF(UPBND(J).EQ.0.0D0) THEN - PRLVAR(J)=0.0 - STAVAR(J)=6 - GO TO 700 - ENDIF - ENDIF - GO TO 700 - ENDIF -C -C -C Check if the variable has finite UPPER bound. - IF(UPBND(J).LE.BIGNEW) THEN - STAVAR(J)=1 - IF(UPBND(J).LT.0.0D0) GO TO 9200 -C -C Check if the UPPER bound is equal to the LOWER bound. -C If so, then FIX the variable on its LOWER bound. - IF(UPBND(J).EQ.0.0D0) THEN - PRLVAR(J)=0.0 - STAVAR(J)=6 - GO TO 700 - ENDIF - GO TO 700 - ENDIF -C - 700 CONTINUE - CLPNTS(N+1)=NZA+1 - NSTRCT=N -C -C -C -C -C Check if there were any FIXED variables. If so, then they -C have been removed from the LP problem formulation and, -C consequently, should be removed from the row linked lists. - DO 710 J=1,N - IF(STAVAR(J).EQ.6) THEN - GO TO 720 - ENDIF - 710 CONTINUE -C -C Here if there are no FIXED variables. - GO TO 780 -C -C Here if a FIXED variable has been found. -C Set the new row linked lists of nonzero elements of matrix A. -C Recall that CLPNTS(j) indicates the first entry of column j. -C Zero RWHEAD array. - 720 DO 730 I=1,M - RWHEAD(I)=0 - 730 CONTINUE -C WRITE(BUFFER,731) -C 731 FORMAT(1X,'RDMPS2: FIXED variables found.') -C CALL MYWRT(IOERR,BUFFER) -C -C Set the row linked lists. - DO 750 J=1,N -C -C Omit FIXED variables. - IF(STAVAR(J).EQ.6) GO TO 750 - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 740 K=KBEG,KEND - I=RWNMBS(K) - RWLINK(K)=RWHEAD(I) - CLNMBS(K)=J - RWHEAD(I)=K - 740 CONTINUE - 750 CONTINUE -C -C -C -C Check if the removal of the FIXED variables created empty rows. - DO 770 I=1,M - IF(RWHEAD(I).NE.0) GO TO 770 -C -C -C Determine the permutation that puts all empty rows -C at the end of the list. -C - CALL EMPTYR(MAXM,M,MNEW,2, - X RWHEAD,STAROW,IROW(1),IMTMP1(1),IOERR) -C -C -C Reorder the rows of the LP constraint matrix according to -C the permutation resulting from the elimination of empty rows. -C - CALL REORDA(MAXM,MAXN,MAXNZA,M,N, - X CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X IROW(1),IMTMP1(1),IMTMP2,IMTMP3,RELT, - X RWNAME,STAROW,RWSTAT,RANGES,B,IOERR) -C -C Set the new number of rows of the constraint matrix. - M=MNEW -C - GO TO 780 - 770 CONTINUE -C -C -C -C -C -C -C Add slack and surplus variables. -C Initialize all structural variables to zero values. - 780 CONTINUE -C -C -C -C -C Recall that RWSTAT is the array of row types: -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 objective row; -C 5 other free row. -C -C Loop over all constraints. - DO 800 I=1,M -C - IF(RWSTAT(I).EQ.1) THEN -C -C Here for EQUALITY constraint. -C Do not add any variable. - GO TO 800 - ENDIF -C - N=N+1 - IF(N.GE.MAXN) GO TO 9030 - IF(NZA+1.GE.MAXNZA) GO TO 9020 - KNEW=NZA+1 -C - IF(RWSTAT(I).EQ.2) THEN -C -C Here for GREATER OR EQUAL type constraint. -C Add the artificial variable. - ACOEFF(KNEW)=-1.0 - C(N)=0.0 - LENCOL(N)=1 - GO TO 790 - ENDIF -C - IF(RWSTAT(I).EQ.3) THEN -C -C Here for LESS OR EQUAL type constraint. -C Add the artificial variable. - ACOEFF(KNEW)=+1.0 - C(N)=0.0 - LENCOL(N)=1 - GO TO 790 - ENDIF -C - GO TO 9120 -C - 790 RWNMBS(KNEW)=I - RWLINK(KNEW)=RWHEAD(I) - CLNMBS(KNEW)=N - RWHEAD(I)=KNEW - STAVAR(N)=0 - CLNAME(N)='logical ' - LOBND(N)=0.0D0 - UPBND(N)=BIG - IF(RANGES(I).LE.BIGNEW) THEN -C WRITE(BUFFER,791) I,RANGES(I) -C 791 FORMAT(1X,'RDMPS2: row=',I6,' range=',D12.6) -C CALL MYWRT(0,BUFFER) -C CALL MYWRT(IOERR,BUFFER) - STAVAR(N)=1 - UPBND(N)=RANGES(I) - ENDIF - PRLVAR(N)=0.0D0 - CLPNTS(N)=NZA+1 - NZA=NZA+1 -C -C -C - 800 CONTINUE - CLPNTS(N+1)=NZA+1 -C -C -C -C Initialize primal variables and count large upper bounds. - K=0 - DO 820 J=1,N - PRLVAR(J)=0.0 - IF(STAVAR(J).EQ.1.OR.STAVAR(J).EQ.3) THEN - IF(UPBND(J).GE.9999.0) K=K+1 - ENDIF - 820 CONTINUE - IF(K.GE.1) THEN - WRITE(BUFFER,821) K - 821 FORMAT(1X,'RDMPS: ',I8,' variables have large UPPER bound.') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - ENDIF -C -C - IF(ITRACE.EQ.0) GO TO 890 -C -C Write the LP problem statistics. - K=0 - DO 840 J=1,N - IF(STAVAR(J).GE.6) GO TO 840 - K=K+LENCOL(J) - 840 CONTINUE - WRITE(BUFFER,891) - 891 FORMAT(1X,'RDMPS: Reformulated LP problem statistics:') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,892) M - 892 FORMAT(8X,I9,' constraints in the LP problem;') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,893) N - 893 FORMAT(8X,I9,' variables in the LP problem,') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,894) NSTRCT - 894 FORMAT(8X,I9,' of which are structurals;') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,895) K - 895 FORMAT(8X,I9,' nonzero elts in matrix A.') - CALL MYWRT(IOERR,BUFFER) -C - 890 CONTINUE -C -C -C -C IF(ITRACE.GE.2) THEN -C -C WRITE(IOERR,*) -C WRITE(IOERR,*) 'RDMPS: MPS file has been read.' -C -C LP problem constraints. -C WRITE(IOERR,*) -C WRITE(IOERR,*) 'RWNAME' -C WRITE(IOERR,'(5(2X,A8))') (RWNAME(I),I=1,M) -C WRITE(IOERR,*) 'RWSTAT' -C WRITE(IOERR,'(5(2X,I8))') (RWSTAT(I),I=1,M) -C WRITE(IOERR,*) 'B' -C WRITE(IOERR,'(5(2X,D12.5))') (B(I),I=1,M) -C WRITE(IOERR,*) 'RANGES' -C WRITE(IOERR,'(5(2X,D12.5))') (RANGES(I),I=1,M) -C -C LP problem variables. -C WRITE(IOERR,*) -C WRITE(IOERR,*) 'CLNAME' -C WRITE(IOERR,'(5(2X,A8))') (CLNAME(J),J=1,N) -C WRITE(IOERR,*) 'STAVAR' -C WRITE(IOERR,'(5(2X,I8))') (STAVAR(J),J=1,N) -C WRITE(IOERR,*) 'C' -C WRITE(IOERR,'(5(2X,D12.5))') (C(J),J=1,N) -C WRITE(IOERR,*) 'UPBND' -C WRITE(IOERR,'(5(2X,D12.5))') (UPBND(J),J=1,N) -C WRITE(IOERR,333) 'LOBND' -C 333 FORMAT(1X,A8) -C WRITE(IOERR,'(5(2X,D12.5))') (LOBND(J),J=1,N) -C -C LP constraint matrix. -C WRITE(IOERR,*) -C WRITE(IOERR,*) 'RWHEAD' -C WRITE(IOERR,'(5(2X,I8))') (RWHEAD(I),I=1,M) -C WRITE(IOERR,*) 'CLPNTS' -C WRITE(IOERR,'(5(2X,I8))') (CLPNTS(J),J=1,N+1) -C WRITE(IOERR,*) 'LENCOL' -C WRITE(IOERR,'(5(2X,I8))') (LENCOL(J),J=1,N) -C WRITE(IOERR,*) -C DO 1010 K=1,NZA -C WRITE(IOERR,1011) K,ACOEFF(K),RWNMBS(K), -C X CLNMBS(K),RWLINK(K) -C1011 FORMAT(1X,'sub=',I8,' elt=',D12.5, -C X ' rw=',I8,' cl=',I8,' rwlnk=',I8) -C1010 CONTINUE -C -C LP constraint matrix by ROWS. -C WRITE(IOERR,*) -C WRITE(IOERR,*) 'ROWS of the LP constraint matrix' -C DO 1020 I=1,M -C CALL GETROW(I,RWORK,IWORK,RMAP,IMAP, -C X IROW,RELT,K,MAXN,IOERR) -C WRITE(IOERR,'(A4,I3,A2,I3,A4,10(1X,I4))') 'ROW ',I, -C X ' (',K,') : ',(IROW(J),J=1,K) -C1020 CONTINUE -C -C LP constraint matrix by COLUMNS. -C WRITE(IOERR,*) -C WRITE(IOERR,*) 'COLUMNS of the LP constraint matrix' -C DO 1030 J=1,N -C CALL GETCOL(J,RWORK,IWORK,RMAP,IMAP, -C X IROW,RELT,K,MAXN,IOERR) -C WRITE(IOERR,'(A4,I3,A2,I3,A4,10(1X,I4))') 'COL ',J, -C X ' (',K,') : ',(IROW(I),I=1,K) -C1030 CONTINUE -C WRITE(IOERR,*) -C -C ENDIF -C -C -C -C - RETURN -C -C -C -C -C -C Here when error occurs. - 9020 WRITE(BUFFER,9021) - 9021 FORMAT(1X,'RDMPS2 ERROR: Number of nonzeros', - X ' of matrix A exceeds MAXNZA.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9030 WRITE(BUFFER,9031) - 9031 FORMAT(1X,'RDMPS2 ERROR: Number of variables', - X ' in the MPS file exceeds MAXN.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9120 WRITE(BUFFER,9121) I,RWSTAT(I) - 9121 FORMAT(1X,'RDMPS2 ERROR: Constraint',I8,' has RWSTAT=',I8) - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9200 WRITE(BUFFER,9201) LOBND(J),UPBND(J),CLNAME(J) - 9201 FORMAT(1X,'RDMPS2: LO bound ',D12.6,' exceeds ', - X 'UP one ',D12.6,' (var=',A8,').') - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C -C -C -C -C *** LAST CARD OF (RDMPS2) *** - END //GO.SYSIN DD hopdm.src/rdmps2.f echo hopdm.src/rdrhs.f 1>&2 sed >hopdm.src/rdrhs.f <<'//GO.SYSIN DD hopdm.src/rdrhs.f' 's/^-//' -C******************************************************************** -C ******* RDRHS ... READ THE RHS SECTION OF THE MPS FILE ******* -C******************************************************************** -C - SUBROUTINE RDRHS(MAXM,M,LINE, - X HDRWCD,LNKRW,HDCLCD,LNKCL, - X NAMEB,RHS,RWNAME,SECT,INMPS,IOERR) -C -C -C -C *** PARAMETERS - INTEGER*4 MAXM,M,LINE,INMPS,IOERR - CHARACTER*8 NAMEB,RWNAME(MAXM) - INTEGER*2 HDRWCD(M+1),LNKRW(M+1) - INTEGER*2 HDCLCD(M+1),LNKCL(M+1) - DOUBLE PRECISION RHS(MAXM) - CHARACTER SECT -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 INDEX - DOUBLE PRECISION VAL1,VAL2 - CHARACTER*8 NAME0,NAMRW1,NAMRW2 - CHARACTER*100 BUFFER -C -C -C -C *** PARAMETERS DESCRIPTION -C ON INPUT: -C MAXM Maximum number of constraints. -C M Current number of constraints. -C LINE Current number of the line read from the MPS file. -C NAMEB The name of the right hand side section chosen. -C RWNAME Array of row names. -C HDRWCD Header to the linked list of rows with the same codes. -C LNKRW Linked list of rows with the same codes. -C HDCLCD Header to the linked list of columns with the same codes. -C LNKCL Linked list of columns with the same codes. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C INMPS Input/output unit number where the input MPS file -C is to be read from. -C ON OUTPUT: -C RHS The right hand side vector. -C SECT Indicator of the section that follows RHS one. -C -C -C -C *** SUBROUTINES CALLED -C LKINDX -C -C -C -C *** PURPOSE -C This routine reads the RHS section of the MPS file. -C (It can also be used to read the RANGES section). -C -C -C -C *** NOTES -C -C -C -C *** REFERENCES: -C Altman A., Gondzio J. (1993). An efficient implementation of -C a higher order primal-dual interior point method for large -C sparse linear programs, Archives of Control Sciences 2, -C No 1-2, pp. 23-40. -C Altman A., Gondzio J. (1993). HOPDM - A higher order primal- -C dual method for large scale linear programmming, European -C Journal of Operational Research 66 (1993) pp 158-160. -C Gondzio J., Tachat D. (1994). The design and application of -C IPMLO - a FORTRAN library for linear optimization with -C interior point methods, RAIRO Recherche Operationnelle 28, -C No 1, pp. 37-56. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: October 14, 1994 -C -C -C -C *** BODY OF (RDRHS) *** -C -C -C -C -C Main loop begins here. - 200 LINE=LINE+1 - INDEX=1 - READ(INMPS,201,ERR=9000) SECT,NAME0,NAMRW1,VAL1,NAMRW2,VAL2 - 201 FORMAT(A1,3X,A8,2X,A8,2X,D12.0,3X,A8,2X,D12.0) -C -C Check if the line belongs to the same section. - IF(SECT.NE.' ') GO TO 300 -C -C First record met defines default section name. - IF(NAMEB.EQ.' ') THEN - NAMEB=NAME0 - ENDIF - IF(NAME0.NE.NAMEB) GO TO 9000 -C -C -C Find the position of the nonzero element. -C 250 CALL LKINDX(RWNAME,M,NAMRW1,INDEX) - 250 CALL LKCODE(RWNAME,M,NAMRW1,INDEX,HDRWCD,LNKRW,IOERR) - IF(INDEX.EQ.0) GO TO 9010 -C -C Save the RHS coefficient. - RHS(INDEX)=VAL1 -C WRITE(BUFFER,251) INDEX,RWNAME(INDEX),VAL1 -C 251 FORMAT(1X,'RDRHS: rw=',I6,' rwname=',A8,' elt=',D14.6) -C CALL MYWRT(IOERR,BUFFER) -C -C Check if there is another nonzero read in the analysed line. - IF(NAMRW2.NE.' ') THEN - NAMRW1=NAMRW2 - VAL1=VAL2 - NAMRW2=' ' - GO TO 250 - ELSE - GO TO 200 - ENDIF -C -C -C - 300 CONTINUE - RETURN -C -C -C -C Here if an error occurs. - 9000 WRITE(BUFFER,9001) LINE - 9001 FORMAT(1X,'RDRHS ERROR: Unexpected characters found', - X ' at line',I10,' of the MPS file.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9010 WRITE(BUFFER,9011) LINE - 9011 FORMAT(1X,'RDRHS ERROR: Unknown row was found', - X ' at line',I10,' of the MPS file.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C -C -C *** LAST CARD OF (RDRHS) *** - END //GO.SYSIN DD hopdm.src/rdrhs.f echo hopdm.src/rdspec.f 1>&2 sed >hopdm.src/rdspec.f <<'//GO.SYSIN DD hopdm.src/rdspec.f' 's/^-//' -C********************************************************** -C **** RDSPEC ... READ THE SPECIFICATIONS FILE **** -C********************************************************** -C - SUBROUTINE RDSPEC(FILMPS,FILSPC,FILERR,FILSOL, - X MDIM,NDIM,NZDIM,MAXM,MAXN,MAXNZA, - X NAMEC,NAMEB,NAMBND,NAMRAN, - X MULT,BIG,DLOBND,DUPBND, - X IOERR,IOSPC,INMPS,OUTMPS) -C -C -C -C *** PARAMETERS - INTEGER MDIM,NDIM,NZDIM,MAXM,MAXN,MAXNZA - INTEGER IOERR,IOSPC,INMPS,OUTMPS - CHARACTER*13 FILMPS,FILSPC,FILERR,FILSOL - CHARACTER*9 NAMEC,NAMEB,NAMBND,NAMRAN - DOUBLE PRECISION MULT,BIG,DLOBND,DUPBND -C -C -C *** COMMON ARREAS -C Cholesky factorization parameters. - COMMON /CHFCT/ CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN,IDNSRW - DOUBLE PRECISION CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN - INTEGER*4 IDNSRW -C -C Optimality tolerance. - COMMON /OPTLTY/ OPTTOL - DOUBLE PRECISION OPTTOL -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,IKEY,LINE - CHARACTER*3 KEY(20,2),KEYWRD - CHARACTER*12 TEXT - CHARACTER*100 BUFFER -C -C -C *** PARAMETERS DESCRIPTION -C MDIM Maximum number of constraints (see also MAXM). -C NDIM Maximum number of variables (see also MAXN). -C NZDIM Maximum number of non-zeros in the LP constraint matrix -C (see also MAXNZA). -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C IOMPS Input/output unit number where the input MPS file -C is to be read from. -C IOSPC Input/output unit number where the problem -C specifications are to be read from. -C OUTMPS Input/output unit number where the solution MPS file -C is to be written. -C FILSPC Specifications file name. -C FILMPS MPS input file name. -C FILERR Error file name. -C FILSOL Solution ile name. -C NAMEC The name of the desired objective function. -C NAMEB The name of the right hand side section chosen. -C NAMBND The name of the bound section chosen. -C NAMRAN The name of the range section chosen. -C MULT Direction of optimization: -C +1 means minimization; -C -1 means maximization. -C BIG "Big" number. -C DLOBND Default LOWER bound. -C DUPBND Default UPPER bound. -C -C CSMALL During the Cholesky decomposition all numbers smaller -C than CSMALL (in the absolute value) are presumed -C to be numerical errors only and are set to zero. -C CSMALL is initialized to the computer relative precision. -C PIVTOL The tolerance for pivots in Cholesky factor L. -C Pivots smaller than PIVTOL are rejected and the matrix -C is presumed to be singular. The factorization is not -C terminated, however. Pivot element is replaced with -C a small positive value. -C TAU To avoid unpredicted exit from the Cholesky decomposition -C a small multiple of the identity matrix is added to the -C A*THETA*Atransp matrix before its factorization. -C It has a value equal to TAU times the largest diagonal -C element of the matrix to be decomposed. TAU is -C initialized to the value of computer relative precision. -C DENSE Threshold value for a column to be treated as dense. -C IDNSRW Index of row of the Cholesky factor for which a switch -C is made to dense code. -C OPTTOL Optimality tolerance. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: October 27, 1994 -C -C -C -C -C *** BODY OF (RDSPEC) *** -C -C -C -C -C Define keywords. - KEY(1,1)='ROW' - KEY(1,2)='row' - KEY(2,1)='COL' - KEY(2,2)='col' - KEY(3,1)='ELE' - KEY(3,2)='ele' - KEY(4,1)='NON' - KEY(4,2)='non' -C - KEY(5,1)='MAX' - KEY(5,2)='max' - KEY(6,1)='MIN' - KEY(6,2)='min' - KEY(7,1)='LOB' - KEY(7,2)='lob' - KEY(8,1)='UPB' - KEY(8,2)='upb' -C - KEY(9,1)='OBJ' - KEY(9,2)='obj' - KEY(10,1)='RHS' - KEY(10,2)='rhs' - KEY(11,1)='RAN' - KEY(11,2)='ran' - KEY(12,1)='BOU' - KEY(12,2)='bou' -C - KEY(13,1)='MPS' - KEY(13,2)='mps' - KEY(14,1)='SOL' - KEY(14,2)='sol' - KEY(15,1)='ERR' - KEY(15,2)='err' -C - KEY(16,1)=' ' - KEY(16,2)=' ' - KEY(17,1)=' ' - KEY(17,2)=' ' - KEY(18,1)='OPT' - KEY(18,2)='opt' -C - KEY(19,1)='BEG' - KEY(19,2)='beg' - KEY(20,1)='END' - KEY(20,2)='end' -C -C -C -C -C Set default file names. - FILMPS='mps' - FILERR='err' - FILSOL='sol' -C -C Set default problem dimensions. - MAXM=MDIM-1 - MAXN=NDIM-1 - MAXNZA=NZDIM-1 -C -C Set default MPS file parameters. - NAMEC(1:8)=' ' - NAMEB(1:8)=' ' - NAMRAN(1:8)=' ' - NAMBND(1:8)=' ' - MULT=1.0D0 -C -C Set default bounds. - BIG=1.0D+30 - DLOBND=0.0D0 - DUPBND=BIG -C -C Set tolerances used by the Cholesky decomposition. - CSMALL=2.3D-16 - TAU=2.3D-16 - DENSE=0.999D0 -C -C Set optimality tolerance. - OPTTOL=1.0D-8 -C -C -C -C Use these lines to directly specify specs file name. - FILSPC='spc' -C WRITE(BUFFER,91) -C 91 FORMAT(1X,'Give the name of the specs file: ') -C CALL MYWRT(0,BUFFER) -C READ(*,*) FILSPC -C -C -C Open the specifications file. - OPEN(IOSPC,FILE=FILSPC,STATUS='OLD',ERR=9000) -C -C -C -C -C Read the first line of the specs file. - LINE=0 - 100 LINE=LINE+1 - READ(IOSPC,101,ERR=9010) KEYWRD,TEXT - 101 FORMAT(A3,9X,A12) - IF(KEYWRD.EQ.KEY(19,1).OR.KEYWRD.EQ.KEY(19,2)) THEN - GO TO 200 - ELSE - WRITE(BUFFER,102) KEYWRD,LINE - 102 FORMAT(1X,'RDSPEC: Unexpected keyword ',A3,' at line',I4) - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(0,BUFFER) - GO TO 100 - ENDIF -C -C -C -C -C Main loop begins here. -C ---------------------- - 200 LINE=LINE+1 - READ(IOSPC,201,ERR=9010) KEYWRD,TEXT - 201 FORMAT(A3,9X,A12) -C -C Check if it is the end of the specs file. - IF(KEYWRD.EQ.KEY(20,1).OR.KEYWRD.EQ.KEY(20,2)) GO TO 3000 -C -C Determine the type of the specification read. - IKEY=0 - DO 300 I=1,18 - IF(KEYWRD.EQ.KEY(I,1).OR.KEYWRD.EQ.KEY(I,2)) THEN - IKEY=I - GO TO 400 - ENDIF - 300 CONTINUE -C - 400 IF(IKEY.EQ.0) THEN - WRITE(BUFFER,401) KEYWRD,LINE - 401 FORMAT(1X,'RDSPEC: Keyword ',A3,' (line',I4,') is ignored.') - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(0,BUFFER) - GO TO 200 - ENDIF -C -C Here if the keyword is identified. -C - IF(IKEY.GE.5) GO TO 1050 - IF(IKEY.EQ.1) THEN - READ(TEXT,1010,ERR=9020) MAXM - 1010 FORMAT(I12) - GO TO 2000 - ENDIF -C - IF(IKEY.EQ.2) THEN - READ(TEXT,1020,ERR=9020) MAXN - 1020 FORMAT(I12) - GO TO 2000 - ENDIF -C - IF(IKEY.EQ.3.OR.IKEY.EQ.4) THEN - READ(TEXT,1030,ERR=9020) MAXNZA - 1030 FORMAT(I12) - GO TO 2000 - ENDIF -C - 1050 IF(IKEY.GE.10) GO TO 1095 - IF(IKEY.EQ.5) THEN - MULT=-1.0 - GO TO 2000 - ENDIF -C - IF(IKEY.EQ.6) THEN - MULT=+1.0 - GO TO 2000 - ENDIF -C - IF(IKEY.EQ.7) THEN - READ(TEXT,1070,ERR=9020) DLOBND - 1070 FORMAT(D12.0) - GO TO 2000 - ENDIF -C - IF(IKEY.EQ.8) THEN - READ(TEXT,1080,ERR=9020) DUPBND - 1080 FORMAT(D12.0) - GO TO 2000 - ENDIF -C - IF(IKEY.EQ.9) THEN - READ(TEXT,1090,ERR=9020) NAMEC - 1090 FORMAT(A8) - GO TO 2000 - ENDIF -C - 1095 IF(IKEY.EQ.10) THEN - READ(TEXT,1100,ERR=9020) NAMEB - 1100 FORMAT(A8) - GO TO 2000 - ENDIF -C - IF(IKEY.EQ.11) THEN - READ(TEXT,1110,ERR=9020) NAMRAN - 1110 FORMAT(A8) - GO TO 2000 - ENDIF -C - IF(IKEY.EQ.12) THEN - READ(TEXT,1120,ERR=9020) NAMBND - 1120 FORMAT(A8) - GO TO 2000 - ENDIF -C - IF(IKEY.EQ.13) THEN - READ(TEXT,1130,ERR=9020) FILMPS - 1130 FORMAT(A12) - GO TO 2000 - ENDIF -C - IF(IKEY.EQ.14) THEN - READ(TEXT,1140,ERR=9020) FILSOL - 1140 FORMAT(A12) - GO TO 2000 - ENDIF -C - IF(IKEY.EQ.15) THEN - READ(TEXT,1150,ERR=9020) FILERR - 1150 FORMAT(A12) - GO TO 2000 - ENDIF -C - IF(IKEY.EQ.18) THEN - READ(TEXT,1180,ERR=9020) OPTTOL - 1180 FORMAT(D10.0) - GO TO 2000 - ENDIF -C -C -C -C -C -C End of main loop. -C ----------------- - 2000 CONTINUE - GO TO 200 -C -C -C -C -C Check if there are no error settings in the specifications. - 3000 CONTINUE -C - IF(MAXM.GT.MDIM) THEN - WRITE(BUFFER,3001) - 3001 FORMAT(1X,'RDSPEC ERROR: MAXM exceeds MDIM.') - CALL ERRWRT(IOERR,BUFFER) - STOP - ENDIF -C - IF(MAXN.GT.NDIM) THEN - WRITE(BUFFER,3002) - 3002 FORMAT(1X,'RDSPEC ERROR: MAXN exceeds NDIM.') - CALL ERRWRT(IOERR,BUFFER) - STOP - ENDIF -C - IF(MAXNZA.GT.NZDIM) THEN - WRITE(BUFFER,3003) - 3003 FORMAT(1X,'RDSPEC ERROR: MAXNZA exceeds NZDIM.') - CALL ERRWRT(IOERR,BUFFER) - STOP - ENDIF -C -C -C -C -C Close the specifications file. - CLOSE(IOSPC) - RETURN -C -C -C -C -C - 9000 WRITE(BUFFER,9001) FILSPC - 9001 FORMAT(1X,'RDSPEC: Cannot open file = ',A13, - X ', default settings are used!') - CALL ERRWRT(IOERR,BUFFER) - RETURN -C -C Here when error occurs. - 9010 WRITE(BUFFER,9011) LINE - 9011 FORMAT(1X,'RDSPEC: Error while reading line',I4, - X ' of the SPC file.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9020 WRITE(BUFFER,9021) LINE - 9021 FORMAT(1X,'RDSPEC: Wrong specification at line',I4, - X ' of the specs file.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C -C -C -C *** LAST CARD OF (RDSPEC) *** - END //GO.SYSIN DD hopdm.src/rdspec.f echo hopdm.src/read.me 1>&2 sed >hopdm.src/read.me <<'//GO.SYSIN DD hopdm.src/read.me' 's/^-//' -GENERAL INFORMATION - -This is a short information on the HOPDM library of routines for -solving large-scale linear programs with interior point methods. -HOPDM stands for Higher Order Primal-Dual Method. - - The code implements the Mehrotra's predictor-corrector variant -of the primal-dual logarithmic barrier (interior point) method. -To make it comparable with other implementations, current version -uses only second order trajectory approximation. All theoretical -references are included in a source files of the library. - - The simplest usage of the library is to apply it as a stand-alone -LP solver that reads LP data (in a widely accepted MPS format), -solves the problem and prints the output (in an MPS-like format). -This, in fact, reflects the structure of the main (HMAIN2.F) routine. -This routine calls the following routines of the library: - - RDSPEC read the problem specifications (several example SPECS - files are included eg, for the smallest Netlib problems: - AFIRO, ADLITTLE, ...) - - RDMPS1 read the MPS-formatted LP data. This routine only reads - the problem but it does nothing else to it. You can - replace it with any other (presumably faster) routine to - read different disc file or to directly generate LP data - structures in internal format of HOPDM. This internal - format is simplified (at this point) just to a collection - of sparse columns of matrix A, explicit LOWER and UPPER - bounds, explicit indication of the OBJECTIVE row and - the RHS vector). - - RDMPS2 transforms the LP data of the above mentioned format - to internal data structures used by the HOPDM library. - (Differently to the simplex method, interior point codes - require comfortable access to both rows and columns of A.) - Here slacks, surplus and artificials are added, FREE - variables are split, etc. - - PRESOL performs an advanced pre_solve analysis of the problem. - In particular, it - cleans the LP matrix: - - determines (and later tightens) bounds on shadow prices, - - eliminates dominated (and weakly dominated) variables, - - eliminates singleton rows, - - eliminates singleton columns (implied FREE variables), - - finds identical columns and aggregates them, - - finds hidden split FREE variables, - - eliminates redundant (dominated or forcing) constraints, - - tightens bounds on variables, - makes the LP matrix sparser: - - pivots out some nonzero entries of A, - makes the LP matrix better suited for Cholesky fact.: - - splits dense columns into shorter pieces. - You may comment out the call of PRESOL routine, but it - usually causes some loss (10-30%) of the HOPDM efficiency. - - PREPRO performs preprocessing for the Cholesky decomposition. - In particular, it: - - builds an adjacency structure of A*Atranspose matrix, - - finds an ordering that minimizes the number of nonzero - entries in a Cholesky factor, - - reorders rows of A (and all data associated to rows, - such as RANGES, RHS etc.) according to the permutation - resulting from the minimum degree ordering, - - prepares data structures for sparse Cholesky decomposition - (i.e. it does the symbolic factorization). - You MUST call this routine prior to calling PCPDM solver. - - SCALEA scales the LP constraint matrix. Simple geometric scaling - is repeated twice on the matrix A. RSCALE and CSCALE - vectors handle the resulting row and column scaling factors, - respectively. - You DO NOT HAVE TO call this routine, what is necessary, - however, is to initialize scaling factors (to ones). - Scaling in 95% of cases improves the numerical properties - of the problem to be solved so it is justified to call it. - - PCPDM (Predictor-Corrector Primal-Dual Method) - solves the LP problem. - - SCLROW, SCLCOL - unscale the LP problem. You DO NOT NEED TO call these - routines if you disabled scaling, but you HAVE TO call - them if scaling has earlier been done. (Otherwise, the - results are printed in an unreadable 'scaled' form). - - POSTSL performs post-solve analysis, i.e., it undoes all the - problem modifications that have been done in a PRESOL - routine. You HAVE TO call this routine if you earlier - called PRESOL. (Otherwise, the solution is printed in - a modified form, with e.g. bounds pushed and may not - be really readable). - - WRTSOL writes an MPS-like formatted solution. - - - Generally speaking, all routines of the HOPDM library are -well documented source files. To deeply understand some functions, -however, you may find it necessary to consult the appropriate -publications (their list is almost always supplied in a source -code of each routine). - - -RUNNING THE PROGRAM - - To run the program you need at least two files to be present -in a current directory: -MPS-formatted file with the LP problem data (default name 'mps') -SPECS file with basic information on a problem to be solved -(default name 'spc'). You are supplied with two smallest -LP problems from the Netlib collection: AFIRO and ADLITTLE -and the specs files for them. -The program ALWAYS reads specifications from the 'spc' file. -To run it on AFIRO problem you thus have to -- copy afiro.spc onto spc -- start the hopdm solver. - - The minimum 'spc' file has to contain at least the following -lines: -begin -mps file afiro.mps -error file afiro.err -solut file afiro.res -end - -It may additionally contain the limits of rows, columns and -nonzero entries, the direction of optimization: minimize or -maximize and names of sections in the MPS file if there are -more sections of the same type. Our specs file for AFIRO -looks like: - -begin -rows 30 -cols 60 -elements 120 -MPS FILE afiro.mps -ERROR FILE afiro.err -SOLUT FILE afiro.res -rhs name B -objective COST -opt tol 1.0d-8 -minimize -end - -although it would suffice to leave only: - -begin -mps file afiro.mps -error file afiro.err -solut file afiro.res -end - -as minimization (to 8 digits exact) is a default direction -of optimization. - - -FILES CREATED BY HOPDM - - - HOPDM creates two files associated to a given problem solved. -In the above example, these files will be: -'afiro.err' which contains all log information on the process - of solving the problem (and, eventually, error - information). -'afiro.res' solution of the problem in MPS-like format. - - You may change their names by appropriate specifications -in 'spc' file. - - Current version of the code writes relatively large output -to an '*.err' file as this output usually helps to understand -eventual difficulties if such occur in the optimization process. -You can skip some of it if you find it superfluous. - - In principle, HOPDM should be easy to port to any platform. -However, you may have some problems with the routines that -measure the elapsed time. If this is the case, please change -the call in MYTIME routine for the one that is appropriate in -your system (or add two C routines written by David Gay and -supplied in FTIME.c source file). - -The code benefits the presence of the following two routines: - -- MMD routine is Joseph Liu's implementation of the Multiple Minimum -Degree ordering. See: "The evolution of the minimum degree ordering -algorithm", SIAM Review 33 (89), 1, pp. 1-19. -NOTE: This routine can be used EXCLUSIVELY for research purposes. - -- GENQMD routine is an implementation of the Quotient tree Minimum -Degree ordering available from SPARSPAK (via Netlib). This routine -is based on the book "Computer Solution of Large Sparse Positive -Definite Systems" by George and Liu, Prentice Hall 1981. //GO.SYSIN DD hopdm.src/read.me echo hopdm.src/reorda.f 1>&2 sed >hopdm.src/reorda.f <<'//GO.SYSIN DD hopdm.src/reorda.f' 's/^-//' -C********************************************************** -C **** REORDA ... REORDERING ROWS OF A **** -C********************************************************** -C - SUBROUTINE REORDA(MAXM,MAXN,MAXNZA,M,N, - X CLPNTS,RWNMBS,RWHEAD,RWLINK,CLNMBS,LENCOL, - X PERM,INVP,TEMP1,TEMP2,DPWORK, - X RWNAME,STAROW,RWSTAT,RANGES,RHS,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXM,MAXN,MAXNZA,M,N,IOERR - INTEGER*4 TEMP1(MAXM),TEMP2(MAXM) - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM+1),RWLINK(MAXNZA) - CHARACTER*8 RWNAME(MAXM) - DOUBLE PRECISION RANGES(MAXM),RHS(MAXM),DPWORK(MAXM) -C -C *** The following arrays can be half-length integer. - INTEGER*2 PERM(MAXM),INVP(MAXM) - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) - INTEGER*2 STAROW(MAXM),RWSTAT(MAXM) -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,IDUMMY,IROW,K,SVROW - CHARACTER*8 SVNAME -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C N Number of columns of the LP constraint matrix. -C PERM Permutation resulting from the minimum degree ordering. -C INVP Inverse permutation. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C LENCOL Lengths of columns of matrix A. -C RWNAME Array of row names. -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C RWSTAT Array of row types (sort as before): -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 row type is objective or free. -C RANGES Array of constraint ranges. -C RHS LP right-hand-side. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C Reordered LP constraint matrix. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C RWNAME Array of row names. -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C RWSTAT Array of row types (sort as before): -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 row type is objective or free. -C RANGES Array of constraint ranges. -C -C WORK ARRAYS: -C TEMP1 Integer work array. -C TEMP2 Integer work array. -C DPWORK Double precision work array. -C -C -C *** SUBROUTINES CALLED: -C NONE -C -C -C *** PURPOSE: -C 1. This routine reorders the rows of the LP constraint -C matrix according to a given permutation (as e.g. the one -C resulting from the minimum degree ordering or the one -C that removes empty rows from A). -C 2. It also reorders RWNAME, STAROW, RWSTAT, RHS and RANGES arrays. -C -C -C *** NOTES: -C -C -C -C *** REFERENCES: -C Duff I.S., Erisman A.M., Reid J.K. (1989). Direct methods -C for sparse matrices, Clarendon Press, Oxford 1989, -C chapter 2. -C Gondzio J. (1991). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization (to appear). -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: October 26, 1992 -C -C -C -C *** BODY OF (REORDA) *** -C -C -C -C *** DEBUGGING -C WRITE(IOERR,51) -C 51 FORMAT(1X/1X,'REORDA: LP rows before reordering') -C DO 53 IROW=1,M -C WRITE(IOERR,52) IROW,RWNAME(IROW) -C 52 FORMAT(1X,'REORDA: row= ',I5,' name=',A8) -C 53 CONTINUE -C -C -C -C -C Save row headers in TEMP1 array. - DO 100 I=1,M - TEMP1(I)=RWHEAD(I) - 100 CONTINUE -C -C Reorder the rows of A. - DO 300 I=1,M - IROW=INVP(I) -C -C Row I of A becomes the row with index IROW. - RWHEAD(IROW)=TEMP1(I) -C -C Modify the whole ancient row I. - K=RWHEAD(IROW) - 200 IF(K.EQ.0) GO TO 300 - RWNMBS(K)=IROW - K=RWLINK(K) - GO TO 200 - 300 CONTINUE -C -C -C -C Reorder STAROW and RWSTAT arrays. - DO 400 I=1,M - TEMP1(I)=STAROW(I) - TEMP2(I)=RWSTAT(I) - 400 CONTINUE - DO 500 I=1,M - IROW=INVP(I) - STAROW(IROW)=TEMP1(I) - RWSTAT(IROW)=TEMP2(I) - 500 CONTINUE -C -C -C Reorder RWNAME array. -C An in-place ordering algorithm is implemented to avoid -C the need of using character work array. - DO 680 IDUMMY=1,M - I=IDUMMY - IROW=INVP(I) - IF(IROW.EQ.I) GO TO 640 - IF(IROW.LE.0) GO TO 680 -C -C Start the loop over the permutation chain. -C First, save the contents of IROW cell. - SVNAME=RWNAME(IROW) - SVROW=IROW -C -C Place the contents of cell I into its new position -C and mark row I as the one that has already been used. - 600 RWNAME(IROW)=RWNAME(I) - INVP(I)=-INVP(I) -C -C Loop over the permutation chain. - IROW=I - I=PERM(I) - IF(I.NE.SVROW) GO TO 600 -C -C End up the loop over the permutation chain. - RWNAME(IROW)=SVNAME - 640 INVP(I)=-INVP(I) - 680 CONTINUE -C -C -C Reorder RANGES array. -C Restore the positive sign of INVP array. - DO 700 I=1,M - INVP(I)=-INVP(I) - DPWORK(I)=RANGES(I) - 700 CONTINUE - DO 750 I=1,M - IROW=INVP(I) - RANGES(IROW)=DPWORK(I) - 750 CONTINUE -C -C -C Reorder RHS array. - DO 800 I=1,M - DPWORK(I)=RHS(I) - 800 CONTINUE - DO 850 I=1,M - IROW=INVP(I) - RHS(IROW)=DPWORK(I) - 850 CONTINUE -C -C -C -C *** DEBUGGING -C WRITE(IOERR,951) -C 951 FORMAT(1X/1X,'REORDA: LP rows after reordering') -C DO 953 IROW=1,M -C WRITE(IOERR,952) IROW,RWNAME(IROW) -C 952 FORMAT(1X,'REORDA: row= ',I5,' name=',A8) -C 953 CONTINUE -C -C - RETURN -C -C *** LAST CARD OF (REORDA) *** - END //GO.SYSIN DD hopdm.src/reorda.f echo hopdm.src/reordi.f 1>&2 sed >hopdm.src/reordi.f <<'//GO.SYSIN DD hopdm.src/reordi.f' 's/^-//' -C************************************************************* -C **** REORDI ... REORDER THE ELEMENTS OF A VECTOR *** -C************************************************************* -C - SUBROUTINE REORDI(MAXM,M, - X PERM,INVP,VECTOR,I2WORK,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXM,M,IOERR - INTEGER*2 PERM(MAXM),INVP(MAXM) - INTEGER*2 VECTOR(MAXM),I2WORK(MAXM) -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,IROW -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXM Maximum row dimension of the LP constraint matrix. -C M Number of rows of the LP constraint matrix. -C PERM Permutation resulting from the minimum degree ordering. -C INVP Inverse permutation. -C VECTOR Array to be permuted. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C VECTOR Array reordered according to a given permutation. -C -C WORK ARRAYS: -C I2WORK Integer work array. -C -C -C *** SUBROUTINES CALLED: -C NONE -C -C -C *** PURPOSE: -C This routine reorders the vector according to a given -C permutation. -C -C -C *** NOTES: -C -C -C -C *** REFERENCES: -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: January 13, 1993 -C -C -C -C *** BODY OF (REORDI) *** -C -C -C Reorder VECTOR array. - DO 100 I=1,M - I2WORK(I)=VECTOR(I) - 100 CONTINUE - DO 200 I=1,M - IROW=INVP(I) - VECTOR(IROW)=I2WORK(I) - 200 CONTINUE -C -C - RETURN -C -C *** LAST CARD OF (REORDI) *** - END //GO.SYSIN DD hopdm.src/reordi.f echo hopdm.src/reordv.f 1>&2 sed >hopdm.src/reordv.f <<'//GO.SYSIN DD hopdm.src/reordv.f' 's/^-//' -C************************************************************* -C **** REORDV ... REORDER THE ELEMENTS OF A VECTOR *** -C************************************************************* -C - SUBROUTINE REORDV(MAXM,M, - X PERM,INVP,VECTOR,DPWORK,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXM,M,IOERR - INTEGER*2 PERM(MAXM),INVP(MAXM) - DOUBLE PRECISION VECTOR(MAXM),DPWORK(MAXM) -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,IROW -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXM Maximum row dimension of the LP constraint matrix. -C M Number of rows of the LP constraint matrix. -C PERM Permutation resulting from the minimum degree ordering. -C INVP Inverse permutation. -C VECTOR Array to be permuted. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C VECTOR Array reordered according to a given permutation. -C -C WORK ARRAYS: -C DPWORK Double precision work array. -C -C -C *** SUBROUTINES CALLED: -C NONE -C -C -C *** PURPOSE: -C This routine reorders the vector according to a given -C permutation. -C -C -C *** NOTES: -C -C -C -C *** REFERENCES: -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: October 26, 1992 -C -C -C -C *** BODY OF (REORDV) *** -C -C -C Reorder VECTOR array. - DO 100 I=1,M - DPWORK(I)=VECTOR(I) - 100 CONTINUE - DO 200 I=1,M - IROW=INVP(I) - VECTOR(IROW)=DPWORK(I) - 200 CONTINUE -C -C - RETURN -C -C *** LAST CARD OF (REORDV) *** - END //GO.SYSIN DD hopdm.src/reordv.f echo hopdm.src/rrwsng.f 1>&2 sed >hopdm.src/rrwsng.f <<'//GO.SYSIN DD hopdm.src/rrwsng.f' 's/^-//' -C***************************************************************** -C *** RRWSNG ... ELIMINATE ROW SINGLETONS FROM MATRIX A *** -C***************************************************************** -C - SUBROUTINE RRWSNG(IOERR,MSGLEV, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X RWORK,IWORK,RMAP,IMAP,IROW,RELT,IMTMP1,IMTMP2, - X B,RANGES,LOBND,UPBND, - X ACOEFF,CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X P,Q,PRLVAR,STAVAR,RWSTAT,STAROW,RWNAME,CLNAME, - X MARKER,LENROW,HEADER,LINKFD,LINKBK) -C -C -C -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(*),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(*) -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real array that contains real LP problem data. -C IWORK Integer array that contains integer LP problem data. -C RMAP Map of RWORK array. -C IMAP Map of IWORK array. -C -C -C -C -C *** PARAMETERS - INTEGER*4 IOERR,MSGLEV,MAXM,MAXN,MAXNZA,M,N,NSTRCT - INTEGER*4 LNHIST,MXHIST - INTEGER*2 INHIST(MXHIST) - DOUBLE PRECISION DPHIST(MXHIST) - INTEGER*4 IROW(MAXN),IMTMP1(MAXM+1),IMTMP2(MAXM+1) - DOUBLE PRECISION RELT(MAXN) - DOUBLE PRECISION ACOEFF(MAXNZA),B(MAXM),RANGES(MAXM) - DOUBLE PRECISION LOBND(MAXN),UPBND(MAXN) - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM+1),RWLINK(MAXNZA) - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) - DOUBLE PRECISION P(MAXM),Q(MAXM),PRLVAR(MAXN) - CHARACTER*8 RWNAME(MAXM),CLNAME(MAXN) - INTEGER*2 STAVAR(MAXN),STAROW(MAXM),RWSTAT(MAXM) - INTEGER*2 LENROW(MAXM),MARKER(MAXM) - INTEGER*2 HEADER(MAXN),LINKFD(MAXM),LINKBK(MAXM) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,IKX,IR,IPOS,J,JCOL,K,KBEG,KEND,KOK,KOUT,KSTAT - INTEGER*4 NEQELM,NNEELM,MNEW,SNGLHD - DOUBLE PRECISION BIG,BIGNEW,SMALLA - DOUBLE PRECISION BL,BU,BNDJLO,BNDJUP,FSBTOL,X0 - CHARACTER*100 BUFFER -C -C -C -C -C *** PARAMETERS DESCRIPTION -C -C *** ON INPUT: -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C MSGLEV The level of PRE_SOLVE information desired: -C 0 only final problem dimensions are printed; -C 1 numbers of eliminated rows and columns are printed; -C 2 names of eliminated rows and columns are printed; -C 3 detailed DEBUGGING information is printed. -C MAXM Maximum number of constraints. -C MAXN Maximum number of variables. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of constraints. -C N Number of variables (total, i.e. including slacks, -C surplus and artificials). -C NSTRCT Number of structural variables (excluding slacks, -C surplus and artificials). -C LNHIST Length of the PRE_SOLVE history list. -C MXHIST Maximum number of entries in the PRE_SOLVE history list. -C INHIST Integer PRE_SOLVE history information. -C DPHIST Double precision PRE_SOLVE history information. -C ACOEFF Array of nonzero elements for each column. -C B Right hand side of the linear program. -C RANGES Array of constraint ranges. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C LENCOL Lengths of (sparse) columns of matrix A. -C LOBND Array of lower bounds. -C UPBND Array of upper bounds. Note that the upper bound -C is changed when the variable has a lower bound. -C P LOWER bounds on shadow prices (dual variables). -C Q UPPER bounds on shadow prices (dual variables). -C PRLVAR Primal variables of the linear program. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C RWSTAT Array of row types: -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 objective row; -C 5 other free row. -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C RWNAME Array of row names (increasing order sort). -C CLNAME Array of column names (unordered). -C -C *** ON OUTPUT: -C -C -C -C -C *** WORK ARRAYS: -C IROW and RELT are the arrays for temporary handling of rows -C and columns of the constraint matrix. They are primarily -C intended to handle sparse vectors (in packed form) -C but may also be used for storing dense ones. -C IMTMP1 Integer work array of size MAXM. -C IMTMP2 Integer work array of size MAXM -C MARKER Integer work array of size MAXM. -C LENROW Integer work array of size MAXM. -C HEADER Header of the doubly linked lists. -C LINKFD Forward linked lists. -C LINKBK Backward linked lists. -C -C -C -C *** LOCAL VARIABLES DESCRIPTION: -C -C -C -C *** PURPOSE -C This routine eliminates row singletons. -C Variable with an entry in a singleton EQUALITY row is FIXED. -C If a variable that has an entry in a singleton INEQUALITY -C row, then a new BOUND is defined for it. -C -C -C -C *** SUBROUTINES CALLED -C MYWRT,GETCOL,DABS,EMPTYR,REORDA,REORDV -C -C -C *** NOTES -C This routine is given direct access to the matrix A. -C It alters hidden data structures. -C -C -C -C *** REFERENCES: -C Gondzio J. (1994). Presolve analysis of linear programs prior -C to applying an interior point method, Technical Report -C No 1994.3, Department of Management Studies, University -C of Geneva, 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, -C February 1994, revised in December 1994. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: February 21, 1993 -C Last modified: March 31, 1995 -C -C -C -C -C *** BODY OF (RRWSNG) *** -C -C -C -C Initialize. - BIG=1.0D+30 - BIGNEW=1.0D+20 - FSBTOL=1.0D-8 - SMALLA=1.0D-8 -C - IF(MSGLEV.LE.3) GO TO 140 - DO 130 J=1,N - IF(STAVAR(J).LT.6) GO TO 130 - WRITE(BUFFER,131) J,LENCOL(J),STAVAR(J), - X LOBND(J),UPBND(J),PRLVAR(J) - 131 FORMAT(1X,'col=',I6,' ln=',I4,' st=',I6,' LO=',D10.3, - X ' UP=',D10.3,' X=',D10.3) - CALL MYWRT(IOERR,BUFFER) - 130 CONTINUE - 140 CONTINUE -C -C -C -C -C Compute row lengths and save them in LENROW array. -C Mark all rows as active in a search process. -C MARKER(i)=0 means the row has been eliminated. - DO 200 I=1,M - LENROW(I)=0 - MARKER(I)=1 - 200 CONTINUE -C -C Loop over all structural columns of A. -C Omit FIXED variables and aggregate split FREE variables. - DO 300 J=1,NSTRCT - KSTAT=STAVAR(J) - IF(KSTAT.GE.6) GO TO 300 - IF(KSTAT.LT.0) THEN - IF(J.GT.-KSTAT) GO TO 300 - ENDIF - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 250 K=KBEG,KEND - I=RWNMBS(K) - LENROW(I)=LENROW(I)+1 - 250 CONTINUE - 300 CONTINUE -C -C -C -C -C Prepare data structures used in a search for singleton rows. -C IMTMP1 array handles (dynamically changing) row lengths. -C IMTMP2 array handles linked list of singleton rows. -C Store equality-type rows at the beginning of the list. - SNGLHD=0 - DO 400 I=1,M - IMTMP1(I)=LENROW(I) - IF(LENROW(I).NE.1) GO TO 400 - IF(RWSTAT(I).EQ.1) GO TO 400 -C WRITE(BUFFER,401) I,RWNAME(I),RWSTAT(I) -C 401 FORMAT(1X,'RRWSNG: rw=',I6,' (name=',A8, -C X ') rwstat=',I3,' has len=1') -C CALL MYWRT(IOERR,BUFFER) - IMTMP2(I)=SNGLHD - SNGLHD=I - 400 CONTINUE - DO 500 I=1,M - IF(LENROW(I).NE.1) GO TO 500 - IF(RWSTAT(I).NE.1) GO TO 500 -C WRITE(BUFFER,501) I,RWNAME(I),RWSTAT(I) -C 501 FORMAT(1X,'RRWSNG: rw=',I6,' (name=',A8, -C X ') rwstat=',I3,' has len=1') -C CALL MYWRT(IOERR,BUFFER) - IMTMP2(I)=SNGLHD - SNGLHD=I - 500 CONTINUE -C -C -C -C -C -C -C -C Main loop begins here. -C Loop over all singleton rows. - NEQELM=0 - NNEELM=0 - 1000 CONTINUE - IF(SNGLHD.EQ.0) GO TO 2100 -C -C -C Pick up a singleton row. - I=SNGLHD - SNGLHD=IMTMP2(SNGLHD) - IF(IMTMP1(I).NE.1) GO TO 2000 - IF(MARKER(I).EQ.0) GO TO 2000 -C ********************* -C IPOS=RWHEAD(I) -C IF(RWSTAT(I).GE.2) IPOS=RWLINK(IPOS) -C KOK=0 -C 720 IF(IPOS.LE.0) GO TO 760 -C J=CLNMBS(IPOS) -C KSTAT=STAVAR(J) -C IF(KSTAT.GE.6) GO TO 740 -C IF(KSTAT.LT.0) THEN -C IF(J.GT.-KSTAT) GO TO 740 -C ENDIF -C KOK=KOK+1 -C WRITE(BUFFER,721) I,J,STAVAR(J) -C 721 FORMAT(1X,'rw=',I6,', pvt cand, cl=',I6,' st=',I3) -C CALL MYWRT(IOERR,BUFFER) -C 740 IPOS=RWLINK(IPOS) -C GO TO 720 -C 760 IF(KOK.NE.1) THEN -C WRITE(BUFFER,761) KOK -C 761 FORMAT(1X,'No of pivot candidates ',I8) -C CALL MYWRT(0,BUFFER) -C CALL MYWRT(IOERR,BUFFER) -C ENDIF -C ********************* -C -C Look for a pivot element in a row. - IPOS=RWHEAD(I) - IF(RWSTAT(I).GE.2) IPOS=RWLINK(IPOS) -C IF(RWSTAT(I).GE.2) THEN -C WRITE(BUFFER,1001) I,CLNMBS(IPOS) -C1001 FORMAT(1X,'Inequality row=',I6,', slack=',I6) -C CALL MYWRT(IOERR,BUFFER) -C IPOS=RWLINK(IPOS) -C ENDIF - 1020 IF(IPOS.LE.0) GO TO 1060 - J=CLNMBS(IPOS) - KSTAT=STAVAR(J) - IF(KSTAT.GE.6) GO TO 1040 - IF(KSTAT.LT.0) THEN - IF(J.GT.-KSTAT) GO TO 1040 - ENDIF -C WRITE(BUFFER,1021) I,J -C1021 FORMAT(1X,'Singleton rw=',I6,' has pivot in cl=',I6) -C CALL MYWRT(IOERR,BUFFER) - GO TO 1080 - 1040 IPOS=RWLINK(IPOS) - GO TO 1020 - 1060 WRITE(BUFFER,1061) I - 1061 FORMAT(1X,'RRWSNG: Row ',I8,' has no entries.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C Here when pivot element has been found. - 1080 KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - BNDJLO=0.0D0 - IF(KSTAT.LT.0) BNDJLO=-BIG - BNDJUP=BIG - IF(KSTAT.EQ.1.OR.KSTAT.EQ.3) BNDJUP=UPBND(J) - IF(MSGLEV.LE.1) GO TO 1085 - WRITE(BUFFER,1081) J,STAVAR(J),BNDJLO,BNDJUP - 1081 FORMAT(1X,'pvt, col=',I6,' st=',I7,' Lj=',D10.3,' Uj=',D10.3) - CALL MYWRT(IOERR,BUFFER) - IF(RANGES(I).LE.BIGNEW) THEN - WRITE(BUFFER,1082) I,RWNAME(I),RWSTAT(I),RANGES(I) - 1082 FORMAT(1X,' rw=',I6,' nm=',A8,' rwst=',I2,' range=',D10.3) - CALL MYWRT(IOERR,BUFFER) - ENDIF - 1085 CONTINUE -C -C -C - IF(RWSTAT(I).EQ.1) THEN -C -C Here for EQUALITY type constraint. -C Check if the eliminated variable is feasible. - X0=B(I)/ACOEFF(IPOS) - IF(KSTAT.LT.0) GO TO 1800 - IF(X0.LE.-FSBTOL) GO TO 9010 - IF(X0.GE.BNDJUP+FSBTOL) GO TO 9010 -C -C Fix variable J on X0. - GO TO 1800 -C - ENDIF -C -C -C - IF(RWSTAT(I).EQ.2) THEN -C -C Here for GREATER OR EQUAL type constraint. - IF(ACOEFF(IPOS).LE.0.0D0) THEN - BU=B(I)/ACOEFF(IPOS) - BL=-BIG - IF(RANGES(I).LE.BIGNEW) THEN - BL=(B(I)+RANGES(I))/ACOEFF(IPOS) - GO TO 1200 - ENDIF - GO TO 1400 - ELSE - BL=B(I)/ACOEFF(IPOS) - BU=BIG - IF(RANGES(I).LE.BIGNEW) THEN - BU=(B(I)+RANGES(I))/ACOEFF(IPOS) - ENDIF - GO TO 1200 - ENDIF -C - ENDIF -C -C -C - IF(RWSTAT(I).EQ.3) THEN -C -C Here for LESS OR EQUAL type constraint. - IF(ACOEFF(IPOS).GE.0.0D0) THEN - BU=B(I)/ACOEFF(IPOS) - BL=-BIG - IF(RANGES(I).LE.BIGNEW) THEN - BL=(B(I)-RANGES(I))/ACOEFF(IPOS) - GO TO 1200 - ENDIF - GO TO 1400 - ELSE - BL=B(I)/ACOEFF(IPOS) - BU=BIG - IF(RANGES(I).LE.BIGNEW) THEN - BU=(B(I)-RANGES(I))/ACOEFF(IPOS) - ENDIF - GO TO 1200 - ENDIF -C - ENDIF -C - GO TO 2000 -C -C -C -C Here if the new LOWER bound has been defined. - 1200 CONTINUE - IF(MSGLEV.LE.1) GO TO 1202 - WRITE(BUFFER,1201) J,CLNAME(J),BL - 1201 FORMAT(1X,'RRWSNG: Variable ',I6,' (name=',A8, - X ') has new LOWER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 1202 CONTINUE -C IF(KSTAT.LT.0) THEN -C WRITE(BUFFER,1203) J -C1203 FORMAT(1X,'RRWSNG: LO bnd on a FREE variable ',I6) -C CALL MYWRT(IOERR,BUFFER) -C ENDIF -C -C Check if it is tighter then the old LOWER bound. -C If so, then update the bound. - 1220 IF(BL.LE.BNDJLO+FSBTOL) GO TO 1400 - DO 1240 K=KBEG,KEND - IR=RWNMBS(K) - IF(MARKER(IR).EQ.0) GO TO 1240 - B(IR)=B(IR)-BL*ACOEFF(K) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - 1240 CONTINUE - STAVAR(J)=2 - LOBND(J)=LOBND(J)+BL -C -C Save the new LOWER bound in a PRE_SOLVE history list. - IF(LNHIST.GE.MXHIST) GO TO 9200 - LNHIST=LNHIST+1 - INHIST(LNHIST)=-J - DPHIST(LNHIST)=BL -C -C Catch up bound on a FREE variable (FIX its split brother). - IF(KSTAT.LT.0) THEN - JCOL=-KSTAT - X0=0.0D0 - IF(MSGLEV.LE.1) GO TO 1243 - WRITE(BUFFER,1241) JCOL,CLNAME(JCOL),X0 - 1241 FORMAT(1X,'RRWSNG: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,1242) - 1242 FORMAT(1X,'RRWSNG: FREE variable eliminated !!! ') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - 1243 CONTINUE - PRLVAR(JCOL)=X0 - STAVAR(JCOL)=6 - ENDIF -C - IF(BNDJUP.LE.BIGNEW) STAVAR(J)=3 - IF(BL.GE.BNDJUP+FSBTOL) GO TO 9210 - UPBND(J)=UPBND(J)-BL - IF(BL.LE.BNDJUP-FSBTOL) THEN - BU=BU-BL - BNDJUP=BNDJUP-BL - GO TO 1400 - ENDIF - X0=0.0D0 - GO TO 1800 -C -C -C -C Here if the new UPPER bound has been defined. - 1400 IF(BU.GE.BIGNEW) GO TO 1960 - IF(MSGLEV.LE.1) GO TO 1402 - WRITE(BUFFER,1401) J,CLNAME(J),BU - 1401 FORMAT(1X,'RRWSNG: Variable ',I6,' (name=',A8, - X ') has new UPPER bound=',D14.6) - CALL MYWRT(IOERR,BUFFER) - 1402 CONTINUE - IF(KSTAT.LT.0) THEN -C WRITE(BUFFER,1403) J -C1403 FORMAT(1X,'RRWSNG: UP bnd on a FREE variable ',I6) -C CALL MYWRT(IOERR,BUFFER) -C -C UP bnd on x1 can be handled as LO bnd on x2. - J=-KSTAT - KSTAT=STAVAR(J) - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - BL=-BU - GO TO 1220 - ENDIF -C -C Check if it is tighter then the old UPPER bound. -C If so, then update the bound. - IF(BU.GE.BNDJUP-FSBTOL) GO TO 1960 - IF(BU.LE.BNDJLO-FSBTOL) GO TO 9220 - UPBND(J)=BU - STAVAR(J)=3 - IF(BU.GE.FSBTOL) GO TO 1960 - X0=0.0D0 -C -C -C -C Fix variable J on X0 and eliminate it. -C Update row lengths and the linked list of singleton rows. - 1800 CONTINUE - IF(MSGLEV.LE.1) GO TO 1803 - WRITE(BUFFER,1801) J,CLNAME(J),X0 - 1801 FORMAT(1X,'RRWSNG: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,1802) I,RWNAME(I) - 1802 FORMAT(1X,'RRWSNG: Row ',I6,' (name=',A8, - X ') is eliminated.') - CALL MYWRT(IOERR,BUFFER) - 1803 CONTINUE -C - PRLVAR(J)=X0 - STAVAR(J)=6 - DO 1840 K=KBEG,KEND - IR=RWNMBS(K) -C IF(MARKER(IR).EQ.0) GO TO 1840 - B(IR)=B(IR)-X0*ACOEFF(K) - IF(DABS(B(IR)).LE.SMALLA) B(IR)=0.0D0 - IMTMP1(IR)=IMTMP1(IR)-1 - IF(IMTMP1(IR).EQ.1) THEN - IMTMP2(IR)=SNGLHD - SNGLHD=IR - ENDIF - IF(IR.EQ.I) GO TO 1840 -C -C Check if an empty row has not been created. - IF(IMTMP1(IR).EQ.0) THEN - KOK=RWHEAD(IR) -C WRITE(BUFFER,1805) I,IR,KOK -C1805 FORMAT(1X,'1805 row=',I6,', empty rw=',I6,' KOK=',I6) -C CALL MYWRT(IOERR,BUFFER) - IF(KOK.LE.0) GO TO 1840 - IF(RWSTAT(IR).EQ.1) THEN - NEQELM=NEQELM+1 - ELSE - NNEELM=NNEELM+1 - JCOL=CLNMBS(KOK) - PRLVAR(JCOL)=0.0D0 - STAVAR(JCOL)=14 - ENDIF - IF(MSGLEV.LE.1) GO TO 1842 - WRITE(BUFFER,1841) IR,RWNAME(IR) - 1841 FORMAT(1X,'RRWSNG: Row ',I6,' (name=',A8, - X ') is eliminated.') - CALL MYWRT(IOERR,BUFFER) - 1842 CONTINUE - RWHEAD(IR)=-RWHEAD(IR) - MARKER(IR)=0 - ENDIF - 1840 CONTINUE -C -C -C Check if the eliminated variable is a FREE one. -C If so, then FIX its split brother on a LOWER bound. - IF(KSTAT.LT.0) THEN - JCOL=-KSTAT - X0=0.0D0 - IF(MSGLEV.LE.1) GO TO 1903 - WRITE(BUFFER,1901) JCOL,CLNAME(JCOL),X0 - 1901 FORMAT(1X,'RRWSNG: Variable ',I6,' (name=',A8, - X ') is being FIXED on X=',D14.6) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,1902) - 1902 FORMAT(1X,'RRWSNG: FREE variable eliminated !!! ') - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - 1903 CONTINUE - PRLVAR(JCOL)=X0 - STAVAR(JCOL)=6 - ENDIF -C -C -C Eliminate row I. - 1960 K=RWHEAD(I) - IF(RWSTAT(I).EQ.1) THEN - NEQELM=NEQELM+1 - ELSE - NNEELM=NNEELM+1 - JCOL=CLNMBS(K) - PRLVAR(JCOL)=0.0D0 - STAVAR(JCOL)=14 - ENDIF - RWHEAD(I)=-RWHEAD(I) - MARKER(I)=0 -C -C -C -C -C -C -C -C End of main loop. - 2000 GO TO 1000 - 2100 CONTINUE -C -C -C -C -C -C -C Here if a successful run of the loop has been completed. - IF(MSGLEV.LE.0) GO TO 5010 - WRITE(BUFFER,5001) NEQELM - 5001 FORMAT(1X,'RRWSNG: Equalities eliminated: ',I9) -C CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,5002) NNEELM - 5002 FORMAT(1X,' Inequalities eliminated:',I9) -C CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) - 5010 CONTINUE -C -C -C -C -C -C -C Determine the permutation that puts all empty and inactive -C rows at the end of the list. -C - IR=3 - IF(MSGLEV.LE.1) IR=4 - CALL EMPTYR(MAXM,M,MNEW,IR, - X RWHEAD,STAROW,LENROW,MARKER,IOERR) -C -C -C Reorder the rows of the LP constraint matrix according to -C the permutation resulting from the analysis of EMPTYR. - IF(MNEW.LT.M) THEN -C - CALL REORDA(MAXM,MAXN,MAXNZA,M,N, - X CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL, - X LENROW,MARKER,IMTMP1,IROW,RELT, - X RWNAME,STAROW,RWSTAT,RANGES,B,IOERR) -C -C Reorder bounds on shadow prices P and Q. - CALL REORDV(MAXM,M, - X LENROW,MARKER,P,RELT,IOERR) - CALL REORDV(MAXM,M, - X LENROW,MARKER,Q,RELT,IOERR) -C -C Reorder elements within each column of the LP constraint -C matrix in such a way that those of the active part of A -C are at the beginning of the lists. The column lengths will -C later be decreased to forget inactive part of matrix A. -C Set the new row linked lists of nonzero elements of matrix A. -C Recall that CLPNTS(j) indicates the first entry of column j. -C Zero RWHEAD and LENROW arrays. - DO 5200 I=1,M - RWHEAD(I)=0 - LENROW(I)=0 - 5200 CONTINUE -C -C Reorder nonzero elements within each column. - DO 5500 J=1,N - IF(STAVAR(J).GE.6) GO TO 5500 - KBEG=CLPNTS(J)-1 - KOK=0 - KOUT=0 -C - DO 5300 IKX=1,LENCOL(J) - K=KBEG+IKX - I=RWNMBS(K) - IF(I.LE.MNEW) THEN - KOK=KOK+1 - IROW(KOK)=RWNMBS(K) - RELT(KOK)=ACOEFF(K) - ELSE - IPOS=LENCOL(J)-KOUT - KOUT=KOUT+1 - IROW(IPOS)=RWNMBS(K) - RELT(IPOS)=ACOEFF(K) - ENDIF - 5300 CONTINUE -C -C Set the row linked lists. -C Count nonzero elements in all rows of A. - DO 5400 IKX=1,LENCOL(J) - K=KBEG+IKX - I=IROW(IKX) - RWNMBS(K)=I - ACOEFF(K)=RELT(IKX) - RWLINK(K)=RWHEAD(I) - RWHEAD(I)=K - LENROW(I)=LENROW(I)+1 - 5400 CONTINUE - LENCOL(J)=KOK - 5500 CONTINUE -C -C Set the new number of rows of the constraint matrix. - M=MNEW -C - ENDIF -C -C -C -C -C Check if there are inequality type rows to be eliminated. -C Check if the eliminated rows were not violated. - DO 5800 I=1,M - IF(DABS(B(I)).LE.FSBTOL) B(I)=0.0D0 - K=RWHEAD(I) - IF(RWSTAT(I).EQ.1) THEN -C -C Here for EQUALITY constraint. - IF(K.NE.0) GO TO 5800 - IF(DABS(B(I)).GT.FSBTOL) GO TO 9020 - GO TO 5800 - ENDIF - KOK=RWLINK(K) - IF(KOK.GT.0) GO TO 5800 - IF(RWSTAT(I).EQ.2) THEN -C -C Here for GREATER OR EQUAL type constraint. - IF(B(I).GT.FSBTOL) GO TO 9020 - RWHEAD(I)=-RWHEAD(I) - J=CLNMBS(K) - STAVAR(J)=14 - GO TO 5800 - ENDIF - IF(RWSTAT(I).EQ.3) THEN -C -C Here for LESS OR EQUAL type constraint. - IF(B(I).LT.-FSBTOL) GO TO 9020 - RWHEAD(I)=-RWHEAD(I) - J=CLNMBS(K) - STAVAR(J)=14 - GO TO 5800 - ENDIF - 5800 CONTINUE -C -C -C -C -C -C - RETURN -C -C -C -C Here if an error occurs. - 9010 WRITE(BUFFER,9011) J,CLNAME(J),X0 - 9011 FORMAT(1X,'RRWSNG: Var. ',I6,' (name=',A8, - X ') is beyond its bounds, X=',D12.6) - CALL ERRWRT(IOERR,BUFFER) -C WRITE(BUFFER,9013) I,B(I),ACOEFF(IPOS) -C9013 FORMAT(1X,'RRWSNG: rw=',I6,' Bi=', D10.3,' elt=',D10.3) -C CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9012) - 9012 FORMAT(1X,'RRWSNG: Problem is infeasible.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9020 WRITE(BUFFER,9021) I,RWNAME(I),B(I) - 9021 FORMAT(1X,'RRWSNG: Constraint ',I6,' (name=',A8, - X ') is violated, B=',D12.6) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9022) - 9022 FORMAT(1X,'RRWSNG: Problem is infeasible.') - CALL ERRWRT(IOERR,BUFFER) -C WRITE(BUFFER,9023) I,RWSTAT(I),RWHEAD(I),LENROW(I) -C9023 FORMAT(1X,'RRWSNG: Constraint ',I6,' rwstat=',I6, -C X ' rwhead=',I8,' length=',I6) -C CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9200 WRITE(BUFFER,9201) - 9201 FORMAT(1X,'RRWSNG: Please increase space for PRE_SOLVE ', - X 'history list.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9210 WRITE(BUFFER,9211) BL,BNDJUP,CLNAME(J) - 9211 FORMAT(1X,'RRWSNG: LO bound ',D12.6,' exceeds ', - X 'UP one ',D12.6,' (var=',A8,').') - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9212) - 9212 FORMAT(1X,'RRWSNG: Problem is infeasible.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 9220 WRITE(BUFFER,9221) BNDJLO,BU,CLNAME(J) - 9221 FORMAT(1X,'RRWSNG: LO bound ',D12.6,' exceeds ', - X 'UP one ',D12.6,' (var=',A8,').') - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9222) - 9222 FORMAT(1X,'RRWSNG: Problem is infeasible.') - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C -C -C *** LAST CARD OF (RRWSNG) *** - END //GO.SYSIN DD hopdm.src/rrwsng.f echo hopdm.src/run 1>&2 sed >hopdm.src/run <<'//GO.SYSIN DD hopdm.src/run' 's/^-//' -unzip ../netlib/$1 -mv $1 $1.mps -unzip ../netlib/specs $1.spc -mv $1.spc spc -hopdm -rm $1.mps -rm $1.ccc -rm $1.res -rm spc -mv fort.99 $1.sum //GO.SYSIN DD hopdm.src/run echo hopdm.src/runall 1>&2 sed >hopdm.src/runall <<'//GO.SYSIN DD hopdm.src/runall' 's/^-//' -run 25fv47 -run 80bau3b -run adlittle -run afiro -run agg -run agg2 -run agg3 -run bandm -run beaconfd -run blend -run bnl1 -run bnl2 -run boeing1 -run boeing2 -run bore3d -run brandy -run capri -run cycle -run czprob -run d2q06c -run d6cube -run degen2 -run degen3 -run dfl001 -run e226 -run etamacro -run fffff800 -run finnis -run fit1d -run fit1p -run fit2d -run fit2p -run forplan -run ganges -run gfrd-pnc -run greenbea -run greenbeb -run grow15 -run grow22 -run grow7 -run israel -run kb2 -run lotfi -run maros -run maros-r7 -run modszk1 -run nesm -run perold -run pilot -run pilot4 -run pilot87 -run pilot_ja -run pilot_we -run pilotnov -run recipe -run sc105 -run sc205 -run sc50a -run sc50b -run scagr25 -run scagr7 -run scfxm1 -run scfxm2 -run scfxm3 -run scorpion -run scrs8 -run scsd1 -run scsd6 -run scsd8 -run sctap1 -run sctap2 -run sctap3 -run seba -run share1b -run share2b -run shell -run ship04l -run ship04s -run ship08l -run ship08s -run ship12l -run ship12s -run sierra -run stair -run standata -run standgub -run standmps -run stocfor1 -run stocfor2 -run stocfor3 -run truss -run tuff -run vtp_base -run wood1p -run woodw -run CH -run GE -run NL -run BL -run BL2 -run UK -run CQ5 -run CQ9 -run CO5 -run CO9 -wrun fort45 -wrun fort46 -wrun fort47 -wrun fort48 -wrun fort49 -wrun fort51 -wrun fort52 -wrun fort53 -wrun fort54 -wrun fort55 -wrun fort56 -wrun fort57 -wrun fort58 -wrun fort59 -wrun fort60 -wrun fort61 -wrun a1 -wrun a2 -wrun x1 -wrun x2 -run vschna02 -run vschnb01 -run vschnb02 -run pata01 -run pata02 -run patb01 -run patb02 -run willett -run pc001 -run pc002 -run2 ex01 -run2 ex02 -run2 ex05 -run2 ex06 -run2 ex09 -run cre-a -run cre-c -run osa-07 -run ken-07 -run ken-11 -run pds-02 -run world2 //GO.SYSIN DD hopdm.src/runall echo hopdm.src/rungay 1>&2 sed >hopdm.src/rungay <<'//GO.SYSIN DD hopdm.src/rungay' 's/^-//' -run 25fv47 -run 80bau3b -run adlittle -run afiro -run agg -run agg2 -run agg3 -run bandm -run beaconfd -run blend -run bnl1 -run bnl2 -run boeing1 -run boeing2 -run bore3d -run brandy -run capri -run cycle -run czprob -run d2q06c -run d6cube -run degen2 -run degen3 -run dfl001 -run e226 -run etamacro -run fffff800 -run finnis -run fit1d -run fit1p -run fit2d -run fit2p -run forplan -run ganges -run gfrd-pnc -run greenbea -run greenbeb -run grow15 -run grow22 -run grow7 -run israel -run kb2 -run lotfi -run maros -run maros-r7 -run modszk1 -run nesm -run perold -run pilot -run pilot4 -run pilot87 -run pilot_ja -run pilot_we -run pilotnov -run recipe -run sc105 -run sc205 -run sc50a -run sc50b -run scagr25 -run scagr7 -run scfxm1 -run scfxm2 -run scfxm3 -run scorpion -run scrs8 -run scsd1 -run scsd6 -run scsd8 -run sctap1 -run sctap2 -run sctap3 -run seba -run share1b -run share2b -run shell -run ship04l -run ship04s -run ship08l -run ship08s -run ship12l -run ship12s -run sierra -run stair -run standata -run standgub -run standmps -run stocfor1 -run stocfor2 -run stocfor3 -run truss -run tuff -run vtp_base -run wood1p -run woodw //GO.SYSIN DD hopdm.src/rungay echo hopdm.src/saty.f 1>&2 sed >hopdm.src/saty.f <<'//GO.SYSIN DD hopdm.src/saty.f' 's/^-//' -C**************************************************** -C **** SATY ... (sparse)Atransp * (dense)Y **** -C**************************************************** -C - SUBROUTINE SATY(RWORK,IWORK,RMAP,IMAP,Y,M,X,N, - X IROW,RELT,MAXN,IOERR) -C -C *** PARAMETERS - INTEGER*4 MAXN,M,N,IOERR - INTEGER*4 IROW(MAXN) - DOUBLE PRECISION X(N),Y(M),RELT(MAXN) -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(*),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(*) -C -C *** LOCAL VARIABLES - INTEGER*4 I,J,KNZ -C -C -C -C *** PURPOSE -C This routine computes the product of a sparse matrix Atransp -C and a dense vector Y and saves the result in a dense vector X. -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXN Maximum column dimension of the LP constraint matrix. -C M Number of rows of the LP constraint matrix. -C N Number of columns of the LP constraint matrix. -C IROW and RELT are the arrays for temporary handling -C of rows/columns of the constraint matrix. They -C are primarily intended to handle sparse vectors -C (in packed form) but may also be used for storing -C dense ones. -C Y Dense vector of dimension M. -C -C ON OUTPUT: -C X Dense vector of dimension N (X = Atransp * Y). -C -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real work array containing almost all real -C LP problem data. -C IWORK Integer work array containing almost all integer -C LP problem data. -C RMAP Map of RWORK. -C IMAP Map of IWORK. -C -C -C -C *** SUBROUTINES CALLED: -C GETROW,SAXPY -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C -C and Dominique Tachat, LAMSADE, -C University of Paris Dauphine, -C Place du Marechal de Lattre de Tassigny, -C 75775 Paris Cedex 16, France. -C -C Last modified: May 4, 1992 -C -C -C -C -C *** BODY OF (SATY) *** -C - DO 100 J=1,N - X(J)=0.0 - 100 CONTINUE - DO 200 I=1,M - CALL GETROW(I,RWORK,IWORK,RMAP,IMAP, - X IROW,RELT,KNZ,MAXN,IOERR) - IF(KNZ.EQ.0) GO TO 200 - CALL SAXPY(IROW,RELT,KNZ,X,Y(I)) - 200 CONTINUE - RETURN -C -C *** LAST CARD OF (SATY) *** - END //GO.SYSIN DD hopdm.src/saty.f echo hopdm.src/sax.f 1>&2 sed >hopdm.src/sax.f <<'//GO.SYSIN DD hopdm.src/sax.f' 's/^-//' -C********************************************** -C **** SAX ... (sparse)A * (dense)X **** -C********************************************** -C - SUBROUTINE SAX(RWORK,IWORK,RMAP,IMAP,STAVAR,X,N,Y,M, - X IROW,RELT,MAXN,IOERR) -C -C *** PARAMETERS - INTEGER*4 MAXN,M,N,IOERR - INTEGER*2 STAVAR(MAXN) - INTEGER*4 IROW(MAXN) - DOUBLE PRECISION X(N),Y(M),RELT(MAXN) -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(*),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(*) -C -C *** LOCAL VARIABLES - INTEGER*4 I,J,KNZ -C -C -C -C *** PURPOSE -C This routine computes the product of a sparse matrix A and -C a dense vector X and saves the result in a dense vector Y. -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXN Maximum column dimension of the LP constraint matrix. -C M Number of rows of the LP constraint matrix. -C N Number of columns of the LP constraint matrix. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C 7 PRESUMED OPTIMAL variable i.e.: x = x0; -C -k free variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicate the position of the original variable. -C IROW and RELT are the arrays for temporary handling -C of rows/columns of the constraint matrix. They -C are primarily intended to handle sparse vectors -C (in packed form) but may also be used for storing -C dense ones. -C X Dense vector of dimension N. -C -C ON OUTPUT: -C Y Dense vector of dimension M (Y = A * X). -C -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real work array containing almost all real -C LP problem data. -C IWORK Integer work array containing almost all integer -C LP problem data. -C RMAP Map of RWORK. -C IMAP Map of IWORK. -C -C -C -C *** SUBROUTINES CALLED: -C GETCOL,SAXPY -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C -C and Dominique Tachat, LAMSADE, -C University of Paris Dauphine, -C Place du Marechal de Lattre de Tassigny, -C 75775 Paris Cedex 16, France. -C -C Last modified: May 5, 1992 -C -C -C -C -C *** BODY OF (SAX) *** -C - DO 100 I=1,M - Y(I)=0. - 100 CONTINUE - DO 200 J=1,N - IF(STAVAR(J).GE.6) GO TO 200 - CALL GETCOL(J,RWORK,IWORK,RMAP,IMAP, - X IROW,RELT,KNZ,MAXN,IOERR) - IF(KNZ.EQ.0) GO TO 200 - CALL SAXPY(IROW,RELT,KNZ,Y,X(J)) - 200 CONTINUE - RETURN -C -C *** LAST CARD OF (SAX) *** - END //GO.SYSIN DD hopdm.src/sax.f echo hopdm.src/saxpy.f 1>&2 sed >hopdm.src/saxpy.f <<'//GO.SYSIN DD hopdm.src/saxpy.f' 's/^-//' -C****************************************************************** -C **** SAXPY ... (dense)Y = ALPHA * (sparse)X + (dense)Y **** -C****************************************************************** -C - SUBROUTINE SAXPY(IROW,RELT,KNZ,Y,ALPHA) -C -C *** PARAMETERS - INTEGER*4 KNZ,IROW(KNZ) - DOUBLE PRECISION Y(*),RELT(KNZ),ALPHA -C -C *** LOCAL VARIABLES - INTEGER*4 I,IKX -C -C *** PURPOSE -C This routine computes the following sum: -C (dense)Y = ALPHA * (sparse)X + (dense)Y -C Sparse vector X is packed in IROW and RELT arrays. -C -C -C *** PARAMETERS DESCRIPTION -C ON INPUT: -C Y Dense vector. -C IROW Row numbers of nonzeros in a sparse vector X. -C RELT Nonzero entries a sparse vector X. -C KNZ Number of nonzero entries in vector X. -C ALPHA Scalar used to multiply sparse vector X. -C ON OUTPUT: -C Y Dense vector (result of the addition). -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C -C and Dominique Tachat, LAMSADE, -C University of Paris Dauphine, -C Place du Marechal de Lattre de Tassigny, -C 75775 Paris Cedex 16, France. -C -C Last modified: March 21, 1992 -C -C -C -C -C *** BODY OF (SAXPY) *** -C - DO 100 I=1,KNZ - IKX=IROW(I) - Y(IKX)=Y(IKX)+ALPHA*RELT(I) - 100 CONTINUE - RETURN -C -C *** LAST CARD OF (SAXPY) *** - END //GO.SYSIN DD hopdm.src/saxpy.f echo hopdm.src/scalea.f 1>&2 sed >hopdm.src/scalea.f <<'//GO.SYSIN DD hopdm.src/scalea.f' 's/^-//' -C*************************************************** -C *** SCALEA ... SCALE LP CONSTRAINT MATRIX *** -C*************************************************** -C - SUBROUTINE SCALEA(IOERR, - X MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X RMTMP1,RMTMP2,RNTMP1,RNTMP2, - X B,RANGES,C,UPBND,CSCALE,RSCALE,OSCALE, - X ACOEFF,CLPNTS,RWNMBS, - X LENCOL,STAVAR) -C -C -C -C *** PARAMETERS - INTEGER*4 IOERR,MAXM,MAXN,MAXNZA,M,N,NSTRCT - DOUBLE PRECISION RMTMP1(MAXM),RMTMP2(MAXM) - DOUBLE PRECISION RNTMP1(MAXN),RNTMP2(MAXN) - DOUBLE PRECISION C(MAXN),UPBND(MAXN) - DOUBLE PRECISION CSCALE(MAXN),RSCALE(MAXM),OSCALE - DOUBLE PRECISION ACOEFF(MAXNZA),B(MAXM),RANGES(MAXM) - INTEGER*4 CLPNTS(MAXN+1) - INTEGER*2 RWNMBS(MAXNZA),LENCOL(MAXN),STAVAR(MAXN) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,IPASS,J,K,KBEG,KEND - DOUBLE PRECISION CSCL,RSCL,DP,ELTMIN,ELTMAX,OBJMAX,OBJMIN - CHARACTER*100 BUFFER -C -C -C -C -C *** PARAMETERS DESCRIPTION -C -C *** ON INPUT: -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C MAXM Maximum number of constraints. -C MAXN Maximum number of variables. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of constraints. -C N Number of variables (total, i.e. including slacks, -C surplus and artificials). -C NSTRCT Number of structural variables (excluding slacks, surplus -C and artificials). -C ACOEFF Array of nonzero elements for each column. -C B Right hand side of the linear program. -C RANGES Array of constraint ranges. -C C Objective function coefficients. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C LENCOL Lengths of (sparse) columns of matrix A. -C UPBND Array of upper bounds. Note that the upper bound -C is changed when the variable has a lower bound. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C *** ON OUTPUT: -C CSCALE Column scaling factors. -C RSCALE Row scaling factors. -C OSCALE Objective row scaling factor. -C -C -C -C *** WORK ARRAYS: -C RMTMP1 Double precision work array of size MAXM. -C RMTMP2 Double precision work array of size MAXM. -C RNTMP1 Double precision work array of size MAXN. -C RNTMP2 Double precision work array of size MAXN. -C -C -C -C -C *** PURPOSE -C This routine scales the LP constraint matrix. -C -C -C -C *** SUBROUTINES CALLED -C MYWRT,DABS,DSQRT -C -C -C *** NOTES -C -C -C -C *** REFERENCES: -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: September 10, 1994 -C -C -C -C -C *** BODY OF (SCALEA) *** -C -C -C -C -C Find the largest and the smallest elements in columns of A. - DO 300 J=1,N - RNTMP1(J)=0.0D0 - RNTMP2(J)=1.0D+10 - IF(DABS(C(J)).GE.1.0D-8) THEN - RNTMP1(J)=DABS(C(J)) - RNTMP2(J)=DABS(C(J)) - ENDIF - IF(STAVAR(J).GE.6.OR.LENCOL(J).EQ.0) THEN - RNTMP1(J)=1.0D0 - RNTMP2(J)=1.0D0 - GO TO 300 - ENDIF - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 200 K=KBEG,KEND - DP=DABS(ACOEFF(K)) - IF(DP.GT.RNTMP1(J)) RNTMP1(J)=DP - IF(DP.LT.RNTMP2(J)) RNTMP2(J)=DP - 200 CONTINUE -C WRITE(IOERR,201) J,RNTMP1(J),RNTMP2(J) -C 201 FORMAT(1X,'col=',I5,' RNTMP1=',D10.3,' RNTMP2=',D10.3) - 300 CONTINUE -C -C -C -C -C -C Main loop begins here. - DO 1000 IPASS=1,2 -C -C -C Find the largest and the smallest element of A. - ELTMAX=0.0D0 - ELTMIN=1.0D+10 - DO 320 J=1,N - IF(STAVAR(J).GE.6) GO TO 320 - IF(RNTMP1(J).GT.ELTMAX) ELTMAX=RNTMP1(J) - IF(RNTMP2(J).LT.ELTMIN) ELTMIN=RNTMP2(J) - 320 CONTINUE - DP=ELTMAX/ELTMIN - WRITE(BUFFER,321) IPASS-1,ELTMAX,ELTMIN,DP - 321 FORMAT(1X,'SCALEA: PASS=',I2,' Amax=',1PD8.1, - X ' Amin=',1PD8.1,' Amax/Amin=',1PD8.1) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C -C -C Scale columns of the LP constraint matrix. -C WRITE(BUFFER,401) -C 401 FORMAT(1X,'SCALEA: Scaling columns of A.') -C CALL MYWRT(0,BUFFER) -C CALL MYWRT(IOERR,BUFFER) -C -C Divide column j of A by CSCALE(j). -C Find the largest and the smallest elements in rows of A. -C Find the largest and the smallest elements in the objective row. - DO 400 I=1,M - RMTMP1(I)=0.0D0 - RMTMP2(I)=1.0D+10 - 400 CONTINUE - OBJMAX=0.0D0 - OBJMIN=1.0D+10 - DO 460 J=1,N - IF(STAVAR(J).GE.6) GO TO 460 - DP=DSQRT(RNTMP1(J)*RNTMP2(J)) -C WRITE(IOERR,402) J,DP -C 402 FORMAT(1X,'SCALEA: column= ',I5,' CSCALE=',D10.3) - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 440 K=KBEG,KEND - ACOEFF(K)=ACOEFF(K)/DP - I=RWNMBS(K) - RSCL=DABS(ACOEFF(K)) - IF(RSCL.GT.RMTMP1(I)) RMTMP1(I)=RSCL - IF(RSCL.LT.RMTMP2(I)) RMTMP2(I)=RSCL - 440 CONTINUE - C(J)=C(J)/DP - IF(DABS(C(J)).GE.1.0D-8) THEN - IF(DABS(C(J)).GT.OBJMAX) OBJMAX=DABS(C(J)) - IF(DABS(C(J)).LT.OBJMIN) OBJMIN=DABS(C(J)) - ENDIF - UPBND(J)=UPBND(J)*DP - CSCALE(J)=CSCALE(J)*DP - 460 CONTINUE -C -C -C Scale rows of the LP constraint matrix. -C WRITE(BUFFER,601) -C 601 FORMAT(1X,'SCALEA: Scaling rows of A.') -C CALL MYWRT(0,BUFFER) -C CALL MYWRT(IOERR,BUFFER) - DO 600 I=1,M - RMTMP1(I)=DSQRT(RMTMP1(I)*RMTMP2(I)) - IF(DABS(RANGES(I)).LE.1.0D+18) RMTMP1(I)=1.0D0 -C WRITE(IOERR,602) I,RMTMP1(I) -C 602 FORMAT(1X,'SCALEA: row= ',I5,' RSCALE=',D10.3) - 600 CONTINUE -C -C Divide row i of A by RSCALE(i) (omit slack coefficients). -C Find the largest and the smallest elements in columns of A. -C Divide objective row by DP=DSQRT(OBJMAX*OBJMIN). - DP=DSQRT(OBJMAX*OBJMIN)/1.0D+1 - IF(DP.GE.1.0D+2) DP=1.0D+2 -C IF(IPASS.GE.2) DP=1.0D0 -C WRITE(BUFFER,603) OBJMAX,OBJMIN,DP -C 603 FORMAT(1X,'SCALEA: Omx=',1PD8.1,' Omn=',1PD8.1,' Oscl=',1PD8.1) -C CALL MYWRT(IOERR,BUFFER) - OSCALE=OSCALE*DP - DO 660 J=1,NSTRCT - RNTMP1(J)=0.0D0 - RNTMP2(J)=1.0D+10 -C IF(DABS(C(J)).GE.1.0D-8) THEN -C RNTMP1(J)=DABS(C(J)) -C RNTMP2(J)=DABS(C(J)) -C ENDIF - IF(STAVAR(J).GE.6.OR.LENCOL(J).EQ.0) THEN - RNTMP1(J)=1.0D0 - RNTMP2(J)=1.0D0 - GO TO 650 - ENDIF - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 640 K=KBEG,KEND - I=RWNMBS(K) - ACOEFF(K)=ACOEFF(K)/RMTMP1(I) - CSCL=DABS(ACOEFF(K)) - IF(CSCL.GT.RNTMP1(J)) RNTMP1(J)=CSCL - IF(CSCL.LT.RNTMP2(J)) RNTMP2(J)=CSCL - 640 CONTINUE - 650 C(J)=C(J)/DP - 660 CONTINUE - DO 680 I=1,M - B(I)=B(I)/RMTMP1(I) - RANGES(I)=RANGES(I)/RMTMP1(I) - RSCALE(I)=RSCALE(I)*RMTMP1(I) - 680 CONTINUE -C -C Do not scale slack coefficients. - DO 700 J=NSTRCT+1,N - RNTMP1(J)=1.0D0 - RNTMP2(J)=1.0D0 - C(J)=C(J)/DP - 700 CONTINUE -C -C -C -C -C End of main loop. - 1000 CONTINUE -C -C -C -C -C Find the largest and the smallest element of A. - ELTMAX=0.0D0 - ELTMIN=1.0D+10 - DO 1100 J=1,N - IF(STAVAR(J).GE.6) GO TO 1100 - IF(RNTMP1(J).GT.ELTMAX) ELTMAX=RNTMP1(J) - IF(RNTMP2(J).LT.ELTMIN) ELTMIN=RNTMP2(J) - 1100 CONTINUE - DP=ELTMAX/ELTMIN - WRITE(BUFFER,1101) IPASS-1,ELTMAX,ELTMIN,DP - 1101 FORMAT(1X,'SCALEA: PASS=',I2,' Amax=',1PD8.1, - X ' Amin=',1PD8.1,' Amax/Amin=',1PD8.1) - CALL MYWRT(0,BUFFER) - CALL MYWRT(IOERR,BUFFER) -C -C - RETURN -C -C *** LAST CARD OF (SCALEA) *** - END //GO.SYSIN DD hopdm.src/scalea.f echo hopdm.src/schur1.f 1>&2 sed >hopdm.src/schur1.f <<'//GO.SYSIN DD hopdm.src/schur1.f' 's/^-//' -C*********************************************************************** -C * SCHUR1 ... SOLVE EQUATION WITH (A,F)*(THETA,THF)*(A,F)transp * -C * ONE COLUMN IS BORDERED TO THE LP CONSTRAINT MTX * -C*********************************************************************** -C - SUBROUTINE SCHUR1(MAXNZL,MAXM,M,COLUMN,RHS, - X LCOEFF,LCLPTS,LRWNBS,LDIAG,LDSQRT, - X FCLMN1,THF1, - X WCLMN1,RTEMP1,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXNZL,MAXM,M,IOERR - DOUBLE PRECISION LCOEFF(*),LDIAG(MAXM),LDSQRT(MAXM) - DOUBLE PRECISION COLUMN(MAXM),RHS(MAXM) - DOUBLE PRECISION FCLMN1(MAXM),THF1 - DOUBLE PRECISION WCLMN1(MAXM),RTEMP1(MAXM) - INTEGER*4 LCLPTS(MAXM+1) -C -C *** The following array can be half-length integer. - INTEGER*2 LRWNBS(MAXNZL) -C -C -C *** LOCAL VARIABLES - DOUBLE PRECISION H,Z,DP1,SCHR11 - INTEGER*4 IROW -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: Cholesky factor of A*THETA*Atransp. -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C MAXM Maximum row dimension of the LP constraint matrix. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C LCOEFF Off-diagonal nonzero coefficients of Cholesky matrix. -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C LDIAG Diagonal elements of Cholesky factor. -C LDSQRT Square root of the diagonal matrix of the Cholesky -C decomposition. -C FCLMN1 Column of matrix F bordered to A (supposed to be dense). -C THF1 Element of matrix THETAF. -C RHS Right-hand-side of the equation. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C COLUMN Solution of the equation -C ( (A,F)*(THETA,THF)*(A,F)transp ) * X = RHS. -C -C WORK ARRAYS: -C WCLMN1 Column of matrix W. -C SCHR11 Element S(1,1) of the 1x1 Schur complement. -C RTEMP1 Temporary work array. -C -C -C -C *** SUBROUTINES CALLED: -C DSQRT,DDOT,SOLVL,SOLAAT -C -C -C *** PURPOSE: -C This routine solves equation with (A,F)*(THETA,THF)*(A,F)transp. -C It handles column F implicitly to avoid its degrading -C influence on the sparsity of Cholesky factor L. -C It uses the Cholesky decomposition L*D*Ltransp of A*THETA*Atransp -C (the decomposition must be computed before calling this routine). -C -C -C *** NOTES: -C 1. The contents of RHS array is destroyed by this routine. -C -C 2. This routine is compatible with Gondzio's implementation -C of Cholesky decomposition. -C -C 3. This routine performs the following sequence of calculations: -C WCLMN1 Column w1: solve eqn (L*D**0.5) * w1 = f1. -C SCHR11 1x1 Schur: compute 1 + (THF**0.5)*(Wtransp*W)*(THF**0.5) -C COLUMN Column g: solve eqn (L*D**0.5) * g = d. -C H Variable h: compute h = THF**0.5 * Wtransp * g. -C Z Variable z: solve eqn S * z = h. -C RHS Column t: compute t = d - F * (THF**0.5) * z. -C COLUMN Column x: solve eqn (L*D*Ltransp) * x = t. -C -C -C *** REFERENCES: -C Cottle R.W. (1974). Manifestations of the Schur complement, -C Linear Algebra and its Applications, vol 8, pp. 189-211. -C Choi I.C., Monma C.L., Shanno D.F. (1990). Further development -C of a primal-dual interior point method, ORSA Journal -C on Computing, vol 2, pp. 304-311. -C Gondzio J. (1991). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Technical Report No 107, LAMSADE, University of Paris -C Dauphine, 75775 Paris Cedex 16, France, December 1991, -C revised in September 1992. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: October 26, 1992 -C -C -C -C *** BODY OF (SCHUR1) *** -C -C -C -C -C Copy FCLMN1 array into RTEMP1 array. - DO 100 IROW=1,M - RTEMP1(IROW)=FCLMN1(IROW) - 100 CONTINUE -C -C -C -C -C Solve the equation (L*D**0.5) * w1 = f1. -C Next, save RHS in RTEMP1 array. -C - CALL SOLVL(LCOEFF,LCLPTS,LRWNBS, - X MAXNZL,MAXM,M,WCLMN1,RTEMP1,IOERR) -C - DO 200 IROW=1,M - WCLMN1(IROW)=WCLMN1(IROW)/LDSQRT(IROW) - RTEMP1(IROW)=RHS(IROW) - 200 CONTINUE -C -C -C -C -C Build up the 1x1 Schur complement. -C 1 + (THF**0.5)*(Wtransp*W)*(THF**0.5) -C - CALL DDOT(WCLMN1,WCLMN1,M,SCHR11) -C - SCHR11=SCHR11*THF1+1.0 -C -C -C -C -C Solve the equation (L*D**0.5) * g = d. -C - CALL SOLVL(LCOEFF,LCLPTS,LRWNBS, - X MAXNZL,MAXM,M,COLUMN,RTEMP1,IOERR) -C - DO 300 IROW=1,M - COLUMN(IROW)=COLUMN(IROW)/LDSQRT(IROW) - 300 CONTINUE -C -C -C -C -C Compute h = THF**0.5 * Wtransp * g. -C - CALL DDOT(WCLMN1,COLUMN,M,H) - H=H*DSQRT(THF1) -C -C -C -C -C Solve equation with a 1x1 Schur complement S * z = h. -C - Z=H/SCHR11 -C -C -C -C -C Compute t = d - F * (THF**0.5) * z. -C - DP1=Z*DSQRT(THF1) -C - DO 400 IROW=1,M - RHS(IROW)=RHS(IROW)-FCLMN1(IROW)*DP1 - 400 CONTINUE -C -C -C -C -C Solve the equation (L*D*Ltransp) * x = t. -C - CALL SOLAAT(LCOEFF,LCLPTS,LRWNBS,LDIAG, - X MAXNZL,MAXM,M,COLUMN,RHS,IOERR) -C -C -C -C - RETURN -C -C -C *** LAST CARD OF (SCHUR1) *** - END //GO.SYSIN DD hopdm.src/schur1.f echo hopdm.src/schur2.f 1>&2 sed >hopdm.src/schur2.f <<'//GO.SYSIN DD hopdm.src/schur2.f' 's/^-//' -C*********************************************************************** -C * SCHUR2 ... SOLVE EQUATION WITH (A,F)*(THETA,THF)*(A,F)transp * -C * TWO COLUMNS ARE BORDERED TO THE LP CONSTRAINT MTX * -C*********************************************************************** -C - SUBROUTINE SCHUR2(MAXNZL,MAXM,M,COLUMN,RHS, - X LCOEFF,LCLPTS,LRWNBS,LDIAG,LDSQRT, - X FCLMN1,FCLMN2,THF1,THF2, - X WCLMN1,WCLMN2,RTEMP1,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXNZL,MAXM,M,IOERR - DOUBLE PRECISION LCOEFF(*),LDIAG(MAXM),LDSQRT(MAXM) - DOUBLE PRECISION COLUMN(MAXM),RHS(MAXM) - DOUBLE PRECISION FCLMN1(MAXM),FCLMN2(MAXM),THF1,THF2 - DOUBLE PRECISION WCLMN1(MAXM),WCLMN2(MAXM),RTEMP1(MAXM) - INTEGER*4 LCLPTS(MAXM+1) -C -C *** The following array can be half-length integer. - INTEGER*2 LRWNBS(MAXNZL) -C -C -C *** LOCAL VARIABLES - DOUBLE PRECISION HCOL(2),ZCOL(2),DP1,DP2 - DOUBLE PRECISION SCHR11,SCHR21,SCHR22,SD11,SD22,SL21 - INTEGER*4 IROW -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: Cholesky factor of A*THETA*Atransp. -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C MAXM Maximum row dimension of the LP constraint matrix. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C LCOEFF Off-diagonal nonzero coefficients of Cholesky matrix. -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C LDIAG Diagonal elements of Cholesky factor. -C LDSQRT Square root of the diagonal matrix of the Cholesky -C decomposition. -C FCLMN1 First column of matrix F (supposed to be dense). -C FCLMN2 Second column of matrix F (supposed to be dense). -C THF1 First element of matrix THETAF. -C THF2 Second element of matrix THETAF. -C RHS Right-hand-side of the equation. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C COLUMN Solution of the equation -C ( (A,F)*(THETA,THF)*(A,F)transp ) * X = RHS. -C -C WORK ARRAYS: -C WCLMN1 First column of matrix W. -C WCLMN2 Second column of matrix W. -C SCHRij Element S(i,j) of the 2x2 symmetric Schur complement. -C RTEMP1 Temporary work array. -C -C -C -C *** SUBROUTINES CALLED: -C DSQRT,DDOT,SOLVL,SOLAAT -C -C -C *** PURPOSE: -C This routine solves equation with (A,F)*(THETA,THF)*(A,F)transp. -C It handles columns of F implicitly to avoid their degrading -C influence on the sparsity of Cholesky factor L. -C It uses the Cholesky decomposition L*D*Ltransp of A*THETA*Atransp -C (the decomposition must be computed before calling this routine). -C -C -C *** NOTES: -C 1. The contents of RHS array is destroyed by this routine. -C -C 2. This routine is compatible with Gondzio's implementation -C of Cholesky decomposition. -C -C 3. This routine performs the following sequence of calculations: -C WCLMN1 Column w1: solve eqn (L*D**0.5) * w1 = f1. -C WCLMN2 Column w2: solve eqn (L*D**0.5) * w2 = f2. -C SCHRij 2x2 Schur: compute I + (THF**0.5)*(Wtransp*W)*(THF**0.5) -C COLUMN Column g: solve eqn (L*D**0.5) * g = d. -C HCOL Column h: compute h = THF**0.5 * Wtransp * g. -C ZCOL Column z: solve eqn S * z = h. -C RHS Column t: compute t = d - F * (THF**0.5) * z. -C COLUMN Column x: solve eqn (L*D*Ltransp) * x = t. -C -C -C *** REFERENCES: -C Cottle R.W. (1974). Manifestations of the Schur complement, -C Linear Algebra and its Applications, vol 8, pp. 189-211. -C Choi I.C., Monma C.L., Shanno D.F. (1990). Further development -C of a primal-dual interior point method, ORSA Journal -C on Computing, vol 2, pp. 304-311. -C Gondzio J. (1991). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Technical Report No 107, LAMSADE, University of Paris -C Dauphine, 75775 Paris Cedex 16, France, December 1991, -C revised in September 1992. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: October 26, 1992 -C -C -C -C *** BODY OF (SCHUR2) *** -C -C -C -C -C Copy FCLMN1 array into RTEMP1 array. -C Copy FCLMN2 array into COLUMN array. - DO 100 IROW=1,M - RTEMP1(IROW)=FCLMN1(IROW) - COLUMN(IROW)=FCLMN2(IROW) - 100 CONTINUE -C -C -C -C -C Solve the equation (L*D**0.5) * w1 = f1. -C Solve the equation (L*D**0.5) * w2 = f2. -C Next, save RHS in RTEMP1 array. -C - CALL SOLVL(LCOEFF,LCLPTS,LRWNBS, - X MAXNZL,MAXM,M,WCLMN1,RTEMP1,IOERR) - CALL SOLVL(LCOEFF,LCLPTS,LRWNBS, - X MAXNZL,MAXM,M,WCLMN2,COLUMN,IOERR) -C - DO 200 IROW=1,M - WCLMN1(IROW)=WCLMN1(IROW)/LDSQRT(IROW) - WCLMN2(IROW)=WCLMN2(IROW)/LDSQRT(IROW) - RTEMP1(IROW)=RHS(IROW) - 200 CONTINUE -C -C -C -C -C Build up the 2x2 Schur complement. -C I + (THF**0.5)*(Wtransp*W)*(THF**0.5) -C - CALL DDOT(WCLMN1,WCLMN1,M,SCHR11) - CALL DDOT(WCLMN1,WCLMN2,M,SCHR21) - CALL DDOT(WCLMN2,WCLMN2,M,SCHR22) -C - SCHR11=SCHR11*THF1+1.0 - SCHR21=SCHR21*DSQRT(THF1*THF2) - SCHR22=SCHR22*THF2+1.0 -C -C -C -C -C Solve the equation (L*D**0.5) * g = d. -C - CALL SOLVL(LCOEFF,LCLPTS,LRWNBS, - X MAXNZL,MAXM,M,COLUMN,RTEMP1,IOERR) -C - DO 300 IROW=1,M - COLUMN(IROW)=COLUMN(IROW)/LDSQRT(IROW) - 300 CONTINUE -C -C -C -C -C Compute h = THF**0.5 * Wtransp * g. -C - CALL DDOT(WCLMN1,COLUMN,M,HCOL(1)) - CALL DDOT(WCLMN2,COLUMN,M,HCOL(2)) - HCOL(1)=HCOL(1)*DSQRT(THF1) - HCOL(2)=HCOL(2)*DSQRT(THF2) -C -C -C -C -C Solve equation with a 2x2 Schur complement S * z = h. -C - SD11=SCHR11 - SL21=SCHR21/SD11 - SD22=SCHR22-SL21*SCHR21 -C - ZCOL(1)=HCOL(1) - ZCOL(2)=HCOL(2)-SL21*ZCOL(1) -C - ZCOL(1)=ZCOL(1)/SD11 - ZCOL(2)=ZCOL(2)/SD22 -C -C ZCOL(2)=ZCOL(2) - ZCOL(1)=ZCOL(1)-SL21*ZCOL(2) -C -C -C -C -C -C Compute t = d - F * (THF**0.5) * z. -C - DP1=ZCOL(1)*DSQRT(THF1) - DP2=ZCOL(2)*DSQRT(THF2) -C - DO 400 IROW=1,M - RHS(IROW)=RHS(IROW)-FCLMN1(IROW)*DP1-FCLMN2(IROW)*DP2 - 400 CONTINUE -C -C -C -C -C Solve the equation (L*D*Ltransp) * x = t. -C - CALL SOLAAT(LCOEFF,LCLPTS,LRWNBS,LDIAG, - X MAXNZL,MAXM,M,COLUMN,RHS,IOERR) -C -C -C -C - RETURN -C -C -C *** LAST CARD OF (SCHUR2) *** - END //GO.SYSIN DD hopdm.src/schur2.f echo hopdm.src/sclcol.f 1>&2 sed >hopdm.src/sclcol.f <<'//GO.SYSIN DD hopdm.src/sclcol.f' 's/^-//' -C****************************************************** -C **** SCLCOL ... SCALE COLUMNS OF A **** -C****************************************************** -C - SUBROUTINE SCLCOL(MAXN,MAXNZA,N, - X CLPNTS,LENCOL,ACOEFF, - X CSCALE,OSCALE,C,UPBND,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXN,MAXNZA,N,IOERR - INTEGER*4 CLPNTS(MAXN+1) - INTEGER*2 LENCOL(MAXN) - DOUBLE PRECISION ACOEFF(MAXNZA) - DOUBLE PRECISION C(MAXN),UPBND(MAXN),CSCALE(MAXN),OSCALE -C -C -C *** LOCAL VARIABLES - INTEGER*4 JCOL,K,KBEG,KEND - DOUBLE PRECISION DP -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C N Number of columns of the LP constraint matrix. -C CLPNTS Pointers to the beginning of columns of matrix A. -C LENCOL Lengths of (sparse) columns of matrix A. -C ACOEFF Array of non zero elements for each column. -C CSCALE Column scaling factors. -C OSCALE Objective row scaling factor. -C C Objective function coefficients. -C UPBND Array of upper bounds. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C Scaled LP constraint matrix. -C CLPNTS Pointers to the beginning of columns of matrix A. -C LENCOL Lengths of (sparse) columns of matrix A. -C ACOEFF Array of non zero elements for each column. -C C Objective function coefficients. -C UPBND Array of upper bounds. -C -C -C -C *** SUBROUTINES CALLED: -C NONE -C -C -C *** PURPOSE: -C 1. This routine scales columns of A. -C Each column of A is divided by a given scaling factor. -C 2. C and UPBND arrays are modified accordingly. -C 3. Additionally, it scales the objective row. -C -C -C *** NOTES: -C -C -C -C *** REFERENCES: -C Altman A., Gondzio J. (1992a). An efficient implementation -C of a higher order primal-dual interior point method -C for large sparse linear programs, Archives of Control -C Sciences (to appear). -C Altman A., Gondzio J. (1992b). HOPDM - A higher order -C primal-dual method for large scale linear programmming, -C European Journal of Operational Research (to appear). -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: May 29, 1992 -C Last modified: September 10, 1994 -C -C -C -C *** BODY OF (SCLCOL) *** -C -C -C -C -C *** DEBUGGING -C WRITE(IOERR,51) -C 51 FORMAT(1X/1X,'SCLCOL: Scaling factors:') -C DO 53 JCOL=1,N -C WRITE(IOERR,52) JCOL,CSCALE(JCOL) -C 52 FORMAT(1X,'SCLCOL: col= ',I5,' CSCALE=',D10.3) -C 53 CONTINUE -C -C -C -C Main loop begins here. -C Divide column j of A by CSCALE(j). - DO 500 JCOL=1,N - DP=CSCALE(JCOL) - KBEG=CLPNTS(JCOL) - KEND=KBEG+LENCOL(JCOL)-1 -C -C Modify the whole column JCOL. - DO 200 K=KBEG,KEND - ACOEFF(K)=ACOEFF(K)/DP - 200 CONTINUE -C - C(JCOL)=C(JCOL)/DP - UPBND(JCOL)=UPBND(JCOL)*DP -C -C End of main loop. - 500 CONTINUE -C -C -C - DO 600 JCOL=1,N - C(JCOL)=C(JCOL)/OSCALE - 600 CONTINUE -C -C - RETURN -C -C *** LAST CARD OF (SCLCOL) *** - END //GO.SYSIN DD hopdm.src/sclcol.f echo hopdm.src/sclrow.f 1>&2 sed >hopdm.src/sclrow.f <<'//GO.SYSIN DD hopdm.src/sclrow.f' 's/^-//' -C****************************************************** -C **** SCLROW ... SCALE ROWS OF A **** -C****************************************************** -C - SUBROUTINE SCLROW(MAXM,MAXNZA,M,NSTRCT, - X RWHEAD,RWLINK,CLNMBS,ACOEFF, - X RSCALE,RANGES,RHS,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXM,MAXNZA,M,NSTRCT,IOERR - INTEGER*4 RWHEAD(MAXM+1),RWLINK(MAXNZA) - INTEGER*2 CLNMBS(MAXNZA) - DOUBLE PRECISION ACOEFF(MAXNZA) - DOUBLE PRECISION RANGES(MAXM),RHS(MAXM),RSCALE(MAXM) -C -C -C *** LOCAL VARIABLES - INTEGER*4 IROW,K - DOUBLE PRECISION DP -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of rows of the LP constraint matrix. -C NSTRCT Number of structural variables (excluding slacks, surplus -C and artificials). -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C ACOEFF Nonzero elements of matrix A. -C RSCALE Current row scaling factors. -C RANGES Array of constraint ranges. -C RHS LP right-hand-side. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C Scaled LP constraint matrix. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C ACOEFF Nonzero elements of matrix A. -C RANGES Array of constraint ranges. -C RHS LP right-hand-side. -C -C -C -C *** SUBROUTINES CALLED: -C NONE -C -C -C *** PURPOSE: -C 1. This routine scales rows of A. -C Each row of A is divided by a given scaling factor. -C 2. RHS and RANGES arrays are modified accordingly. -C -C -C *** NOTES: -C -C -C -C *** REFERENCES: -C Altman A., Gondzio J. (1992a). An efficient implementation -C of a higher order primal-dual interior point method -C for large sparse linear programs, Archives of Control -C Sciences (to appear). -C Altman A., Gondzio J. (1992b). HOPDM - A higher order -C primal-dual method for large scale linear programmming, -C European Journal of Operational Research (to appear). -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: May 29, 1992 -C Last modified: January 4, 1993 -C -C -C -C *** BODY OF (SCLROW) *** -C -C -C -C -C *** DEBUGGING -C WRITE(IOERR,51) -C 51 FORMAT(1X/1X,'SCLROW: Scaling factors:') -C DO 53 IROW=1,M -C WRITE(IOERR,52) IROW,RSCALE(IROW) -C 52 FORMAT(1X,'SCLROW: row= ',I5,' RSCALE=',D10.3) -C 53 CONTINUE -C -C -C -C Main loop begins here. -C Divide row i of A by RSCALE(i). - DO 500 IROW=1,M - DP=RSCALE(IROW) -C -C Modify the whole row IROW. - K=RWHEAD(IROW) - 100 IF(K.EQ.0) GO TO 400 - IF(CLNMBS(K).LE.NSTRCT) GO TO 200 - K=RWLINK(K) - GO TO 100 - 200 IF(K.EQ.0) GO TO 400 - ACOEFF(K)=ACOEFF(K)/DP - K=RWLINK(K) - GO TO 200 -C - 400 RHS(IROW)=RHS(IROW)/DP - RANGES(IROW)=RANGES(IROW)/DP -C -C End of main loop. - 500 CONTINUE -C -C -C - RETURN -C -C *** LAST CARD OF (SCLROW) *** - END //GO.SYSIN DD hopdm.src/sclrow.f echo hopdm.src/sdot.f 1>&2 sed >hopdm.src/sdot.f <<'//GO.SYSIN DD hopdm.src/sdot.f' 's/^-//' -C************************************************************** -C **** SDOT ... SPARSE INNER PRODUCT OF TWO VECTORS **** -C************************************************************** -C - SUBROUTINE SDOT(X,IROW,RELT,KNZ,PROD) -C -C *** PARAMETERS - INTEGER*4 KNZ,IROW(KNZ) - DOUBLE PRECISION X(*),RELT(KNZ),PROD -C -C *** LOCAL VARIABLES - INTEGER*4 I,IKX -C -C *** PURPOSE -C This routine computes the scalar product of a dense vector X -C and a sparse vector Y (packed in IROW and RELT arrays). -C -C -C *** PARAMETERS DESCRIPTION -C ON INPUT: -C X The first (dense) vector. -C IROW Row numbers of nonzeros in a sparse vector Y. -C RELT Nonzero entries a sparse vector Y. -C KNZ Number of nonzero entries in vector Y. -C ON OUTPUT: -C PROD Scalar product of vectors X and Y. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C -C and Dominique Tachat, LAMSADE, -C University of Paris Dauphine, -C Place du Marechal de Lattre de Tassigny, -C 75775 Paris Cedex 16, France. -C -C Last modified: March 21, 1992 -C -C -C -C -C *** BODY OF (SDOT) *** -C - PROD=0. - DO 100 I=1,KNZ - IKX=IROW(I) - PROD=PROD+X(IKX)*RELT(I) - 100 CONTINUE - RETURN -C -C *** LAST CARD OF (SDOT) *** - END //GO.SYSIN DD hopdm.src/sdot.f echo hopdm.src/setmap.f 1>&2 sed >hopdm.src/setmap.f <<'//GO.SYSIN DD hopdm.src/setmap.f' 's/^-//' -C**************************************************************** -C ** SETMAP ... SET MAPS OF THE HIDDEN DATA STRUCTURES ** -C**************************************************************** -C - SUBROUTINE setmap(MAXM,MAXN,MAXNZA, - X IMAP,RMAP,LIWORK,LRWORK,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXM,MAXN,MAXNZA,LIWORK,LRWORK,IOERR - INTEGER*4 IMAP(*),RMAP(*) -C -C -C *** LOCAL VARIABLES - INTEGER*4 INTHLF,IMEMR,RMEMR - CHARACTER*100 BUFFER -C -C -C *** PARAMETER DESCRIPTION -C -C ON INPUT: -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C LIWORK Size of IWORK array. -C LRWORK Size of RWORK array. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C RMAP Map of RWORK. -C IMAP Map of IWORK. -C -C -C *** HIDDEN DATA STRUCTURES DESCRIPTION -C RWORK Real work array containing almost all real -C LP problem data. -C IWORK Integer work array containing almost all integer -C LP problem data. -C RMAP Map of RWORK. -C IMAP Map of IWORK. -C -C Map of IWORK array: -C IMAP(1) Points to CLPNTS array. -C IMAP(2) Points to RWNMBS array. -C IMAP(3) Points to RWHEAD array. -C IMAP(4) Points to RWLINK array. -C IMAP(5) Points to CLNMBS array. -C IMAP(6) Points to LENCOL array. -C IMAP(7) Points to the first empty cell of IWORK array. -C -C Map of RWORK array: -C RMAP(1) Points to ACOEFF array. -C RMAP(2) Points to COBJ array. -C RMAP(3) Points to RHS array. -C RMAP(4) Points to the first empty cell of RWORK array. -C -C -C -C *** SUBROUTINES CALLED: -C NONE -C -C *** PURPOSE: -C This routine sets up the maps of the hidden data structures. -C -C -C *** NOTES: -C -C ARRAY SIZES: -C ARRAY NO. OF ENTRIES TYPE -C ------ -------------- ---- -C CLPNTS MAXN + 8 INTEGER*4 -C RWNMBS MAXNZA INTEGER*2 (or *4) -C RWHEAD MAXM INTEGER*4 -C RWLINK MAXNZA INTEGER*4 -C CLNMBS MAXNZA INTEGER*2 (or *4) -C LENCOL MAXN INTEGER*2 (or *4) -C -C COEFFA MAXNZA DOUBLE PRECISION -C COBJ MAXN DOUBLE PRECISION -C RHS MAXM DOUBLE PRECISION -C -C FORMULAS FOR DETERMINING HOW MUCH SPACE IS NEEDED: -C -C LIWORK = MAXM + 2*MAXN + (1+2/INTHLF)*MAXNZA + 9 -C LRWORK = MAXM + MAXN + MAXNZA + 1 -C -C -C -C *** REFERENCES: -C Gondzio J., Tachat D. (1992). The design and application -C of IPMLO - a FORTRAN library for linear optimization -C with interior point methods, Technical Report No 108, -C LAMSADE, University of Paris Dauphine, 75775 Paris Cedex 16, -C France, January 1992, revised in November 1992. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C -C and Dominique Tachat, LAMSADE, -C University of Paris Dauphine, -C Place du Marechal de Lattre de Tassigny, -C 75775 Paris Cedex 16, France. -C -C Date written: April 11, 1991 -C Last modified: January 23, 1993 -C -C -C -C -C -C *** BODY OF (SETMAP) *** -C -C -C -C Set the parameter controling the length of representation -C of the half-length INTEGER data. This applies to all arrays -C handling indicices like row/col numbers or column lengths. -C Row linked lists are always stored as INTEGER*4 as they are -C expected to address more than 32000 nonzero elements. -C INTHLF = 1 means that INTEGER*4 arrays will be used; -C INTHLF = 2 means that INTEGER*2 arrays will be used; - INTHLF=2 -C -C -C -C Set up IMAP, the map of the hidden INTEGER data. - IMAP(1)=1 - IMAP(2)=IMAP(1)+MAXN+8 - IMAP(3)=IMAP(2)+MAXNZA/INTHLF - IMAP(4)=IMAP(3)+MAXM - IMAP(5)=IMAP(4)+MAXNZA - IMAP(6)=IMAP(5)+MAXNZA/INTHLF - IMAP(7)=IMAP(6)+MAXN/INTHLF -C -C Set up RMAP, the map of the hidden REAL data. - RMAP(1)=1 - RMAP(2)=RMAP(1)+MAXNZA - RMAP(3)=RMAP(2)+MAXN - RMAP(4)=RMAP(3)+MAXM -C -C -C -C Figure out how much space is left. - IMEMR=LIWORK-IMAP(7) - RMEMR=LRWORK-RMAP(4) -C - WRITE(BUFFER,101) LIWORK,LRWORK - 101 FORMAT(1X,'SETMAP: Available memory:', - X 3X,'INTEGER:',I9,5X,'REAL:',I9) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,102) - 102 FORMAT(1X) - CALL MYWRT(IOERR,BUFFER) -C - IF(IMEMR.GE.0.AND.RMEMR.GE.0) GO TO 200 - WRITE(BUFFER,103) - 103 FORMAT(1X,'SETMAP ERROR: Please increase work arrays:') - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,104) IMAP(7),RMAP(4) - 104 FORMAT(29X,'INTEGER:',I9,5X,'REAL:',I9) - CALL ERRWRT(IOERR,BUFFER) - STOP -C - 200 IF(IMEMR.GT.0) THEN - WRITE(BUFFER,201) LIWORK,IMAP(7) - 201 FORMAT(9X,'INTEGER memory can be reduced from',I9,' to ',I9) - CALL MYWRT(IOERR,BUFFER) - ENDIF - IF(RMEMR.GT.0) THEN - WRITE(BUFFER,202) LRWORK,RMAP(4) - 202 FORMAT(9X,'REAL memory can be reduced from',I9,' to ',I9) - CALL MYWRT(IOERR,BUFFER) - ENDIF -C -C - RETURN -C -C *** LAST CARD OF (SETMAP) *** - END //GO.SYSIN DD hopdm.src/setmap.f echo hopdm.src/smplx.f 1>&2 sed >hopdm.src/smplx.f <<'//GO.SYSIN DD hopdm.src/smplx.f' 's/^-//' -C************************************************************** -C *** SMPLX ... A (ONE ROW) LOOK-AHEAD SIMPLEX METHOD *** -C************************************************************** -C - SUBROUTINE SMPLX(IOERR,MSGLEV,NMAX,N,NSTRCT,ROWST, - X COEFF,X,C,UPPER,RDCOST,RHS,P,Q,DUAL) -C -C *** PARAMETERS - INTEGER*4 IOERR,MSGLEV,NMAX,N,NSTRCT,ROWST - DOUBLE PRECISION COEFF(NMAX),X(NMAX),C(NMAX),UPPER(NMAX) - DOUBLE PRECISION RDCOST(NMAX),RHS,P,Q,DUAL -C -C *** LOCAL VARIABLES - INTEGER*4 IBASIC,ITER,ISTEP,J,JBEST - DOUBLE PRECISION BIGNEW,FSBTOL,OPTTOL,SMALLA - DOUBLE PRECISION DP,DBEST,STEP,STEPB,SBEST,OBJ - CHARACTER*100 BUFFER -C -C -C *** PARAMETERS DESCRIPTION -C *** ON INPUT: -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C MSGLEV The level of PRE_SOLVE information desired: -C 0 only final problem dimensions are printed; -C 1 numbers of eliminated rows and columns are printed; -C 2 names of eliminated rows and columns are printed; -C 3 detailed DEBUGGING information is printed. -C NMAX Maximum number of columns. -C N Number of variables (including logicals). -C NSTRCT Number of structural variables. -C ROWST Status of the row: -C 1 'EQ' row; -C 2 'GE' row; -C 3 'LE' row. -C COEFF LP constraint coefficients. -C X Primal variables. -C C Objective function coefficients. -C UPPER Variables' upper bounds. -C RDCOST Reduced costs. -C RHS Right hand side. -C P LOWER bound on shadow price. -C Q UPPER bound on shadow price. -C DUAL Dual variable. -C *** ON OUTPUT: -C X Primal variables. -C RDCOST Reduced costs. -C DUAL Dual variable. -C -C -C *** WORK ARRAYS: -C -C -C *** PURPOSE -C This routine solves a one-row linear program. -C It uses the simplex method. -C -C *** SUBROUTINES CALLED -C MYWRT,DABS -C -C *** NOTES -C -C -C *** REFERENCES: -C Gondzio J. (1994). Presolve analysis of linear programs prior -C to applying an interior point method, Technical Report -C No 1994.3, Department of Management Studies, University -C of Geneva, 102, Bd. Carl-Vogt, 1211 Geneva, Switzerland, -C February 1994, revised in December 1994. -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: December 3, 1993 -C Last modified: March 29, 1995 -C -C -C -C *** BODY OF (SMPLX) *** -C -C -C -C Initialize. - BIGNEW=1.0D+20 - FSBTOL=1.0D-8 - OPTTOL=1.0D-8 - SMALLA=1.0D-8 -C -C Initialize all primal variables on zero. -C Compute the 'big number', a penalty for artificial variable. - DBEST=0.0D0 - DO 100 J=1,NSTRCT - X(J)=0.0D0 - IF(DABS(C(J)).GT.DBEST) DBEST=DABS(C(J)) -C WRITE(BUFFER,101) J,COEFF(J),C(J),UPPER(J) -C 101 FORMAT(1X,'cl=',I3,' coeff=',D14.6,' c=',D14.6,' Uj=',D14.6) -C CALL MYWRT(IOERR,BUFFER) - 100 CONTINUE - DBEST=1.0D+3*(DBEST+1.0D0) -C -C -C -C Add logical variables and construct initial feasible solution. - N=NSTRCT - IF(ROWST.EQ.1) THEN - IF(DABS(RHS).LE.SMALLA) THEN - IBASIC=1 - GO TO 200 - ENDIF - N=NSTRCT+1 - C(N)=DBEST - UPPER(N)=2*BIGNEW - IF(RHS.GE.0.0D0) THEN - COEFF(N)=1.0D0 - X(N)=RHS - ELSE - COEFF(N)=-1.0D0 - X(N)=-RHS - ENDIF - IBASIC=N - GO TO 200 - ENDIF -C - IF(ROWST.EQ.2) THEN - N=NSTRCT+1 - C(N)=0.0D0 - UPPER(N)=2*BIGNEW - COEFF(N)=-1.0D0 - IF(RHS.GE.0.0D0) THEN - X(N)=0.0D0 - N=N+1 - C(N)=DBEST - UPPER(N)=2*BIGNEW - COEFF(N)=1.0D0 - X(N)=RHS - ELSE - X(N)=-RHS - ENDIF - IBASIC=N - GO TO 200 - ENDIF -C - IF(ROWST.EQ.3) THEN - N=NSTRCT+1 - C(N)=0.0D0 - UPPER(N)=2*BIGNEW - COEFF(N)=1.0D0 - IF(RHS.GE.0.0D0) THEN - X(N)=RHS - ELSE - X(N)=0.0D0 - N=N+1 - C(N)=DBEST - UPPER(N)=2*BIGNEW - COEFF(N)=-1.0D0 - X(N)=-RHS - ENDIF - IBASIC=N - GO TO 200 - ENDIF -C -C -C -C -C -C Here when feasible solution found. -C N is the number of LP variables (including logicals). -C Do the feasibility check. - 200 DP=RHS - DO 300 J=1,N - DP=DP-COEFF(J)*X(J) - 300 CONTINUE - IF(DABS(DP).LE.FSBTOL) GO TO 400 - WRITE(BUFFER,301) DP - 301 FORMAT(1X,'SMPLX: Initial solution is infeasible, DP=',D10.3) - CALL MYWRT(IOERR,BUFFER) - STOP -C -C -C -C -C -C -C Main loop begins here. -C Simplex iterations. -C IBASIC indicates basic variable. - 400 ITER=0 - 1000 ITER=ITER+1 - IF(ITER.GE.2*N) THEN - WRITE(BUFFER,1001) - 1001 FORMAT(1X,'SMPLX: Excess iterations limit.') - CALL ERRWRT(IOERR,BUFFER) - STOP - ENDIF -C -C -C Compute dual variable. - DUAL=C(IBASIC)/COEFF(IBASIC) -C -C -C Price all nonbasic variables. -C Compute the current objective. - OBJ=0.0D0 - IF(MSGLEV.LE.2) GO TO 1003 - WRITE(BUFFER,1002) ITER,IBASIC - 1002 FORMAT(1X,'SMPLX: iter=',I6,' ibasic=',I6) - CALL MYWRT(IOERR,BUFFER) - 1003 CONTINUE - DO 1100 J=1,N - RDCOST(J)=C(J)-DUAL*COEFF(J) - OBJ=OBJ+C(J)*X(J) - IF(MSGLEV.LE.2) GO TO 1012 - WRITE(BUFFER,1011) J,RDCOST(J),X(J) - 1011 FORMAT(1X,'LB: cl=',I6,' rc=',D16.8, - X ' X=',D12.5) - CALL MYWRT(IOERR,BUFFER) - 1012 CONTINUE - 1100 CONTINUE - IF(MSGLEV.LE.1) GO TO 1022 - WRITE(BUFFER,1121) ITER,OBJ - 1121 FORMAT(1X,'SMPLX: iter=',I6,' obj=',D10.3) - CALL MYWRT(IOERR,BUFFER) - 1022 CONTINUE -C -C -C Choose a variable to enter the basis. -C Look for a zero variable with the most negative reduced -C cost or a variable blocked on its UPPER bound with the -C most positive reduced cost. -C Additionally, compute the stepsize and the predicted -C improvement of the objective function (do a look-ahead). -C Pick up the variable that gives maximum decrease of the -C objective. - DBEST=0.0D0 - SBEST=0.0D0 - JBEST=0 - DO 1500 J=1,N - IF(DABS(RDCOST(J)).LE.OPTTOL) GO TO 1500 -C -C - IF(RDCOST(J).LE.0.0D0.AND.X(J).LE.FSBTOL) THEN -C -C -C Here when the reduced cost is negitive -C and a variable is on its zero LOWER bound. -C Compute the stepsize. - STEP=1.0D+16 - DP=-COEFF(J)/COEFF(IBASIC) - IF(DP.GE.0) THEN - STEPB=(UPPER(IBASIC)-X(IBASIC))/DP - ELSE - STEPB=-X(IBASIC)/DP - ENDIF - IF(STEPB.LT.STEP) STEP=STEPB - IF(UPPER(J)-X(J).LT.STEP) STEP=UPPER(J)-X(J) - IF(STEP.GE.1.0D+10) THEN - WRITE(BUFFER,1201) - 1201 FORMAT(1X,'SMPLX: Problem is unbounded.') - CALL MYWRT(IOERR,BUFFER) - STOP - ENDIF -C -C Compute the objective improvement (look ahead). - DP=RDCOST(J)*STEP - IF(MSGLEV.LE.2) GO TO 1203 - WRITE(BUFFER,1202) J,RDCOST(J),STEP,DP - 1202 FORMAT(1X,'LB: cl=',I6,' rc=',D16.8, - X ' step=',D12.5,' impr=',D16.8) - CALL MYWRT(IOERR,BUFFER) - 1203 CONTINUE - IF(DP.LT.DBEST) THEN - DBEST=DP - SBEST=STEP - JBEST=J - ISTEP=+1 - ENDIF - ENDIF -C -C - IF(RDCOST(J).GE.0.0D0.AND.UPPER(J)-X(J).LE.FSBTOL) THEN -C -C -C Here when the reduced cost is positive -C and a variable is on its UPPER bound. -C Compute the stepsize. - STEP=1.0D+16 - DP=COEFF(J)/COEFF(IBASIC) - IF(DP.GE.0) THEN - STEPB=(UPPER(IBASIC)-X(IBASIC))/DP - ELSE - STEPB=-X(IBASIC)/DP - ENDIF - IF(STEPB.LT.STEP) STEP=STEPB - IF(X(J).LT.STEP) STEP=X(J) - IF(STEP.GE.1.0D+10) THEN - WRITE(BUFFER,1301) - 1301 FORMAT(1X,'SMPLX: Problem is unbounded.') - CALL MYWRT(IOERR,BUFFER) - STOP - ENDIF -C -C Compute the objective improvement (look ahead). - DP=-RDCOST(J)*STEP - IF(MSGLEV.LE.2) GO TO 1303 - WRITE(BUFFER,1302) J,RDCOST(J),STEP,DP - 1302 FORMAT(1X,'UB: cl=',I6,' rc=',D16.8, - X ' step=',D12.5,' impr=',D16.8) - CALL MYWRT(IOERR,BUFFER) - 1303 CONTINUE - IF(DP.LT.DBEST) THEN - DBEST=DP - SBEST=STEP - JBEST=J - ISTEP=-1 - ENDIF - ENDIF -C - - 1500 CONTINUE - IF(MSGLEV.LE.2) GO TO 1502 - WRITE(BUFFER,1501) ISTEP,JBEST,RDCOST(JBEST),DBEST - 1501 FORMAT(1X,'Istp=',I2,' Jbst=',I6,' rc=',D16.8,' impr=',D16.8) - CALL MYWRT(IOERR,BUFFER) - 1502 CONTINUE -C -C -C Here to make step. - IF(DBEST.GE.-OPTTOL) GO TO 2100 - IF(ISTEP.EQ.-1) SBEST=-SBEST - X(IBASIC)=X(IBASIC)-SBEST*COEFF(JBEST)/COEFF(IBASIC) - X(JBEST)=X(JBEST)+SBEST - IF(DABS(X(JBEST)-UPPER(JBEST)).GE.SMALLA.AND. - X DABS(X(JBEST)).GE.SMALLA) THEN -C -C Basis change. - IBASIC=JBEST - ENDIF -C -C -C -C -C -C -C End of main loop. - 2000 GO TO 1000 - 2100 CONTINUE -C - IF(MSGLEV.LE.1) GO TO 2102 - WRITE(BUFFER,2101) ITER-1 - 2101 FORMAT(1X,'SMPLX: Optimum found after',I4,' iteration(s).') - CALL MYWRT(IOERR,BUFFER) - 2102 CONTINUE -C -C - RETURN -C -C -C *** LAST CARD OF (SMPLX) *** - END //GO.SYSIN DD hopdm.src/smplx.f echo hopdm.src/solaat.f 1>&2 sed >hopdm.src/solaat.f <<'//GO.SYSIN DD hopdm.src/solaat.f' 's/^-//' -C***************************************************************** -C *** SOLAAT ... SOLVE EQUATION WITH A*THETA*Atransp *** -C***************************************************************** -C - SUBROUTINE SOLAAT(LCOEFF,LCLPTS,LRWNBS,LDIAG, - X MAXNZL,MAXM,M,COLUMN,RHS,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXNZL,MAXM,M,IOERR - DOUBLE PRECISION LCOEFF(*),LDIAG(MAXM) - DOUBLE PRECISION COLUMN(MAXM),RHS(MAXM) - INTEGER*4 LCLPTS(MAXM+1) -C -C *** The following array can be half-length integer. - INTEGER*2 LRWNBS(MAXNZL) -C -C -C *** LOCAL VARIABLES - INTEGER*4 IROW -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C MAXM Maximum row dimension of the LP constraint matrix. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C LCOEFF Off-diagonal nonzero coefficients of Cholesky matrix. -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C LDIAG Diagonal elements of Cholesky factor. -C RHS Right-hand-side of the equation. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C COLUMN Solution of the equation (A*THETA*Atransp) * X = RHS. -C -C WORK ARRAYS: -C NONE -C -C -C *** SUBROUTINES CALLED: -C SOLVL,SOLVLT -C -C -C *** PURPOSE: -C This routine solves the equation with A*THETA*Atransp. -C It uses the Cholesky decomposition L*D*Ltransp -C of the above matrix. -C -C -C *** NOTES: -C 1. RHS array is destroyed by this routine. -C 2. The solution is devided into three phases: -C (i) L * X1 = RHS (SOLVL routine) -C (ii) D * X2 = X1 -C (iii) Ltransp * COLUMN = X2 (SOLVLT routine) -C -C -C *** REFERENCES: -C Duff I.S., Erisman A.M., Reid J.K. (1989). Direct methods -C for sparse matrices, Clarendon Press, Oxford 1989, -C chapter 6. -C Gondzio J. (1993). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization 27, pp. 121-140. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: April 15, 1991 -C Last modified: November 8, 1993 -C -C -C -C *** BODY OF (SOLAAT) *** -C -C Solve the equation L * X1 = RHS -C (save X1 in COLUMN array). - CALL SOLVL(LCOEFF,LCLPTS,LRWNBS, - X MAXNZL,MAXM,M,COLUMN,RHS,IOERR) -C -C Solve the equation D * X2 = X1 -C (save X2 in RHS array). - DO 300 IROW=1,M - RHS(IROW)=COLUMN(IROW)/LDIAG(IROW) - 300 CONTINUE -C -C Solve the equation Ltransp * COLUMN = X2 -C (COLUMN array contains the solution). - CALL SOLVLT(LCOEFF,LCLPTS,LRWNBS, - X MAXNZL,MAXM,M,COLUMN,RHS,IOERR) -C - RETURN -C -C *** LAST CARD OF (SOLAAT) *** - END //GO.SYSIN DD hopdm.src/solaat.f echo hopdm.src/solvl.f 1>&2 sed >hopdm.src/solvl.f <<'//GO.SYSIN DD hopdm.src/solvl.f' 's/^-//' -C************************************************************ -C *** SOLVL ... SOLVE EQUATION WITH THE FACTOR L *** -C************************************************************ -C - SUBROUTINE SOLVL(LCOEFF,LCLPTS,LRWNBS, - X MAXNZL,MAXM,M,COLUMN,RHS,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXNZL,MAXM,M,IOERR - DOUBLE PRECISION LCOEFF(*),COLUMN(MAXM),RHS(MAXM) - INTEGER*4 LCLPTS(MAXM+1) -C -C *** The following array can be half-length integer. - INTEGER*2 LRWNBS(MAXNZL) -C -C -C *** LOCAL VARIABLES - INTEGER*4 IROW,IX,JCOL,KBEG,KEND,K,LENCOL - DOUBLE PRECISION DP -C -C -C *** COMMON ARREAS -C Cholesky factorization parameters. - COMMON /CHFCT/ CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN,IDNSRW - DOUBLE PRECISION CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN - INTEGER*4 IDNSRW -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C MAXM Maximum row dimension of the LP constraint matrix. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C LCOEFF Off-diagonal nonzero coefficients of Cholesky matrix. -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C RHS Right-hand-side of the equation. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C COLUMN Solution of the equation L * X = RHS. -C -C WORK ARRAYS: -C NONE -C -C -C *** SUBROUTINES CALLED: -C DAXPY -C -C -C *** PURPOSE: -C This routine solves equation with the Cholesky factor L. -C -C -C *** NOTES: -C The lower right corner of the Cholesky factor is stored -C as a dense matrix (double addressing is thus avoided). -C IDNSRW (from CHFACT common block) is a number of the first -C row of a dense window. -C -C -C -C *** REFERENCES: -C Duff I.S., Erisman A.M., Reid J.K. (1989). Direct methods -C for sparse matrices, Clarendon Press, Oxford 1989, -C chapter 6. -C Gondzio J. (1993). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization 27, pp. 121-140. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: April 15, 1991 -C Last modified: November 8, 1993 -C -C -C -C *** BODY OF (SOLVL) *** -C -C -C -C COPY RHS onto COLUMN. - DO 100 JCOL=1,M - COLUMN(JCOL)=RHS(JCOL) - 100 CONTINUE -C -C -C -C Solve the equation L * X = COLUMN -C (save X in COLUMN array). -C -C Begin in sparse mode. - DO 300 JCOL=1,IDNSRW-1 - KBEG=LCLPTS(JCOL) - KEND=LCLPTS(JCOL+1)-1 - IF(KBEG.GT.KEND) GO TO 300 - DO 200 K=KBEG,KEND - IROW=LRWNBS(K) - COLUMN(IROW)=COLUMN(IROW)-COLUMN(JCOL)*LCOEFF(K) - 200 CONTINUE - 300 CONTINUE -C -C Switch to dense mode. - IX=1 - DO 400 JCOL=IDNSRW,M - KBEG=LCLPTS(JCOL) - LENCOL=LCLPTS(JCOL+1)-KBEG - DP=-COLUMN(JCOL) -C CALL DAXPY(LCOEFF(KBEG),COLUMN(JCOL+1),LENCOL,DP) - call daxpy(LENCOL,DP,LCOEFF(KBEG),ix,COLUMN(JCOL+1),ix) - 400 CONTINUE -C -C -C - RETURN -C -C -C *** LAST CARD OF (SOLVL) *** - END //GO.SYSIN DD hopdm.src/solvl.f echo hopdm.src/solvlt.f 1>&2 sed >hopdm.src/solvlt.f <<'//GO.SYSIN DD hopdm.src/solvlt.f' 's/^-//' -C***************************************************************** -C *** SOLVLT ... SOLVE EQUATION WITH THE TRANSPOSE OF L *** -C***************************************************************** -C - SUBROUTINE SOLVLT(LCOEFF,LCLPTS,LRWNBS, - X MAXNZL,MAXM,M,COLUMN,RHS,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXNZL,MAXM,M,IOERR - DOUBLE PRECISION LCOEFF(*),COLUMN(MAXM),RHS(MAXM) - INTEGER*4 LCLPTS(MAXM+1) -C -C *** The following array can be half-length integer. - INTEGER*2 LRWNBS(MAXNZL) -C -C -C *** LOCAL VARIABLES - INTEGER*4 IROW,IX,JCOL,KBEG,KEND,K,LENCOL - DOUBLE PRECISION DP -C -C -C *** FUNCTIONS - DOUBLE PRECISION DDOT -C -C -C *** COMMON ARREAS -C Cholesky factorization parameters. - COMMON /CHFCT/ CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN,IDNSRW - DOUBLE PRECISION CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN - INTEGER*4 IDNSRW -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C MAXM Maximum row dimension of the LP constraint matrix. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C LCOEFF Off-diagonal nonzero coefficients of Cholesky matrix. -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C RHS Right-hand-side of the equation. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C COLUMN Solution of the equation (Ltransp) * X = RHS. -C -C WORK ARRAYS: -C NONE -C -C -C *** SUBROUTINES CALLED: -C DDOT -C -C -C *** PURPOSE: -C This routine solves equation with the transpose -C of the Cholesky factor L. -C -C -C *** NOTES: -C The lower right corner of the Cholesky factor is stored -C as a dense matrix (double addressing is thus avoided). -C IDNSRW (from CHFACT common block) is a number of the first -C row of a dense window. -C -C -C -C *** REFERENCES: -C Duff I.S., Erisman A.M., Reid J.K. (1989). Direct methods -C for sparse matrices, Clarendon Press, Oxford 1989, -C chapter 6. -C Gondzio J. (1993). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization 27, pp. 121-140. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: April 15, 1991 -C Last modified: November 8, 1993 -C -C -C -C *** BODY OF (SOLVLT) *** -C -C -C -C Solve the equation Ltransp * X = RHS -C (save X in COLUMN array). -C -C Begin in dense mode. - IX=1 - DO 300 JCOL=M,IDNSRW,-1 - KBEG=LCLPTS(JCOL) - LENCOL=LCLPTS(JCOL+1)-KBEG -C CALL DDOT(LCOEFF(KBEG),COLUMN(JCOL+1),LENCOL,DP) - DP = ddot(LENCOL,LCOEFF(KBEG),ix,COLUMN(JCOL+1),ix) - COLUMN(JCOL)=RHS(JCOL)-DP - 300 CONTINUE -C -C Switch to sparse mode. - DO 500 JCOL=IDNSRW-1,1,-1 - COLUMN(JCOL)=RHS(JCOL) - KBEG=LCLPTS(JCOL) - KEND=LCLPTS(JCOL+1)-1 - IF(KBEG.GT.KEND) GO TO 500 - DO 400 K=KBEG,KEND - IROW=LRWNBS(K) - COLUMN(JCOL)=COLUMN(JCOL)-COLUMN(IROW)*LCOEFF(K) - 400 CONTINUE - 500 CONTINUE -C -C -C - RETURN -C -C -C *** LAST CARD OF (SOLVLT) *** - END //GO.SYSIN DD hopdm.src/solvlt.f echo hopdm.src/split.f 1>&2 sed >hopdm.src/split.f <<'//GO.SYSIN DD hopdm.src/split.f' 's/^-//' -C************************************************************ -C **** SPLIT ... SPLITTING DENSE COLUMNS OF A **** -C************************************************************ -C - SUBROUTINE SPLIT(MAXM,MAXN,MAXNZA,M,N,NSTRCT, - X LNHIST,MXHIST,INHIST,DPHIST, - X ACOEFF,CLPNTS,RWNMBS,RWHEAD,RWLINK,CLNMBS,LENCOL, - X SPLCOL,ROWLEN,CSPLIT,LENCLA,LENCLB, - X MAXCOL,SVIROW,SVRELT,IROW,RELT, - X P,Q,CLNAME,STAVAR,PRLVAR,COBJ,UPBND,LOBND, - X RWNAME,STAROW,RWSTAT,RANGES,RHS,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXM,MAXN,MAXNZA,M,N,NSTRCT - INTEGER*4 LNHIST,MXHIST,MAXCOL,IOERR - INTEGER*2 INHIST(MXHIST) - DOUBLE PRECISION DPHIST(MXHIST) - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM+1),RWLINK(MAXNZA) - INTEGER*4 SVIROW(MAXM),IROW(MAXM),LENCLA(MAXN),LENCLB(MAXN) - CHARACTER*8 RWNAME(MAXM),CLNAME(MAXN) - DOUBLE PRECISION ACOEFF(MAXNZA),SVRELT(MAXM),RELT(MAXM) - DOUBLE PRECISION P(MAXM),Q(MAXM),RANGES(MAXM),RHS(MAXM) - DOUBLE PRECISION PRLVAR(MAXN),COBJ(MAXN),UPBND(MAXN),LOBND(MAXN) -C -C *** The following arrays can be half-length integer. - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) - INTEGER*2 STAVAR(MAXN),STAROW(MAXM),RWSTAT(MAXM) - INTEGER*2 CSPLIT(MAXM),SPLCOL(MAXM),ROWLEN(MAXM) -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,IDUMMY,IR,IRW,INEWRW,IX,ICOLS,IND,IPARTS - INTEGER*4 K,KBEG,KEND,KNEW,KBEGNW,NELTS,NLEFT - INTEGER*4 IRWADD,KRWADD,KADDED,ISPLIT,JSPLIT,JCOLMN - INTEGER*4 LNCOL,COLLEN,LNMIN,LNMAX,MAXLEN - INTEGER*4 J,JLAST,JCOL,JPOS,JCOLNW,ISIGMA,BSTSIG,IPENAL - INTEGER*4 BESTCL,BESTLN,NRSPLT,SVCLLN,MOVE,MVCOL - INTEGER*4 MNEW,NNEW,NSTNEW,NZNEW - DOUBLE PRECISION BIG - CHARACTER*8 TEXT - CHARACTER*100 BUFFER -C -C -C *** COMMON ARREAS -C Markers for linking rows. - COMMON /ICGRAD/ MSPLIT(100000) - INTEGER*2 MSPLIT -C -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C N Number of columns of the LP constraint matrix. -C NSTRCT Number of structural variables (excluding slacks, surplus -C and artificials). -C LNHIST Length of the PRE_SOLVE history list; -C MXHIST Maximum number of entries in the PRE_SOLVE history list. -C INHIST Integer PRE_SOLVE history information. -C DPHIST Double precision PRE_SOLVE history information. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C LENCOL Lengths of columns of matrix A. -C MAXCOL Threshold length for columns to be split. -C P LOWER bounds on shadow prices (dual variables). -C Q UPPER bounds on shadow prices (dual variables). -C CLNAME Array of column names (unordered). -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C UPBND Array of upper bounds. Note that the upper bound -C is changed when the variable has a lower bound. -C LOBND Array of lower bounds. -C COBJ Array of cost coefficients (objective function). -C RWNAME Array of row names (increasing order sort). -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C RWSTAT Array of row types (sort as before): -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 row type is objective or free. -C RANGES Array of constraint ranges. -C RHS LP right-hand-side. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C New LP constraint matrix with all long columns split. -C NSTRCT Number of structural variables (excluding slacks, surplus -C and artificials). -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C -C WORK ARRAYS: -C CSPLIT Work array for handling the list of columns to split. -C LENCLA Work array for temporary handling the length of columns. -C LENCLB Work array for temporary handling the length of columns. -C SVIROW Work array used to save the contents of IROW array. -C SVRELT Work array used to save the contents of RELT array. -C SPLCOL Work array for splitting mechanism. -C ROWLEN Handles the number of nonzero etries of a given row -C that appear in long columns. -C IROW Integer work array. -C RELT Double precision work array. -C -C -C *** SUBROUTINES CALLED: -C MYWRT -C -C -C *** PURPOSE: -C This routine splits all long columns of the LP constraint -C matrix into the shorter ones. Long columns are those which -C have at least MAXCOL nonzero entries. -C -C -C *** NOTES: -C 1. This routine depends on data structures for handling A. -C 2. It should not be called if the LP problem contains FREE -C variables or if singleton FREE columns are eliminated. -C -C -C *** REFERENCES: -C Gondzio J. (1992). Splitting dense columns of the constraint -C matrix in interior point methods for large scale linear -C programming, Optimization 24, pp. 285-297. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: October 12, 1990 -C Last modified: February 25, 1995 -C -C -C -C *** BODY OF (SPLIT) *** -C -C -C - MNEW=M - NNEW=N - NZNEW=CLPNTS(N+1)-1 - KRWADD=0 - BIG=1.0D+30 -C -C -C Initialize markers for linking rows. - DO 100 IR=1,MAXM - MSPLIT(IR)=0 - 100 CONTINUE -C -C -C -C -C -C Scan the whole matrix A and count the columns to be split. -C Split only columns with the number of nonzero entries that -C considerably exceeds MAXCOL. -C IRWADD is the number of rows that will be bordered to A. -C NRSPLT is the number of columns to be split. - IRWADD=0 - NRSPLT=0 - MAXLEN=MAXCOL+MAXCOL/5 - DO 150 J=1,N -C -C Omit fixed columns. -C Check if column J is to be split. - IF(STAVAR(J).GE.6) GO TO 150 - IF(LENCOL(J).LE.MAXLEN) GO TO 150 -C -C Save the column as the one to be split. - NRSPLT=NRSPLT+1 - CSPLIT(NRSPLT)=J -C WRITE(BUFFER,151) J,CLNAME(J),LENCOL(J) -C 151 FORMAT(1x,'column ',i5,2x,a8,' (len=',i4,') will be split.') -C CALL MYWRT(IOERR,BUFFER) - INEWRW=(LENCOL(J)-1)/MAXCOL - IRWADD=IRWADD+INEWRW - 150 CONTINUE -C -C -C -C Check if there are any columns to be split. - MNEW=M+IRWADD - NNEW=N+IRWADD - NSTNEW=NSTRCT+IRWADD - NZNEW=CLPNTS(N+1)-1+2*IRWADD - IF(NRSPLT.EQ.0) GO TO 2000 -C -C -C -C -C Scan the whole matrix A and check if there are any FREE -C variables in the LP problem. If so, then disable splitting. - DO 160 J=1,N - IF(STAVAR(J).LT.0) THEN - NRSPLT=0 - WRITE(BUFFER,161) - 161 FORMAT(1X,'SPLIT: Splitting disabled,', - X ' FREE variables present in the LP problem.') - CALL MYWRT(IOERR,BUFFER) - MNEW=M - NNEW=N - NSTNEW=NSTRCT - NZNEW=CLPNTS(N+1)-1 - GO TO 2000 - ENDIF - 160 CONTINUE -C -C -C -C -C Scan PRE_SOLVE history list and check if there were any -C singleton FREE variables eliminated. Disable splitting, if so. - DO 180 IX=1,LNHIST - IF(INHIST(IX).GT.0) THEN - NRSPLT=0 - WRITE(BUFFER,181) - 181 FORMAT(1X,'SPLIT: Splitting disabled,', - X ' singleton FREE variables were eliminated.') - CALL MYWRT(IOERR,BUFFER) - MNEW=M - NNEW=N - NSTNEW=NSTRCT - NZNEW=CLPNTS(N+1)-1 - GO TO 2000 - ENDIF - 180 CONTINUE -C -C -C -C -C -C -C -C -C -C -C Check if there is enough space to perform splitting. - IF(MNEW.GT.MAXM) GO TO 9000 - IF(NNEW.GT.MAXN) GO TO 9000 - IF(NZNEW.GT.MAXNZA) GO TO 9000 -C -C -C - WRITE(BUFFER,201) - 201 FORMAT(1X,'SPLIT: Splitting starts.') - CALL MYWRT(0,BUFFER) -C -C -C -C Initialize. - DO 200 IR=1,MAXM - RWHEAD(IR)=0 - SPLCOL(IR)=0 - ROWLEN(IR)=0 - 200 CONTINUE -C -C -C -C Scan the whole matrix A and expand data structures -C in such a way that empty cells are left for elements -C added in linking rows that are bordered to A. -C Row linked lists are created for short columns. -C ROWLEN(IRW) handles the number of nonzero entries -C of row IRW that appear in long columns. -C MVCOL determines how far a given column must be moved. -C MOVE determines how far its elements must be moved. -C KRWADD is the numer of rows (and columns) added. - MVCOL=IRWADD - MOVE=2*IRWADD - KRWADD=0 - JLAST=N - CLPNTS(N+MVCOL+1)=CLPNTS(N+1)+MOVE - DO 300 ISPLIT=NRSPLT,1,-1 - JSPLIT=CSPLIT(ISPLIT) -C -C Move all columns with indices JSPLIT+1,JSPLIT+2,...,JLAST -C to their new positions. Save their new positions in LENCLA. - DO 250 JCOL=JLAST,JSPLIT+1,-1 - KBEG=CLPNTS(JCOL) - KEND=KBEG+LENCOL(JCOL)-1 - KBEGNW=KBEG+MOVE - JCOLNW=JCOL+MVCOL - LENCLA(JCOL)=JCOLNW - DO 220 K=KEND,KBEG,-1 - KNEW=K+MOVE - ACOEFF(KNEW)=ACOEFF(K) - RWNMBS(KNEW)=RWNMBS(K) - 220 CONTINUE -C -C Update the row linked lists of short columns. -C Omit the fixed columns. - IF(STAVAR(JCOL).GE.6) GO TO 240 - DO 230 K=KEND,KBEG,-1 - KNEW=K+MOVE - CLNMBS(KNEW)=JCOLNW - IRW=RWNMBS(KNEW) - RWLINK(KNEW)=RWHEAD(IRW) - RWHEAD(IRW)=KNEW - 230 CONTINUE - 240 CLPNTS(JCOLNW)=KBEGNW - CLNAME(JCOLNW)=CLNAME(JCOL) - LENCOL(JCOLNW)=LENCOL(JCOL) - COBJ(JCOLNW)=COBJ(JCOL) - STAVAR(JCOLNW)=STAVAR(JCOL) - PRLVAR(JCOLNW)=PRLVAR(JCOL) - UPBND(JCOLNW)=UPBND(JCOL) - LOBND(JCOLNW)=LOBND(JCOL) - 250 CONTINUE -C -C Add new rows and new columns to a constraint matrix. - COLLEN=LENCOL(JSPLIT) - INEWRW=(COLLEN-1)/MAXCOL -C -C Define new row and column names. - DO 260 I=1,INEWRW - KADDED=KRWADD+I - WRITE(TEXT,251) KADDED - 251 FORMAT(I8) - TEXT(1:5)='SPLRW' - IRW=M+KADDED - RWNAME(IRW)=TEXT - MSPLIT(IRW)=1 - P(IRW)=-BIG - Q(IRW)=BIG - RHS(IRW)=0.0 - RANGES(IRW)=0.0 - RWSTAT(IRW)=1 - STAROW(IRW)=1 - TEXT(4:5)='CL' - JCOL=JCOLNW-I - CLNAME(JCOL)=TEXT - LENCOL(JCOL)=0 - COBJ(JCOL)=0.0 - STAVAR(JCOL)=STAVAR(JSPLIT) - PRLVAR(JCOL)=PRLVAR(JSPLIT) - UPBND(JCOL)=UPBND(JSPLIT) - LOBND(JCOL)=LOBND(JSPLIT) - 260 CONTINUE -C -C Move the column to be split to its new position. -C Leave empty cells for nonzero elements that will -C later be added by the splitting mechanism. -C Save its new position in LENCLA. - MVCOL=MVCOL-INEWRW - MOVE=MOVE-2*INEWRW - KBEG=CLPNTS(JSPLIT) - KEND=KBEG+LENCOL(JSPLIT)-1 - KBEGNW=KBEG+MOVE - JCOLNW=JSPLIT+MVCOL - LENCLA(JSPLIT)=JCOLNW - DO 280 K=KEND,KBEG,-1 - KNEW=K+MOVE - ACOEFF(KNEW)=ACOEFF(K) - RWNMBS(KNEW)=RWNMBS(K) -C -C Update the ROWLEN array. ROWLEN(IRW) indicates the number -C of nonzero etries of row IRW that appear in long columns. - IRW=RWNMBS(KNEW) - ROWLEN(IRW)=ROWLEN(IRW)+1 - 280 CONTINUE - CLPNTS(JCOLNW)=KBEGNW - CLNAME(JCOLNW)=CLNAME(JSPLIT) - LENCOL(JCOLNW)=LENCOL(JSPLIT) - COBJ(JCOLNW)=COBJ(JSPLIT) - STAVAR(JCOLNW)=STAVAR(JSPLIT) - PRLVAR(JCOLNW)=PRLVAR(JSPLIT) - UPBND(JCOLNW)=UPBND(JSPLIT) - LOBND(JCOLNW)=LOBND(JSPLIT) -C -C Update the number of added rows. -C Save the new index of column to be split. - KRWADD=KRWADD+INEWRW - CSPLIT(ISPLIT)=JCOLNW - JLAST=JSPLIT-1 -C - 300 CONTINUE -C -C -C -C Update the row linked lists of short columns -C (add all columns with indices 1,2,...,JLAST). -C Save their new positions in LENCLA. -C Omit the fixed columns. - DO 350 JCOL=JLAST,1,-1 - LENCLA(JCOL)=JCOL - IF(STAVAR(JCOL).GE.6) GO TO 350 - KBEG=CLPNTS(JCOL) - KEND=KBEG+LENCOL(JCOL)-1 - DO 330 K=KEND,KBEG,-1 - CLNMBS(K)=JCOL - IRW=RWNMBS(K) - RWLINK(K)=RWHEAD(IRW) - RWHEAD(IRW)=K - 330 CONTINUE - 350 CONTINUE -C -C -C -C Update the PRE_SOLVE history list (column numbers have changed). - DO 380 IX=1,LNHIST - J=-INHIST(IX) - INHIST(IX)=-LENCLA(J) -C WRITE(BUFFER,381) IX,J,LENCLA(J) -C 381 FORMAT(1X,'ientry=',I6,' col=',I6,' becomes col=',I6) -C CALL MYWRT(IOERR,BUFFER) - 380 CONTINUE -C -C -C -C -C -C -C -C Here to perform splitting. -C Initialize IRWADD again. - IRWADD=0 -C -C -C Select the shortest column from those to be split. - 400 BESTCL=0 - BESTLN=32000 - IND=0 - DO 420 I=1,NRSPLT - JCOL=CSPLIT(I) - IF(JCOL.LE.0) GO TO 420 - COLLEN=LENCOL(JCOL) - IF(COLLEN.GE.BESTLN) GO TO 420 - BESTCL=JCOL - BESTLN=COLLEN - IND=I - 420 CONTINUE - IF(BESTCL.EQ.0) GO TO 2000 -C -C -C Get the column to be split from the data structures. - JCOLMN=BESTCL - CSPLIT(IND)=0 -C -C -C -C Logic for splitting. -C First, save the long column. -C Set up LENCLB array. - DO 440 I=1,NNEW - LENCLB(I)=0 - 440 CONTINUE - COLLEN=LENCOL(JCOLMN) - KBEG=CLPNTS(JCOLMN)-1 - DO 480 I=1,COLLEN - K=KBEG+I - IRW=RWNMBS(K) - SVIROW(I)=IRW - SVRELT(I)=ACOEFF(K) - SPLCOL(IRW)=I - JPOS=RWHEAD(IRW) - 460 IF(JPOS.EQ.0) GO TO 480 - JCOL=CLNMBS(JPOS) - LENCLB(JCOL)=LENCLB(JCOL)+1 - JPOS=RWLINK(JPOS) - GO TO 460 - 480 CONTINUE - SVCLLN=COLLEN - INEWRW=(COLLEN-1)/MAXCOL - MAXLEN=COLLEN/(INEWRW+1) -C -C *** DEBUGGING -C WRITE(BUFFER,461) JCOLMN,LENCOL(JCOLMN),MAXLEN -C 461 FORMAT(1X,'col=',I6,' ln=',I6,' is split, MAXLEN=',I6) -C CALL MYWRT(IOERR,BUFFER) -C - MAXLEN=MAXLEN+MAXLEN/3 - IF(MAXLEN.GE.MAXCOL+MAXCOL/3) MAXLEN=MAXCOL+MAXCOL/3 -C -C -C *** DEBUGGING -C WRITE(BUFFER,481) CLNAME(JCOLMN),JCOLMN,COLLEN -C 481 FORMAT(1X,'var= ',A8,' (col=',I4,', len=',I4,') is split.') -C CALL MYWRT(IOERR,BUFFER) -C DO 483 I=1,COLLEN -C WRITE(BUFFER,482) I,SVIROW(I),SVRELT(I) -C 482 FORMAT(1X,'I=',I5,' SVIROW=',I5,' SVRELT=',E10.4) -C CALL MYWRT(IOERR,BUFFER) -C 483 CONTINUE -C -C -C Add new (split) columns to the data structures. - ICOLS=0 -C -C -C -C -C -C Main loop begins here. - DO 1000 IDUMMY=1,INEWRW+1 - BESTCL=0 - BESTLN=0 - NELTS=0 - LNMIN=(INEWRW-IDUMMY)*MAXCOL - LNMAX=LNMIN+MAXCOL - IPARTS=INEWRW+2-IDUMMY -C -C -C Check how many nonzero elements in the long columns left. -C If their number is less than MAXCOL, then the sparsity -C pattern analysis is unnecessary. - LNCOL=0 - DO 520 IND=1,SVCLLN - IRW=SVIROW(IND) - IF(SPLCOL(IRW).LE.0) GO TO 520 - LNCOL=LNCOL+1 - RELT(LNCOL)=SVRELT(IND) - IROW(LNCOL)=SVIROW(IND) - 520 CONTINUE - COLLEN=LNCOL - NELTS=LNCOL - IF(LNCOL.LE.MAXCOL) GO TO 580 -C -C Restore zero value of LNCOL. - LNCOL=0 -C -C -C Look for the column with maximum entries in rows -C in which the column to be split has also nonzero elements. -C BESTCL is the index of the best column found by now; -C BESTLN is the number of common elements. - BESTCL=0 - BESTLN=0 - DO 540 JCOL=1,NNEW - IF(LENCLB(JCOL).LE.BESTLN) GO TO 540 - BESTCL=JCOL - BESTLN=LENCLB(JCOL) - 540 CONTINUE -C -C Check if there are still elements left in the long column. - IF(NELTS.EQ.0) GO TO 1100 - IF(BESTCL.GT.0) GO TO 560 - LNCOL=0 - GO TO 700 -C -C Extract the partitioned column from the long one -C and set up LENCLA array. - 560 JCOL=BESTCL - COLLEN=LENCOL(JCOL) - KBEG=CLPNTS(JCOL)-1 - DO 570 I=1,COLLEN - K=KBEG+I - IROW(I)=RWNMBS(K) - RELT(I)=ACOEFF(K) - 570 CONTINUE - 580 LNCOL=0 - DO 600 I=1,NNEW - LENCLA(I)=0 - 600 CONTINUE - DO 640 IX=1,COLLEN - IR=IROW(IX) - JCOL=SPLCOL(IR) - IF(JCOL.GT.0) THEN - LNCOL=LNCOL+1 - RELT(LNCOL)=SVRELT(JCOL) - IROW(LNCOL)=IR - SPLCOL(IR)=-JCOL - JPOS=RWHEAD(IR) - 620 IF(JPOS.EQ.0) GO TO 640 - JCOL=CLNMBS(JPOS) - LENCLA(JCOL)=LENCLA(JCOL)+1 - LENCLB(JCOL)=LENCLB(JCOL)-1 - JPOS=RWLINK(JPOS) - GO TO 620 - ENDIF - 640 CONTINUE -C -C -C Analyse whether it is profitable to add more elements -C to the column. An element is then looked for that can -C be moved from the set of unsplit elements to the set -C of already split elements with the mininmum penalty. -C To break ties, a number of nonzero entries that are -C in the given row and in the columns to be split is -C counted and its largest possible value is selected. -C BSTSIG is the penalty of the best row found by now; -C BESTLN is the length of the best row found by now; -C IRW is the index of the best row found by now. - 700 BSTSIG=1000000 - BESTLN=0 - IRW=0 - DO 800 IX=1,SVCLLN - IR=SVIROW(IX) - JCOL=SPLCOL(IR) - IF(JCOL.LT.0) GO TO 800 - ISIGMA=0 - JPOS=RWHEAD(IR) - 720 IF(JPOS.EQ.0) GO TO 740 - JCOL=CLNMBS(JPOS) - ISIGMA=ISIGMA+LENCLB(JCOL)-LENCLA(JCOL)-1 - JPOS=RWLINK(JPOS) - GO TO 720 - 740 IF(ISIGMA-BSTSIG) 780,760,800 - 760 IF(ROWLEN(IR).LE.BESTLN) GO TO 800 - 780 IRW=IR - BSTSIG=ISIGMA - BESTLN=ROWLEN(IR) - 800 CONTINUE - IF(IRW.EQ.0) GO TO 860 -C -C If the number of elements left is too large, then (no metter -C how large the penalty is) the element has to be added. - NLEFT=NELTS-LNCOL - IF(NLEFT.GT.LNMAX) GO TO 820 -C -C If the number of elements that would rest after -C the addition of the one selected now is too small, -C then the element can not be added. - IF(NLEFT.LE.LNMIN+1) GO TO 860 -C -C Do not let the number of elements in a column -C to considerably exceed MAXCOL. - IF(LNCOL.GE.MAXLEN) GO TO 860 -C -C -C Now check if the addition of the element selected -C improves total penalty indicator. If the change of -C penalty is positive (which means it is better -C not to add the element), then end up the column. - IPENAL=(IPARTS*LNCOL-NELTS)/(IPARTS-1)+BSTSIG - IF(IPENAL.GT.0) GO TO 860 -C -C -C *** DEBUGGING -C WRITE(BUFFER,821) LNCOL+1,BSTSIG,IPENAL -C 821 FORMAT(1X,'Col. augmentation (elt=',I5,'), penalty=',I6, -C X ', tot. penalty=',I5) -C CALL MYWRT(IOERR,BUFFER) -C -C - 820 LNCOL=LNCOL+1 - JCOL=SPLCOL(IRW) - RELT(LNCOL)=SVRELT(JCOL) - IROW(LNCOL)=SVIROW(JCOL) - SPLCOL(IRW)=-JCOL -C -C Update LENCLA and LENCLB arrays. - JPOS=RWHEAD(IRW) - 840 IF(JPOS.EQ.0) GO TO 700 - JCOL=CLNMBS(JPOS) - LENCLA(JCOL)=LENCLA(JCOL)+1 - LENCLB(JCOL)=LENCLB(JCOL)-1 - JPOS=RWLINK(JPOS) - GO TO 840 -C -C Augment the column and add it to the data structure. - 860 COLLEN=LNCOL - ICOLS=ICOLS+1 - IF(ICOLS.EQ.1) THEN - COLLEN=COLLEN+1 - IROW(COLLEN)=M+IRWADD+ICOLS - RELT(COLLEN)=+1.0 - ELSE - IF(ICOLS.LE.INEWRW) THEN - COLLEN=COLLEN+2 - IROW(COLLEN-1)=M+IRWADD+ICOLS-1 - RELT(COLLEN-1)=-1.0 - IROW(COLLEN)=M+IRWADD+ICOLS - RELT(COLLEN)=+1.0 - ELSE - COLLEN=COLLEN+1 - IROW(COLLEN)=M+IRWADD+ICOLS-1 - RELT(COLLEN)=-1.0 - ENDIF - ENDIF -C -C -C Add the new column to the data structures. - KBEG=CLPNTS(JCOLMN) - DO 880 I=1,COLLEN - K=KBEG+I-1 - ACOEFF(K)=RELT(I) - IRW=IROW(I) - RWNMBS(K)=IRW - CLNMBS(K)=JCOLMN - RWLINK(K)=RWHEAD(IRW) - RWHEAD(IRW)=K - ROWLEN(IRW)=ROWLEN(IRW)-1 - 880 CONTINUE - IF(ICOLS.LE.INEWRW) CLPNTS(JCOLMN+1)=KBEG+COLLEN - LENCOL(JCOLMN)=COLLEN - JCOLMN=JCOLMN+1 -C -C -C -C -C - ISIGMA=(NELTS-LNCOL-1)/MAXCOL -C -C -C *** DEBUGGING -C The following two lines have to be uncommented to help -C the 'xlf' compiler of IBM POWER PC computer to produce -C correct code for a -O option. - WRITE(BUFFER,881) JCOLMN,COLLEN - 881 FORMAT(1X,'SPLIT: new variable=',I6,' of lenght=',I6) -C CALL MYWRT(IOERR,BUFFER) -C DO 883 I=1,COLLEN -C WRITE(BUFFER,882) I,IROW(I),RELT(I) -C 882 FORMAT(1X,'I=',I6,' IROW=',I6,' RELT=',E10.4) -C CALL MYWRT(IOERR,BUFFER) -C 883 CONTINUE -C -C -C -C -C End of main loop. - 1000 CONTINUE -C -C -C -C -C Restore zero value of SPLCOL array. - 1100 DO 1120 I=1,SVCLLN - IRW=SVIROW(I) - SPLCOL(IRW)=0 - 1120 CONTINUE -C -C -C Update the number of added rows. - IRWADD=IRWADD+INEWRW - GO TO 400 -C -C -C -C -C Restore the number of structural variables. - 2000 IF(NRSPLT.EQ.0) THEN -C - WRITE(BUFFER,2001) - 2001 FORMAT(1X,'SPLIT: There are no columns to split.') - CALL MYWRT(0,BUFFER) -C - ELSE -C - WRITE(BUFFER,2002) - 2002 FORMAT(1X,'SPLIT: Splitting completed.') - CALL MYWRT(0,BUFFER) -C -C Set the row linked lists (slack should be -C the first element of the list). - LNCOL=0 - DO 2200 I=1,MNEW - RWHEAD(I)=0 - 2200 CONTINUE - DO 2300 J=1,NNEW -C -C Omit FIXED variables. - IF(STAVAR(J).GE.6) GO TO 2300 - LNCOL=LNCOL+LENCOL(J) - KBEG=CLPNTS(J) - KEND=KBEG+LENCOL(J)-1 - DO 2250 K=KBEG,KEND - I=RWNMBS(K) - RWLINK(K)=RWHEAD(I) - CLNMBS(K)=J - RWHEAD(I)=K - 2250 CONTINUE - 2300 CONTINUE - ENDIF -C -C -C -C *** DEBUGGING -C IF(NRSPLT.EQ.0) GO TO 3000 -C DO 2420 I=1,MAXM -C ROWLEN(I)=0 -C2420 CONTINUE -C DO 2442 IRW=1,MNEW -C WRITE(BUFFER,2441) IRW,RWHEAD(IRW) -C2441 FORMAT(1X,'row=',I6,' rwhead=',I6) -C CALL MYWRT(IOERR,BUFFER) -C2442 CONTINUE -C DO 2460 JCOL=1,NNEW -C IF(STAVAR(JCOL).GE.6) GO TO 2460 -C IF(LENCOL(JCOL).LE.MAXCOL) GO TO 2460 -C LNCOL=LENCOL(JCOL) -C KBEG=CLPNTS(JCOL) -C KEND=KBEG+LENCOL(JCOL)-1 -C WRITE(BUFFER,2461) JCOL,LNCOL -C2461 FORMAT(1X,' SPLIT: column=',I5,' has length=',I5) -C CALL MYWRT(IOERR,BUFFER) -C DO 2463 K=KBEG,KEND -C WRITE(BUFFER,2462) K,ACOEFF(K),RWNMBS(K), -C X RWLINK(K),CLNMBS(K) -C2462 FORMAT(1X,' K=',I6,' elt=',D8.2,' row=',I6, -C X ' link=',I6,' col=',I6) -C CALL MYWRT(IOERR,BUFFER) -C2463 CONTINUE -C IF(LNCOL.GT.0) ROWLEN(LNCOL)=ROWLEN(LNCOL)+1 -C2460 CONTINUE -C MAXLEN=MNEW -C DO 2480 I=MNEW+1,1,-1 -C IF(ROWLEN(I).EQ.0) GO TO 2480 -C GO TO 2500 -C2480 CONTINUE -C2500 MAXLEN=I -C WRITE(IOERR,2501) MAXLEN -C2501 FORMAT(1X,'SPLIT: The longest column has ',I6,' elts.'/ -C X 1X,' Profile of the new matrix A:') -C WRITE(IOERR,2502) (ROWLEN(I),I=1,MAXLEN) -C2502 FORMAT(9X,10I6) -C ISIGMA=0 -C DO 2521 I=1,MAXLEN -C ISIGMA=ISIGMA+ROWLEN(I)*I -C2521 CONTINUE -C WRITE(IOERR,2522) ISIGMA -C2522 FORMAT(/1X,'SPLIT: Nonzeros of matrix A: ',I9) -C -C -C Take account of added linking rows. - 3000 M=MNEW - N=NNEW - NSTRCT=NSTNEW -C -C -C -C Write the MPS statistics. - IF(NRSPLT.GT.0) THEN - WRITE(BUFFER,3001) M - 3001 FORMAT(1X,'SPLIT: Constraints in the mps file: ',I9) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,3002) KRWADD - 3002 FORMAT(1X,' Splitting constraints added: ',I9) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,3003) N - 3003 FORMAT(1X,' Variables in the mps file: ',I9) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,3004) LNCOL - 3004 FORMAT(1X,' Nonzeros of matrix A: ',I9) - CALL MYWRT(IOERR,BUFFER) - ENDIF -C -C - RETURN -C -C -C -C Here if an error occurs. - 9000 WRITE(BUFFER,9001) - 9001 FORMAT(1X,'SPLIT ERROR: Please increase space for new A') - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9002) MNEW,MAXM - 9002 FORMAT(14X,'there will be',I10, - X ' constraints (current max. is',I10,')') - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9003) NNEW,MAXN - 9003 FORMAT(14X,'there will be',I10, - X ' variables (current max. is',I10,')') - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9004) NZNEW,MAXNZA - 9004 FORMAT(14X,'there will be',I10, - X ' nonzeros (current max. is',I10,')') - CALL ERRWRT(IOERR,BUFFER) - STOP -C -C -C -C *** LAST CARD OF (SPLIT) *** - END //GO.SYSIN DD hopdm.src/split.f echo hopdm.src/symfct.f 1>&2 sed >hopdm.src/symfct.f <<'//GO.SYSIN DD hopdm.src/symfct.f' 's/^-//' -C********************************************************** -C **** SYMFCT ... SYMBOLIC FACTORIZATION **** -C********************************************************** -C - SUBROUTINE SYMFCT(AATPAT,AATPNT, - X LCLPTS,LRWNBS,MAXNZL,MAXM,MAXN,MAXNZA,M, - X HEADER,LINKFD,LINKBK,MARKER,TEMP,STAVAR, - X CLPNTS,RWNMBS, - X RWHEAD,RWLINK,CLNMBS,LENCOL,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXNZL,MAXM,MAXN,MAXNZA,M,IOERR - INTEGER*4 AATPAT(MAXNZL),AATPNT(MAXM+1),LCLPTS(MAXM+1) - INTEGER*4 MARKER(MAXM),TEMP(MAXM) - INTEGER*4 CLPNTS(MAXN+1),RWHEAD(MAXM+1),RWLINK(MAXNZA) -C -C *** The following arrays can be half-length integer. - INTEGER*2 LRWNBS(MAXNZL),STAVAR(MAXN) - INTEGER*2 RWNMBS(MAXNZA),CLNMBS(MAXNZA),LENCOL(MAXN) - INTEGER*2 HEADER(MAXM),LINKFD(MAXM),LINKBK(MAXM) -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,IROW,IR,IRWACT,JCOL,K,KBEG,KEND,KX - INTEGER*4 LENOFL,LENOK,LENROW,TRIANG,NEXT,PREVS - DOUBLE PRECISION A0,A1,A2,DFLOPS - CHARACTER*100 BUFFER -C -C -C *** COMMON ARREAS -C Cholesky factorization parameters. - COMMON /CHFCT/ CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN,IDNSRW - DOUBLE PRECISION CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN - INTEGER*4 IDNSRW -C -C Additional Cholesky fact. parameters (interface to HYBRID). - COMMON /CHHYB/ RO,FLOPS,IREG,NZCHL,RTCD - DOUBLE PRECISION RO,FLOPS - INTEGER*4 IREG,NZCHL,RTCD -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C MAXM Maximum row dimension of the LP constraint matrix. -C MAXN Maximum column dimension of the LP constraint matrix. -C MAXNZA Maximum number of nonzeros of the LP constraint matrix. -C M Number of rows of the LP constraint matrix -C (and the dimension of A*Atransp). -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k free variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicate the position of the original variable. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C LENCOL Lengths of columns of matrix A. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C -C Additionally, through the CHHYB common block SYMFCT returns: -C NZCHL Overestimate of the number of nonzeros -C of Cholesky factor (important if RTCD = 0). -C RTCD Return code from the symbolic factorization: -C 0 SYMFCT failure; -C 1 SYMFCT success. -C FLOPS Flops required to compute the decomposition. -C -C WORK ARRAYS: -C AATPAT Triangular part of the sparsity pattern of A*Atransp -C handled as a collection of sparse row vectors -C (diagonal elements are excluded from the list). -C AATPNT Pointers to rows of A*Atransp. -C HEADER Header of the doubly linked lists of rows that have -C their first off-diagonal entries in the same columns. -C LINKFD Forward linked lists. -C LINKBK Backward linked lists. -C MARKER Array used to mark columns when merging is done. -C TEMP Temporary array used for handling pivotal clique. -C -C -C *** SUBROUTINES CALLED: -C MYWRT,DEFAAT,DTSORT -C -C -C *** PURPOSE: -C This routine implements the symbolic factorization -C for a symmetric positive definite matrix. -C -C -C *** NOTES: -C 1. This routine follows Duff et al. (1989) description -C of the minimum degree ordering. It is thus strongly -C influenced by the multifrontal approach to the Cholesky -C decomposition. -C 2. The lower right corner of the Cholesky factor is stored -C as a dense matrix (double addressing is thus avoided). -C IDNSRW (from CHFACT common block) is a number of the -C first row of a dense window. -C -C -C *** REFERENCES: -C Duff I.S., Erisman A.M., Reid J.K. (1989). Direct methods -C for sparse matrices, Clarendon Press, Oxford 1989, -C chapter 10. -C Gondzio J. (1993). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization 27, pp. 121-140. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: May 19, 1991 -C Last modified: February 12, 1994 -C -C -C -C *** BODY OF (SYMFCT) *** -C -C Set the return code (for successful run). - RTCD=1 -C -C -C Initialize for the symbolic factorization. -C Set up the sarsity pattern of A*Atransp array -C (only triangular part of A*Atransp is necessary). - TRIANG=1 - CALL DEFAAT(LRWNBS,AATPNT,AATPAT, - X MAXNZL,MAXM,MAXN,MAXNZA,M,TRIANG, - X MARKER,TEMP,STAVAR, - X CLPNTS,RWNMBS,RWHEAD,RWLINK,CLNMBS,LENCOL,IOERR) -C -C -C Copy the sparsity pattern of A*Atransp to AATPAT array. - DO 20 K=1,AATPNT(M+1)-1 - AATPAT(K)=LRWNBS(K) - 20 CONTINUE -C -C -C Zero work arrays. - DO 60 IROW=1,M - HEADER(IROW)=0 - MARKER(IROW)=0 - 60 CONTINUE -C -C Set the doubly linked lists of rows that have -C the first subdiagonal entry in the same columns. -C Recall that AATPNT(i) indicates the first -C off-diagonal entry of row i. - DO 80 IROW=1,M - KBEG=AATPNT(IROW) - KEND=AATPNT(IROW+1)-1 - IF(KBEG.GT.KEND) GO TO 80 - JCOL=AATPAT(KBEG) - NEXT=HEADER(JCOL) - LINKFD(IROW)=NEXT - HEADER(JCOL)=IROW - IF(NEXT.GT.0) LINKBK(NEXT)=IROW - LINKBK(IROW)=-JCOL - 80 CONTINUE -C -C -C Set the parameters controlling the progress of building -C the sparsity pattern of the Cholesky factor. -C LENOFL is a current length of the Cholesky factor. -C FLOPS is a cost of the numerical phase of the factorization. -C LENROW is the length of a given row of Cholesky factor. - LENOFL=0 - FLOPS=0.0D0 - LENROW=0 -C -C -C -C -C -C Main loop begins here (loop over rows of Cholesky factor). -C For every row IROW, its sparsity pattern is merged -C with those of all rows that have the first off-diagonal -C entry in the pivot column. All the already merged rows -C are removed from the linked lists. The pivot row is added -C to the sparsity pattern of the Cholesky matrix and its -C index is added to the linked list determined by its first -C off-diagonal entry. - DO 500 IROW=1,M - LCLPTS(IROW)=LENOFL+1 -C -C -C Create the pivot row sparsity pattern. -C Start from the sparsity pattern of row IROW of A*Atransp. - MARKER(IROW)=1 - KBEG=AATPNT(IROW) - KEND=AATPNT(IROW+1)-1 - LENROW=0 - DO 100 K=KBEG,KEND - LENROW=LENROW+1 - IR=AATPAT(K) - TEMP(LENROW)=IR - MARKER(IR)=1 - 100 CONTINUE -C -C -C Merge all the rows of Cholesky matrix that have -C the first off-diagonal entry in column IROW with -C the pivot row sparsity pattern. -C IRWACT is a number of row that is being merged with a pivot one. - IRWACT=HEADER(IROW) - 150 IF(IRWACT.EQ.0) GO TO 250 - KBEG=LCLPTS(IRWACT) - KEND=LCLPTS(IRWACT+1)-1 - DO 200 K=KBEG,KEND - IR=LRWNBS(K) - IF(MARKER(IR).EQ.1) GO TO 200 - LENROW=LENROW+1 - TEMP(LENROW)=IR - MARKER(IR)=1 - 200 CONTINUE - IRWACT=LINKFD(IRWACT) - GO TO 150 -C -C -C Here if pivot row sparsity pattern is determined. -C Update FLOPS. - 250 FLOPS=FLOPS+DBLE(LENROW)*DBLE(LENROW) -C -C -C Find the number of column of its first off-diagonal -C entry (and save it in JCOL). - IF(LENROW.LE.1) GO TO 350 - JCOL=M+1 - DO 300 IR=1,LENROW - IF(TEMP(IR).GE.JCOL) GO TO 300 - IRWACT=IR - JCOL=TEMP(IR) - 300 CONTINUE -C -C -C Place the first off-diagonal entry at the beginning of the list. - TEMP(IRWACT)=TEMP(1) - TEMP(1)=JCOL -C -C -C Copy the pivot row sparsity pattern to LRWNBS array. - 350 IF(LENROW.EQ.0) GO TO 500 - IF(LENOFL+LENROW.GT.MAXNZL) GO TO 9000 - DO 400 K=1,LENROW - LENOFL=LENOFL+1 - IR=TEMP(K) - LRWNBS(LENOFL)=IR - MARKER(IR)=0 - 400 CONTINUE -C -C -C *** DEBUGGING -C WRITE(BUFFER,401) IROW,LENROW -C 401 FORMAT(1X,'SYMFCT: row ',I6,' of L has length=',I6) -C CALL MYWRT(IOERR,BUFFER) -C -C -C Remove the pivot row from the linked list of rows -C that have the first off-diagonal entry in column IR. - 450 IF(LENROW.LE.1) GO TO 500 - KBEG=AATPNT(IROW) - KEND=AATPNT(IROW+1)-1 - IF(KBEG.GT.KEND) GO TO 480 - IR=AATPAT(KBEG) - IF(IR.EQ.JCOL) GO TO 500 - NEXT=LINKFD(IROW) - PREVS=LINKBK(IROW) - IF(NEXT.GT.0) LINKBK(NEXT)=PREVS - IF(PREVS.LE.0) THEN - HEADER(IR)=NEXT - ELSE - LINKFD(PREVS)=NEXT - ENDIF -C -C -C Add the pivot row to the linked list of rows that have -C the first off-diagonal entry in column JCOL. -C Rows of length 1 are not added to the list since they -C do not influence the sparsity pattern of Cholesky matrix. - 480 IF(LENROW.LE.1) GO TO 500 - NEXT=HEADER(JCOL) - HEADER(JCOL)=IROW - LINKFD(IROW)=NEXT - LINKBK(IROW)=-JCOL - IF(NEXT.GT.0) LINKBK(NEXT)=IROW -C -C -C -C -C -C End of main loop. - 500 CONTINUE - LCLPTS(M+1)=LENOFL+1 -C -C -C -C -C -C Go perform a double transpose sort. -C -C SUBROUTINE DTSORT(ROWNBS,COLPTS, -C X ICLNBS,IRWPTS,MAXNZ,MAXM,M,IOERR) -C - CALL DTSORT(LRWNBS,LCLPTS, - X AATPAT(1),TEMP,MAXNZL,MAXM,M,IOERR) -C -C -C -C -C Write problem statistics. - K=AATPNT(M+1)-1 - KX=LENOFL - A1=LENOFL*200.0 - A2=M*M-M - IF(M.GT.1) THEN - A1=A1/A2 - ELSE - A1=0.0 - ENDIF - WRITE(BUFFER,501) KX,A1 - 501 FORMAT(1X,'SYMFCT: Sparse matrix L has ',I13, - X ' subdiagonal elts (density=',F5.1,'%).') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,502) KX-K - 502 FORMAT(1X,' Fill-in ',I13) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,503) FLOPS - 503 FORMAT(1X,' Decomposition flops',1PD14.6) - CALL MYWRT(IOERR,BUFFER) -C -C WRITE(BUFFER,504) K,KX,FLOPS -C 504 FORMAT(1X,'qqqb',I10,' &',I10,' &',1PD13.6) -C CALL MYWRT(99,BUFFER) -C CALL MYWRT(IOERR,BUFFER) -C -C -C -C -C -C Check if it is useful to make a switch to the full code -C near the end of factorization. -C IDNSRW indicates the first 'dense' row of Cholesky matrix -C i.e., a row with the density at least DENSE. - IDNSRW=M+1 - DO 600 I=M,1,-1 - LENROW=LCLPTS(I+1)-LCLPTS(I) - A0=(M-I)*DENSE+0.5 - LENOK=A0 - IF(LENROW.GE.LENOK) THEN - FLOPS=FLOPS-DBLE(LENROW)*DBLE(LENROW) - IDNSRW=I - ELSE - GO TO 700 - ENDIF - 600 CONTINUE -C -C -C Check if the dense window is not too small. - 700 IF(M-IDNSRW.LE.10) THEN - IDNSRW=M+1 - GO TO 1000 - ENDIF - WRITE(BUFFER,701) M-IDNSRW - 701 FORMAT(1X,'SYMFCT: Dense window found ',I13) - CALL MYWRT(IOERR,BUFFER) -C -C -C Expand the lower right triangle of the sparse Cholesky -C factor to a dense matrix. - IROW=IDNSRW - LENOFL=LCLPTS(IDNSRW)-1 - LENROW=M-IDNSRW - LENROW=LENROW*(LENROW+1)/2 - IF(LENOFL+LENROW.GT.MAXNZL) GO TO 9000 - DO 900 IROW=IDNSRW,M - LCLPTS(IROW)=LENOFL+1 - DO 800 IR=IROW+1,M - LENOFL=LENOFL+1 - LRWNBS(LENOFL)=IR - 800 CONTINUE - 900 CONTINUE - LCLPTS(M+1)=LENOFL+1 -C -C -C -C -C Write final problem statistics. - DFLOPS=M-IDNSRW - DFLOPS=2.0*DFLOPS+1.0 - DFLOPS=DBLE(LENROW)*DFLOPS/3. - FLOPS=FLOPS+DFLOPS - KX=LENOFL - A1=LENOFL*200.0 - IF(M.GT.1) THEN - A1=A1/A2 - ELSE - A1=0.0 - ENDIF - WRITE(BUFFER,901) KX,A1 - 901 FORMAT(1X,'SYMFCT: Final matrix L has ',I13, - X ' subdiagonal elts (density=',F5.1,'%).') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,902) KX-K - 902 FORMAT(1X,' Fill-in ',I13) - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,903) FLOPS,DFLOPS - 903 FORMAT(1X,' Decomposition flops',1PD14.6, - X ' (',1PD12.6,' in dense mode).') - CALL MYWRT(IOERR,BUFFER) -C -C -C -C - 1000 CONTINUE - NZCHL=LENOFL - RETURN -C -C -C -C -C Here to write error message. - 9000 WRITE(BUFFER,9001) LENOFL+LENROW - 9001 FORMAT(1X,'SYMFCT ERROR: Matrix L overflow ',I10) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9002) MAXNZL - 9002 FORMAT(1X,' space was provided for only ',I10,' nonzeros.') - CALL ERRWRT(IOERR,BUFFER) -C - IF(IREG.EQ.-1) THEN -C *** Here for HOPDM: STOP the program. - STOP - ENDIF - IF(IREG.GE.0) THEN -C *** Here for HYBRID: Do not STOP the program. - LENROW=M-IROW+1 - LENROW=LENROW*(LENROW+1)/2 - NZCHL=LENOFL+LENROW - RTCD=0 - RETURN - ENDIF -C -C -C -C *** LAST CARD OF (SYMFCT) *** - END //GO.SYSIN DD hopdm.src/symfct.f echo hopdm.src/symref.f 1>&2 sed >hopdm.src/symref.f <<'//GO.SYSIN DD hopdm.src/symref.f' 's/^-//' -C********************************************************** -C **** SYMREF ... SYMBOLIC REFACTORIZATION **** -C********************************************************** -C - SUBROUTINE SYMREF(MAXNZL,MAXM,M,MNEW, - X LCLPTS,LRWNBS,PERM,INVP,IOERR) -C -C -C *** PARAMETERS - INTEGER*4 MAXNZL,MAXM,M,MNEW,IOERR - INTEGER*4 LCLPTS(MAXM+1) -C -C *** The following arrays can be half-length integer. - INTEGER*2 LRWNBS(MAXNZL),PERM(MAXM),INVP(MAXM) -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,IROW,IR,INEWRW,JCOL,K,KBEG,KEND,KX - INTEGER*4 LENOFL,LENOK,LENROW - DOUBLE PRECISION A0,A1,A2,DFLOPS - CHARACTER*100 BUFFER -C -C -C *** COMMON ARREAS -C Cholesky factorization parameters. - COMMON /CHFCT/ CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN,IDNSRW - DOUBLE PRECISION CSMALL,PIVTOL,TAU,DENSE,PIVMAX,PIVMIN - INTEGER*4 IDNSRW -C -C Additional Cholesky fact. parameters (interface to HYBRID). - COMMON /CHHYB/ RO,FLOPS,IREG,NZCHL,RTCD - DOUBLE PRECISION RO,FLOPS - INTEGER*4 IREG,NZCHL,RTCD -C -C -C *** PARAMETERS DESCRIPTION -C -C ON INPUT: -C MAXNZL Maximum number of nonzeros of the Cholesky factor. -C MAXM Maximum row dimension of the LP constraint matrix. -C M Number of rows of the LP constraint matrix before -C reduction (and the dimension of A*Atransp). -C MNEW Number of rows of the LP constraint matrix after -C reduction (and the dimension of A*Atransp). -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C PERM Permutation resulting from the elimination of inactive -C constraints. -C INV Inverse permutation. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C ON OUTPUT: -C LCLPTS Pointers to columns of the Cholesky factor. -C LRWNBS Row numbers of nonzeros in columns of matrix L. -C -C -C Additionally, through the CHHYB common block SYMREF returns: -C NZCHL Overestimate of the number of nonzeros -C of Cholesky factor (important if RTCD = 0). -C RTCD Return code from the symbolic factorization: -C 0 SYMREF failure; -C 1 SYMREF success. -C FLOPS Flops required to compute the decomposition. -C -C -C *** SUBROUTINES CALLED: -C MYWRT -C -C -C *** PURPOSE: -C This routine implements a compresion of the static data -C structures used to handle the Cholesky factor after removing -C some rows from the LP constraint matrix (and, consequently, -C from the Cholesky matrix of A*THETA*Atransp). -C -C -C *** NOTES: -C 1. This routine assumes that nonzeros of columns of L are -C in an increasing order and maintains such an order in a -C reduced matrix. -C 2. The lower right corner of the Cholesky factor is stored -C as a dense matrix (double addressing is thus avoided). -C IDNSRW (from CHFACT common block) is a number of the -C first row of a dense window. -C -C -C *** REFERENCES: -C Duff I.S., Erisman A.M., Reid J.K. (1989). Direct methods -C for sparse matrices, Clarendon Press, Oxford 1989, -C chapter 10. -C Gondzio J. (1993). Implementing Cholesky factorization -C for interior point methods of linear programming, -C Optimization 27, pp. 121-140. -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: January 19, 1994 -C -C -C -C *** BODY OF (SYMREF) *** -C -C Set the return code (for successful run). - RTCD=1 -C -C -C Set the parameters controlling the progress of building -C the sparsity pattern of the Cholesky factor. -C LENOFL is a current length of the Cholesky factor. -C FLOPS is a cost of the numerical phase of the factorization. -C LENROW is the length of a given row of Cholesky factor. -C INEWRW is the number of a new row of Cholesky factor. - LENOFL=0 - FLOPS=0.0D0 - LENROW=0 - INEWRW=0 -C -C -C -C -C -C Main loop begins here (loop over rows of Cholesky factor). -C Compress all rows of the Cholesky matrix. - DO 500 IROW=1,M -C -C Omit inactive row. - IF(INVP(IROW).GT.MNEW) GO TO 500 - INEWRW=INEWRW+1 - KBEG=LCLPTS(IROW) - KEND=LCLPTS(IROW+1)-1 - LCLPTS(INEWRW)=LENOFL+1 -C -C -C Analyse old row IROW. Save only those nonzero entries which -C refer to still active LP constraints. - LENROW=0 - DO 400 K=KBEG,KEND - IR=LRWNBS(K) - JCOL=INVP(IR) - IF(JCOL.LE.MNEW) THEN - LENROW=LENROW+1 - LENOFL=LENOFL+1 - LRWNBS(LENOFL)=JCOL - ENDIF - 400 CONTINUE -C -C -C Here if pivot row sparsity pattern is determined. -C Update FLOPS. - FLOPS=FLOPS+DBLE(LENROW)*DBLE(LENROW) -C -C -C *** DEBUGGING -C WRITE(BUFFER,401) IROW,LENROW -C 401 FORMAT(1X,'SYMREF: row ',I6,' of L has length=',I6) -C CALL MYWRT(IOERR,BUFFER) -C -C -C -C -C -C End of main loop. - 500 CONTINUE - LCLPTS(INEWRW+1)=LENOFL+1 - LCLPTS(M+1)=LENOFL+1 -C -C -C -C -C -C -C Write problem statistics. - KX=LENOFL - A1=LENOFL*200.0 - A2=MNEW*MNEW-MNEW - IF(MNEW.GT.1) THEN - A1=A1/A2 - ELSE - A1=0.0 - ENDIF - WRITE(BUFFER,501) KX,A1 - 501 FORMAT(1X,'SYMREF: Sparse matrix L has ',I13, - X ' subdiagonal elts (density=',F5.1,'%).') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,503) FLOPS - 503 FORMAT(1X,' Decomposition flops',1PD14.6) - CALL MYWRT(IOERR,BUFFER) -C -C -C -C -C -C Check if it is useful to make a switch to the full code -C near the end of factorization. -C IDNSRW indicates the first 'dense' row of Cholesky matrix -C i.e., a row with the density at least DENSE. - IDNSRW=MNEW+1 - DO 600 I=MNEW,1,-1 - LENROW=LCLPTS(I+1)-LCLPTS(I) - A0=(MNEW-I)*DENSE+0.5 - LENOK=A0 - IF(LENROW.GE.LENOK) THEN - FLOPS=FLOPS-DBLE(LENROW)*DBLE(LENROW) - IDNSRW=I - ELSE - GO TO 700 - ENDIF - 600 CONTINUE -C -C -C Check if the dense window is not too small. - 700 IF(MNEW-IDNSRW.LE.10) THEN - IDNSRW=MNEW+1 - GO TO 1000 - ENDIF - WRITE(BUFFER,701) MNEW-IDNSRW - 701 FORMAT(1X,'SYMREF: Dense window found ',I13) - CALL MYWRT(IOERR,BUFFER) -C -C -C Expand the lower right triangle of the sparse Cholesky -C factor to a dense matrix. - IROW=IDNSRW - LENOFL=LCLPTS(IDNSRW)-1 - LENROW=MNEW-IDNSRW - LENROW=LENROW*(LENROW+1)/2 - IF(LENOFL+LENROW.GT.MAXNZL) GO TO 9000 - DO 900 IROW=IDNSRW,MNEW - LCLPTS(IROW)=LENOFL+1 - DO 800 IR=IROW+1,MNEW - LENOFL=LENOFL+1 - LRWNBS(LENOFL)=IR - 800 CONTINUE - 900 CONTINUE - LCLPTS(MNEW+1)=LENOFL+1 -C -C -C -C -C Write final problem statistics. - DFLOPS=MNEW-IDNSRW - DFLOPS=2.0*DFLOPS+1.0 - DFLOPS=DBLE(LENROW)*DFLOPS/3. - FLOPS=FLOPS+DFLOPS - KX=LENOFL - A1=LENOFL*200.0 - IF(MNEW.GT.1) THEN - A1=A1/A2 - ELSE - A1=0.0 - ENDIF - WRITE(BUFFER,901) KX,A1 - 901 FORMAT(1X,'SYMREF: Final matrix L has ',I13, - X ' subdiagonal elts (density=',F5.1,'%).') - CALL MYWRT(IOERR,BUFFER) - WRITE(BUFFER,903) FLOPS,DFLOPS - 903 FORMAT(1X,' Decomposition flops',1PD14.6, - X ' (',1PD12.6,' in dense mode).') - CALL MYWRT(IOERR,BUFFER) -C -C -C -C - 1000 CONTINUE - NZCHL=LENOFL - RETURN -C -C -C -C -C Here to write error message. - 9000 WRITE(BUFFER,9001) LENOFL+LENROW - 9001 FORMAT(1X,'SYMREF ERROR: Matrix L overflow ',I10) - CALL ERRWRT(IOERR,BUFFER) - WRITE(BUFFER,9002) MAXNZL - 9002 FORMAT(1X,' space was provided for only ',I10,' nonzeros.') - CALL ERRWRT(IOERR,BUFFER) -C - IF(IREG.EQ.-1) THEN -C *** Here for HOPDM: STOP the program. - STOP - ENDIF - IF(IREG.GE.0) THEN -C *** Here for HYBRID: Do not STOP the program. - LENROW=MNEW-IROW+1 - LENROW=LENROW*(LENROW+1)/2 - NZCHL=LENOFL+LENROW - RTCD=0 - RETURN - ENDIF -C -C -C -C *** LAST CARD OF (SYMREF) *** - END //GO.SYSIN DD hopdm.src/symref.f echo hopdm.src/timepf.f 1>&2 sed >hopdm.src/timepf.f <<'//GO.SYSIN DD hopdm.src/timepf.f' 's/^-//' - SUBROUTINE TIMEPF( JOB, NOUT, IDATIM) - INTEGER JOB, NOUT - INTEGER IDATIM(9) -C -C TIMEPF - Set the Current Date, Time and Elapsed Time -C -C*****Purpose: -C Subroutine TIMEPF gets the current date and time by calling -C the user or Fortran supplied routines GETDAT and GETTIM, -C increases the elapsed time specified in the array IDATIM -C by the difference between the current time and the time -C specified in IDATIM and prints the current date, time and -C elapsed time on the output file number NOUT if JOB=1. -C Additionally, if JOB=0, the elapsed time in IDATIM is set -C to zero, whereas if JOB is neither 0 nor 1, the elapsed time -C is not changed. Usually TIMEPF will be called first with -C JOB=0, and then with JOB=1 to output the time elapsed since -C the first call. -C -C*****Remark: -C The IBM Professional Fortran subroutines from the library -C file PROFORT.LIB -C CALL GETDAT( IYEAR, IMONTH, IDAY) -C CALL GETTIM( IHOUR, IMINUTE, ISECOND, IHUNDREDSECOND) -C return the current date and time in their INTEGER*2 arguments. -C For other compilers you must provide your own versions of -C GETDAT and GETTIM. Note that the last argument HUNDREDSECOND -C is not used here. -C -C*****Parameters: -C JOB is an integer input variable. -C NOUT is an integer input variable that specifies a -C non-negative output file number. -C IDATIM is an integer array of length 9 which on output -C stores the current date, time and elapsed time as -C follows: -C IDATIM(1) - year; -C IDATIM(2) - month; -C IDATIM(3) - day; -C IDATIM(4) - hours; -C IDATIM(5) - minutes; -C IDATIM(6) - seconds; -C IDATIM(7) - hours of elapsed time; -C IDATIM(8) - minutes of elapsed time; -C IDATIM(9) - seconds of elapsed time. -C On input IDATIM(I) must be set as above for I=4 to 9 -C if JOB=1, and for I=7 to 9 if JOB is neither 0 nor 1; -C for JOB=0 IDATIM is arbitrary. -C*****Subprograms called: -C Fortran-supplied - FLOAT, GETDAT, GETTIM, IDINT. - INTEGER IDINT - REAL FLOAT -C -C*****History: -C Written by Krzysztof C. Kiwiel, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, 01-447 Warsaw. -C Date last modified: January 14, 1987. -C -C*****Body of subroutine TIMEPF: - INTEGER I - DOUBLE PRECISION DMINUT, DSECND - INTEGER*2 JDATIM(7) -C Get the current date and time. JDATIM is set as IDATIM. - CALL GETDAT( JDATIM(1), JDATIM(2), JDATIM(3)) - CALL GETTIM( JDATIM(4), JDATIM(5), JDATIM(6), JDATIM(7)) - IF ( JOB.NE.0 ) GO TO 10 -C Zero the elapsed time. - IDATIM(7)=0 - IDATIM(8)=0 - IDATIM(9)=0 - 10 IF ( JOB.NE.1 ) GO TO 20 -C Calculate the elapsed time in seconds. - DSECND=60.0*(60.0D+0*FLOAT(IDATIM(7)+JDATIM(4)-IDATIM(4)) - * +FLOAT(IDATIM(8)+JDATIM(5)-IDATIM(5))) - * +FLOAT(IDATIM(9)+JDATIM(6)-IDATIM(6)) -C Account for passing midnight. - IF ( JDATIM(4).LT.IDATIM(4) ) DSECND=DSECND+86400.0D+0 - DMINUT=IDINT( DSECND/60.0) - IDATIM(9)=DSECND-60.0*DMINUT - IDATIM(7)=IDINT( DMINUT/60.0) - IDATIM(8)=DMINUT-60.0D+0*FLOAT( IDATIM(7)) - 20 CONTINUE -C Save the current date and time. - DO 30 I=1,6 - IDATIM(I)=JDATIM(I) - 30 CONTINUE -C Print the date, time and elapsed time. - IF (NOUT.LT.0) RETURN - WRITE(NOUT,301) IDATIM - 301 FORMAT(' DATE..',I4,'-',I2.2,'-',I2.2, - * ' TIME..',I2,':',I2.2,':',I2.2, - * ' ELAPSED TIME..',I2,':',I2.2,':',I2.2) - RETURN -C*****Last card of subroutine TIMEPF********************************** - END //GO.SYSIN DD hopdm.src/timepf.f echo hopdm.src/wrtsol.f 1>&2 sed >hopdm.src/wrtsol.f <<'//GO.SYSIN DD hopdm.src/wrtsol.f' 's/^-//' -C************************************************************** -C * WRTSOL ... WRITE MPS (or NONSTANDARD) SULUTION FILE * -C************************************************************** -C - SUBROUTINE WRTSOL(M,MFINAL,N,NSTRCT,MAXM,MAXN, - X STAVAR,RWSTAT,STAROW,RWNAME,CLNAME,NAMMPS,MULT, - X LOBND,UPBND,B,C,PRLVAR,DLVAR, - X RWORK,IWORK,RMAP,IMAP,IROW,RELT, - X PRLACT,BNEW,IWRITE,OUTMPS,IOERR) -C -C -C -C *** PARAMETERS - INTEGER*4 MAXM,MAXN,M,MFINAL,N,NSTRCT - INTEGER*2 STAVAR(MAXN),STAROW(MAXM),RWSTAT(MAXM) - CHARACTER*8 RWNAME(MAXM),CLNAME(MAXN),NAMMPS - DOUBLE PRECISION MULT,UPBND(MAXN),LOBND(MAXN) - DOUBLE PRECISION B(MAXM),C(MAXN),PRLVAR(MAXN),DLVAR(MAXM) - INTEGER*4 IROW(MAXN) - DOUBLE PRECISION RELT(MAXN),PRLACT(MAXM),BNEW(MAXM) - INTEGER*4 IWRITE,OUTMPS,IOERR -C -C -C -C *** HIDDEN DATA STRUCTURES - INTEGER*4 IWORK(*),IMAP(*),RMAP(*) - DOUBLE PRECISION RWORK(*) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 I,I1,IKX,J,K,NFREE,STATUS - DOUBLE PRECISION VRBLJ,BNDLJ,PROD,PRFSBT - CHARACTER*100 BUFFER -C -C -C -C An indicator if the elimination routine has been used. - COMMON /ELMNTE/ IELIM - INTEGER*4 IELIM -C -C -C -C *** PARAMETERS DESCRIPTION -C MAXM Maximum number of constraints. -C MAXN Maximum number of variables. -C M Current number of constraints. -C MFINAL Final number of constraints. -C N Number of variables (total, i.e. including slacks, surplus -C and artificials). -C NSTRCT Number of structural variables (excluding slacks, surplus -C and artificials). -C RWSTAT Array of row types: -C 1 row type is = ; -C 2 row type is >= ; -C 3 row type is <= ; -C 4 free row (may be objective for example). -C STAROW Array of row status: -C 0 row has been removed (it indicates a free row); -C 1 row has not been removed. -C STAVAR Array of variable status: -C 0 STANDARD (nonnegative) variable i.e.: 0 <= x <= +inf; -C 1 UPPER bounded variable i.e.: 0 <= x <= u; -C 2 LOWER bounded variable i.e.: l <= x <= +inf; -C 3 both LOWER and UPPER bounded variable i.e.: l <= x <= u; -C 4 MINUS INFINITY type variable i.e.: -inf <= x <= u; -C 5 PLUS INFINITY type variable i.e.: l <= x <= +inf; -C 6 FIXED variable i.e.: x = l = u; -C -k FREE variable. As the free variable is split into two -C variables, k is the number of its brother. Observe, -C that k-th variable will also have negative status -C that indicates the position of the original variable. -C RWNAME Array of row names. -C CLNAME Array of column names. -C NAMMPS The name of the LP problem. -C MULT Direction of optimization: -C +1 means minimization; -C -1 means maximization. -C LOBND Array of lower bounds. -C UPBND Array of upper bounds. Note that the upper bound -C is changed when the variable has a lower bound. -C B Right hand side of the linear program. -C C Objective function coefficients. -C PRLVAR Primal variables of the LP problem. -C DLVAR Dual variables of the LP problem. -C IROW and RELT are the arrays for temporary handling of rows -C and columns of the constraint matrix. They are primarily -C intended to handle sparse vectors (in packed form) -C but may also be used for storing dense ones. -C PRLACT Primal activity ((Ai)transp*X). -C BNEW New right hand side of the (modified) linear program. -C IWRITE Solution output parameter: -C 0 no MPS file desired; -C 1 produce MPS-like solution file. -C OUTMPS Input/output unit number where the output MPS file -C is to be written to. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C -C -C -C *** OUTPUT FILE DESCRIPTION -C -C ROWS SECTION DESCRIPTION: -C column ROW: index of the row -C column EQUATION: name of the row -C column LOWER LIMIT: lower limit of the constraint -C column UPPER LIMIT: upper limit of the constraint -C column ACTIVITY: value of the constraint -C column STATUS: -C LL: constraint is at its lower limit -C UL: constraint is at its upper limit -C EQ: constraint is equal to RHS -C column SLACK: index of the slack variable added -C to the constraint -C column SLK ACTIVITY: value of the slack variable -C -C COLUMNS SECTION DESCRIPTION: -C column COLUMN: index of the variable -C column VARIABLE: name of the variable -C column LOWER BOUND: lower bound of the variable -C column UPPER BOUND: upper bound of the variable -C column ACTIVITY: value of the variable -C -C -C -C *** PURPOSE -C This routine writes an MPS (or nonstandard) solution file. -C -C -C -C *** SUBROUTINES CALLED -C GETROW,GETCOL,DABS,DBLE -C -C -C -C *** NOTES -C Since the elimination routine might have earlier been -C called, some of the original LP data may have been lost. -C We will not be able to write complete MPS output in such -C case, so a (nonstandard) output file will be produced. -C -C -C -C -C *** REFERENCES: -C Altman A., Gondzio J. (1992). An efficient implementation -C of a higher order primal-dual interior point method -C for large sparse linear programs, Archives of Control -C Sciences (to appear). -C Altman A., Gondzio J. (1993). HOPDM - A higher order primal- -C dual method for large scale linear programmming, European -C Journal of Operational Research 66 (1993) pp 158-160. -C Gondzio J., Tachat D. (1992). The design and application -C of IPMLO - a FORTRAN library for linear optimization -C with interior point methods, Technical Report No 108, -C LAMSADE, University of Paris Dauphine, 75775 Paris Cedex 16, -C France, January 1992, revised in November 1992, -C RAIRO Operations Research (to appear). -C Murtagh B. (1981). Advanced Linear Programming, McGrew-Hill, -C New York, 1981. -C Murtagh B., Saunders M. (1983). MINOS 5.0 User's guide, -C Technical Report SOL 83-20, Department of Operations -C Research, Stanford University, Stanford, 1983. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Date written: May 29, 1991 -C Last modified: September 22, 1994 -C -C -C -C -C -C -C *** BODY OF (WRTSOL) *** -C -C -C -C -C Set up (local) feasibility tolerance. - PRFSBT=1.0D-6 -C -C -C -C -C computing the slack activity and the LP objective -C ************************************************* -C - PROD=0.0 - DO 100 I=1,M - PRLACT(I)=0.0D0 - BNEW(I)=B(I) - 100 CONTINUE - DO 120 I=M+1,MAXM - PRLACT(I)=0.0D0 - DLVAR(I)=0.0D0 - BNEW(I)=0.0D0 - 120 CONTINUE - DO 160 J=1,NSTRCT -C -C Restore the original status of all variables. - STATUS=STAVAR(J) - IF(STATUS.EQ.14) THEN -C -C Here for slack variable eliminated in HOELIM routine. - STAVAR(J)=0 - GO TO 160 - ENDIF - IF(STATUS.EQ.15) THEN -C -C Here for structural variable eliminated as a FREE one. -C Its correct value has already been restored by POSTSL routine. - STAVAR(J)=6 - STATUS=STAVAR(J) - ENDIF - IF(STATUS.GE.7) THEN -C -C Here for structural variable eliminated in HOELIM routine. - STAVAR(J)=STAVAR(J)-7 - ENDIF -C - VRBLJ=PRLVAR(J) - BNDLJ=0.0D0 - IF(STAVAR(J).EQ.2.OR.STAVAR(J).EQ.3.OR.STAVAR(J).EQ.6) THEN - VRBLJ=LOBND(J)+PRLVAR(J) - BNDLJ=LOBND(J) - ENDIF - PROD=PROD+VRBLJ*C(J) -C -C Columns refering to FIXED variables were not reordered so their -C contribution to the right hand side cannot be taken into account. - IF(STATUS.GE.6) GO TO 160 - CALL GETCOL(J,RWORK,IWORK,RMAP,IMAP, - X IROW,RELT,K,MAXN,IOERR) - DO 140 I1=1,K - IKX=IROW(I1) - PRLACT(IKX)=PRLACT(IKX)+VRBLJ*RELT(I1) - BNEW(IKX)=BNEW(IKX)+BNDLJ*RELT(I1) - 140 CONTINUE - 160 CONTINUE - DO 180 I=1,M - IF(DABS(BNEW(I)).LE.1.0D-12) BNEW(I)=0.0 - 180 CONTINUE -C -C -C -C -C writing the output file -C *********************** -C -C writing the title of the original problem -C ----------------------------------------- -C - IF(IWRITE.EQ.1) THEN - WRITE(BUFFER,103) NAMMPS - 103 FORMAT(1X,'TITLE OF THE PROBLEM: ',A8) - CALL MYWRT(OUTMPS,BUFFER) - IF(IELIM.EQ.1) THEN - WRITE(BUFFER,104) - 104 FORMAT(1X,'Incomplete report (rows/cols elimination).') - CALL MYWRT(OUTMPS,BUFFER) - ENDIF - WRITE(BUFFER,105) - 105 FORMAT(1X) - CALL MYWRT(OUTMPS,BUFFER) - CALL MYWRT(OUTMPS,BUFFER) - ENDIF -C -C writing the optimal value of the objective function -C --------------------------------------------------- -C - PROD=MULT*PROD - PRLACT(MAXM)=PROD - WRITE(BUFFER,107) PROD - 107 FORMAT(1X,'OBJECTIVE FUNCTION VALUE = ',D18.10) - CALL MYWRT(IOERR,BUFFER) - CALL MYWRT(99,BUFFER) - IF(IWRITE.EQ.1) THEN - CALL MYWRT(OUTMPS,BUFFER) - ENDIF - IF(IWRITE.EQ.1) THEN - WRITE(BUFFER,108) - 108 FORMAT(1X) - CALL MYWRT(OUTMPS,BUFFER) - ENDIF -C -C -C -C -C writing the ROWS section -C ------------------------ -C - WRITE(BUFFER,109) - 109 FORMAT(2X,'ROW EQUATION LOWER LIMIT UPPER ', - X 'LIMIT ACTIVITY STAT SLACK SL ACTIVITY') - IF(IWRITE.EQ.1) THEN - CALL MYWRT(OUTMPS,BUFFER) - ENDIF -C -C -C -C Main loop over constraints. - DO 300 I=1,MFINAL - PROD=BNEW(I)-PRLACT(I) - CALL GETROW(I,RWORK,IWORK,RMAP,IMAP, - X IROW,RELT,K,MAXN,IOERR) -C -C - IF(RWSTAT(I).EQ.1) THEN -C -C Here for EQUALITY constraint. - IF(IWRITE.EQ.1) THEN - WRITE(BUFFER,301) I,RWNAME(I),BNEW(I),BNEW(I), - X PRLACT(I),PROD - 301 FORMAT(1X,I4,3X,A8,1X,D11.5,1X,D11.5,1X,D11.5, - X 3X,'EQ',3X,'NONE',2X,D11.5) - CALL MYWRT(OUTMPS,BUFFER) - ENDIF - GO TO 300 - ENDIF -C -C Here for INEQUALITY constraint. - IF(K.EQ.0) THEN - IF(IWRITE.EQ.1) THEN - WRITE(BUFFER,302) I,RWNAME(I) - 302 FORMAT(1X,I4,3X,A8,2X,'was eliminated.') - CALL MYWRT(OUTMPS,BUFFER) - ENDIF - GO TO 300 - ENDIF - J=IROW(1) -C -C - IF(RWSTAT(I).EQ.2) THEN -C -C Here for GREATER OR EQUAL type constraint (surplus variable). - PROD=-PROD - PRLVAR(J)=PROD - IF(DABS(PROD)/(DABS(BNEW(I))+1.0).LT.PRFSBT) THEN -C -C Row I is at its LOWER bound. - IF(IWRITE.EQ.1) THEN - WRITE(BUFFER,303) I,RWNAME(I),BNEW(I),PRLACT(I), - X J,PROD - 303 FORMAT(1X,I4,3X,A8,1X,D11.5,8X,'NONE',1X,D11.5, - X 3X,'LL',1X,I6,2X,D11.5) - CALL MYWRT(OUTMPS,BUFFER) - ENDIF - ELSE -C -C Row I is not at its LOWER bound. - IF(IWRITE.EQ.1) THEN - WRITE(BUFFER,304) I,RWNAME(I),BNEW(I),PRLACT(I), - X J,PROD - 304 FORMAT(1X,I4,3X,A8,1X,D11.5,8X,'NONE',1X,D11.5, - X 6X,I6,2X,D11.5) - CALL MYWRT(OUTMPS,BUFFER) - ENDIF - ENDIF -C - GO TO 300 - ENDIF -C -C - IF(RWSTAT(I).EQ.3) THEN - PRLVAR(J)=PROD -C -C Here for LESS OR EQUAL type constraint (slack variable). - IF(DABS(PROD)/(DABS(BNEW(I))+1.0).LT.PRFSBT) THEN -C -C Row I is at its UPPER bound. - IF(IWRITE.EQ.1) THEN - WRITE(BUFFER,305) I,RWNAME(I),BNEW(I),PRLACT(I), - X J,PROD - 305 FORMAT(1X,I4,3X,A8,8X,'NONE',1X,D11.5,1X,D11.5, - X 3X,'UL',1X,I6,2X,D11.5) - CALL MYWRT(OUTMPS,BUFFER) - ENDIF - ELSE -C -C Row I is not at its UPPER bound. - IF(IWRITE.EQ.1) THEN - WRITE(BUFFER,306) I,RWNAME(I),BNEW(I),PRLACT(I), - X J,PROD - 306 FORMAT(1X,I4,3X,A8,8X,'NONE',1X,D11.5,1X,D11.5, - X 6X,I6,2X,D11.5) - CALL MYWRT(OUTMPS,BUFFER) - ENDIF - ENDIF -C - GO TO 300 - ENDIF -C -C -C -C End of main loop over constraints. - 300 CONTINUE -C -C -C -C Write information on eliminated constraints. - DO 320 I=MFINAL+1,MAXM-1 - PRLACT(I)=-1.0D+36 - 320 CONTINUE - IF(IWRITE.EQ.1) THEN - IF(IELIM.EQ.1) THEN - DO 340 I=MFINAL+1,M - WRITE(BUFFER,339) I,RWNAME(I) - 339 FORMAT(1X,I4,3X,A8,2X,'was eliminated.') - CALL MYWRT(OUTMPS,BUFFER) - 340 CONTINUE - ENDIF - ENDIF -C -C -C -C -C writing the dual activity of constraints -C ---------------------------------------- -C - IF(IWRITE.EQ.1) THEN - WRITE(BUFFER,341) - 341 FORMAT(1X) - CALL MYWRT(OUTMPS,BUFFER) - WRITE(BUFFER,342) - 342 FORMAT(1X,' ROW EQUATION DUAL ACTIVITY') - CALL MYWRT(OUTMPS,BUFFER) - ENDIF -C -C -C -C Main loop over constraints. - IF(IWRITE.EQ.1) THEN - DO 400 I=1,M -C - WRITE(BUFFER,399) I,RWNAME(I),DLVAR(I) - 399 FORMAT(1X,I4,3X,A8,3X,D11.5) - CALL MYWRT(OUTMPS,BUFFER) -C -C End of main loop over constraints. - 400 CONTINUE - ENDIF -C -C -C -C -C writing the COLUMNS section -C --------------------------- -C - IF(IWRITE.EQ.1) THEN - WRITE(BUFFER,401) - 401 FORMAT(1X) - CALL MYWRT(OUTMPS,BUFFER) - WRITE(BUFFER,402) - 402 FORMAT(1X,'COLUMN VARIABLE LOWER BOUND ', - X 'UPPER BOUND ACTIVITY') - CALL MYWRT(OUTMPS,BUFFER) - ENDIF -C -C -C -C Main loop over variables. - NFREE=0 - DO 500 J=1,NSTRCT -C -C - IF(STAVAR(J).EQ.0) THEN -C -C Here for the STANDARD variable. - IF(IWRITE.EQ.0) GO TO 500 - WRITE(BUFFER,501) J,CLNAME(J),DBLE(0.),PRLVAR(J) - 501 FORMAT(1X,I6,1X,A8,1X,D11.5,8X,'NONE',1X,D11.5) - CALL MYWRT(OUTMPS,BUFFER) - GO TO 500 - ENDIF -C -C - IF(STAVAR(J).EQ.1) THEN -C -C Here if the variable has only an UPPER bound. - IF(IWRITE.EQ.0) GO TO 500 - WRITE(BUFFER,502) J,CLNAME(J),DBLE(0.),UPBND(J),PRLVAR(J) - 502 FORMAT(1X,I6,1X,A8,1X,D11.5,1X,D11.5,1X,D11.5) - CALL MYWRT(OUTMPS,BUFFER) - GO TO 500 - ENDIF -C -C - IF(STAVAR(J).EQ.2) THEN -C -C Here if the variable has only a LOWER bound. - PRLVAR(J)=LOBND(J)+PRLVAR(J) - IF(IWRITE.EQ.0) GO TO 500 - WRITE(BUFFER,503) J,CLNAME(J),LOBND(J),PRLVAR(J) - 503 FORMAT(1X,I6,1X,A8,1X,D11.5,8X,'NONE',1X,D11.5) - CALL MYWRT(OUTMPS,BUFFER) - GO TO 500 - ENDIF -C -C - IF(STAVAR(J).EQ.3) THEN -C -C Here if the variable has both LOWER and UPPER bounds. -C Observe that it has already been pushed to a zero LOWER bound. -C Consequently, its UPPER bound was equal to UPBND(J)-LOBND(J). - UPBND(J)=LOBND(J)+UPBND(J) - PRLVAR(J)=LOBND(J)+PRLVAR(J) - IF(IWRITE.EQ.0) GO TO 500 - WRITE(BUFFER,504) J,CLNAME(J),LOBND(J),UPBND(J),PRLVAR(J) - 504 FORMAT(1X,I6,1X,A8,1X,D11.5,1X,D11.5,1X,D11.5) - CALL MYWRT(OUTMPS,BUFFER) - GO TO 500 - ENDIF -C -C - IF(STAVAR(J).EQ.6) THEN -C -C Here if the variable is FIXED. - UPBND(J)=LOBND(J)+UPBND(J) - PRLVAR(J)=LOBND(J)+PRLVAR(J) - IF(IWRITE.EQ.0) GO TO 500 - WRITE(BUFFER,505) J,CLNAME(J),LOBND(J),UPBND(J),PRLVAR(J) - 505 FORMAT(1X,I6,1X,A8,1X,D11.5,1X,D11.5,1X,D11.5) - CALL MYWRT(OUTMPS,BUFFER) - GO TO 500 - ENDIF -C -C - IF(STAVAR(J).LT.0) THEN -C -C Here if the variable is FREE. - K=STAVAR(J) - IF(J.GT.-K) GO TO 500 - PRLVAR(J)=PRLVAR(J)-PRLVAR(-K) - NFREE=NFREE+1 - IF(IWRITE.EQ.0) GO TO 500 - WRITE(BUFFER,506) J,CLNAME(J),PRLVAR(J) - 506 FORMAT(1X,I6,1X,A8,8X,'NONE',8X,'NONE',1X,D11.5) - CALL MYWRT(OUTMPS,BUFFER) - GO TO 500 - ENDIF -C -C -C -C End of main loop over variables. - 500 CONTINUE - NSTRCT=NSTRCT-NFREE -C -C -C -C -C - RETURN -C -C -C *** LAST CARD OF (WRTSOL) *** - END //GO.SYSIN DD hopdm.src/wrtsol.f echo hopdm.src/xgtcol.f 1>&2 sed >hopdm.src/xgtcol.f <<'//GO.SYSIN DD hopdm.src/xgtcol.f' 's/^-//' -C************************************************************** -C **** XGTCOL ... GET THE J-th COLUMN OF MATRIX A **** -C************************************************************** -C - SUBROUTINE XGTCOL(J,ACOEFF, - X CLPNTS,RWNMBS,LENCOL, - X IROW,RELT,COLLEN,IOERR) -C -C -C -C *** PARAMETERS - INTEGER*4 J,COLLEN,IOERR - INTEGER*4 CLPNTS(*),IROW(*) - INTEGER*2 RWNMBS(*),LENCOL(*) - DOUBLE PRECISION ACOEFF(*),RELT(*) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 K,KBEG,IKX -C -C -C -C *** PARAMETERS DESCRIPTION -C ON INPUT: -C J Index of the column to be created. -C ACOEFF Array of non zero elements for each column. -C CLPNTS Pointers to the beginning of columns of matrix A. -C RWNMBS Row numbers of nonzeros in columns of matrix A. -C LENCOL Lengths of (sparse) columns of matrix A. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C ON OUTPUT: -C IROW Row indices of nonzero entries of the column to be created. -C RELT Nonzero entries of the column to be created. -C COLLEN Number of nonzero entries of the column to be created. -C -C -C -C *** SUBROUTINES CALLED -C NONE -C -C -C *** NOTES -C -C -C -C *** REFERENCES: -C Gondzio J., Tachat D. (1992). The design and application -C of IPMLO - a FORTRAN library for linear optimization -C with interior point methods, Technical Report No 108, -C LAMSADE, University of Paris Dauphine, 75775 Paris Cedex 16, -C France, January 1992, revised in November 1992. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: June 10, 1992 -C -C -C -C -C *** BODY OF (XGTCOL) *** -C - COLLEN=LENCOL(J) - KBEG=CLPNTS(J)-1 - DO 100 IKX=1,COLLEN - K=KBEG+IKX - IROW(IKX)=RWNMBS(K) - RELT(IKX)=ACOEFF(K) - 100 CONTINUE -C - RETURN -C -C *** LAST CARD OF (XGTCOL) *** - END //GO.SYSIN DD hopdm.src/xgtcol.f echo hopdm.src/xgtrow.f 1>&2 sed >hopdm.src/xgtrow.f <<'//GO.SYSIN DD hopdm.src/xgtrow.f' 's/^-//' -C************************************************************** -C **** XGTROW ... GET THE I-th ROW OF MATRIX A **** -C************************************************************** -C - SUBROUTINE XGTROW(I,ACOEFF, - X RWHEAD,RWLINK,CLNMBS, - X JCOL,RELT,ROWLEN,IOERR) -C -C -C -C *** PARAMETERS - INTEGER*4 I,ROWLEN,IOERR - INTEGER*4 RWHEAD(*),RWLINK(*),JCOL(*) - INTEGER*2 CLNMBS(*) - DOUBLE PRECISION ACOEFF(*),RELT(*) -C -C -C -C *** LOCAL VARIABLES - INTEGER*4 K -C -C -C -C *** PARAMETERS DESCRIPTION -C ON INPUT: -C I Index of the row to be created. -C ACOEFF Array of non zero elements for each column. -C RWHEAD Headers to the row linked lists of matrix A. -C RWLINK Row linked lists of matrix A. -C CLNMBS Column numbers of nonzeros in rows of matrix A. -C IOERR Input/output unit number where error messages -C (if any) are to be written. -C ON OUTPUT: -C JCOL Column indices of nonzero entries of the row to be created. -C RELT Nonzero entries of the row to be created. -C ROWLEN Number of nonzero entries of the row to be created. -C -C -C -C *** SUBROUTINES CALLED -C NONE -C -C -C *** NOTES -C -C -C -C *** REFERENCES: -C Gondzio J., Tachat D. (1992). The design and application -C of IPMLO - a FORTRAN library for linear optimization -C with interior point methods, Technical Report No 108, -C LAMSADE, University of Paris Dauphine, 75775 Paris Cedex 16, -C France, January 1992, revised in November 1992. -C -C -C -C *** HISTORY: -C Written by: Jacek Gondzio, Systems Research Institute, -C Polish Academy of Sciences, Newelska 6, -C 01-447 Warsaw, Poland. -C Last modified: May 7, 1992 -C -C -C -C -C *** BODY OF (XGTROW) *** -C - ROWLEN=0 - K=RWHEAD(I) - 100 IF(K.LE.0) GO TO 200 - ROWLEN=ROWLEN+1 - JCOL(ROWLEN)=CLNMBS(K) - RELT(ROWLEN)=ACOEFF(K) - K=RWLINK(K) - GO TO 100 -C - 200 CONTINUE - RETURN -C -C *** LAST CARD OF (XGTROW) *** - END //GO.SYSIN DD hopdm.src/xgtrow.f echo hopdm.src/specs.shar 1>&2 sed >hopdm.src/specs.shar <<'//GO.SYSIN DD hopdm.src/specs.shar' 's/^-//' -# to unbundle, sh this file (in an empty directory) -mkdir specs -echo specs/25fv47.spc 1>&2 -sed >specs/25fv47.spc <<'//GO.SYSIN DD specs/25fv47.spc' 's/^-//' --begin --rows 840 --cols 3200 --elements 13000 --B0 tol 0.01 --fac freq 30 --MPS FILE 25fv47.mps --ERROR FILE 25fv47.err --SOLUT FILE 25fv47.res --minimize --end -//GO.SYSIN DD specs/25fv47.spc -echo specs/80bau3b.spc 1>&2 -sed >specs/80bau3b.spc <<'//GO.SYSIN DD specs/80bau3b.spc' 's/^-//' --begin --rows 2500 --cols 15000 --elements 35000 --MPS FILE 80bau3b.mps --ERROR FILE 80bau3b.err --SOLUT FILE 80bau3b.res --minimize --end -//GO.SYSIN DD specs/80bau3b.spc -echo specs/adlittle.spc 1>&2 -sed >specs/adlittle.spc <<'//GO.SYSIN DD specs/adlittle.spc' 's/^-//' --begin --rows 60 --cols 200 --elements 600 --MPS FILE adlittle.mps --ERROR FILE adlittle.err --SOLUT FILE adlittle.res --opt tol 1.0D-8 --minimize --end -//GO.SYSIN DD specs/adlittle.spc -echo specs/afiro.spc 1>&2 -sed >specs/afiro.spc <<'//GO.SYSIN DD specs/afiro.spc' 's/^-//' --begin --rows 30 --cols 60 --elements 120 --MPS FILE afiro.mps --ERROR FILE afiro.err --SOLUT FILE afiro.res --rhs name B --objective COST --opt tol 1.0D-8 --minimize --end -//GO.SYSIN DD specs/afiro.spc -echo specs/agg.spc 1>&2 -sed >specs/agg.spc <<'//GO.SYSIN DD specs/agg.spc' 's/^-//' --begin --rows 500 --cols 1000 --elements 4000 --MPS FILE agg.mps --ERROR FILE agg.err --SOLUT FILE agg.res --minimize --end -//GO.SYSIN DD specs/agg.spc -echo specs/agg2.spc 1>&2 -sed >specs/agg2.spc <<'//GO.SYSIN DD specs/agg2.spc' 's/^-//' --begin --rows 600 --cols 1000 --elements 6000 --MPS FILE agg2.mps --ERROR FILE agg2.err --SOLUT FILE agg2.res --minimize --end -//GO.SYSIN DD specs/agg2.spc -echo specs/agg3.spc 1>&2 -sed >specs/agg3.spc <<'//GO.SYSIN DD specs/agg3.spc' 's/^-//' --begin --rows 600 --cols 1000 --elements 6000 --MPS FILE agg3.mps --ERROR FILE agg3.err --SOLUT FILE agg3.res --minimize --end -//GO.SYSIN DD specs/agg3.spc -echo specs/aircraft.spc 1>&2 -sed >specs/aircraft.spc <<'//GO.SYSIN DD specs/aircraft.spc' 's/^-//' --begin --rows 10000 --cols 32000 --elements 120000 --MPS FILE aircraft.mps --ERROR FILE aircraft.err --SOLUT FILE aircraft.res --minimize --end -//GO.SYSIN DD specs/aircraft.spc -echo specs/bandm.spc 1>&2 -sed >specs/bandm.spc <<'//GO.SYSIN DD specs/bandm.spc' 's/^-//' --begin --rows 310 --cols 800 --elements 3000 --MPS FILE bandm.mps --ERROR FILE bandm.err --SOLUT FILE bandm.res --minimize --end -//GO.SYSIN DD specs/bandm.spc -echo specs/beaconfd.spc 1>&2 -sed >specs/beaconfd.spc <<'//GO.SYSIN DD specs/beaconfd.spc' 's/^-//' --begin --rows 180 --cols 500 --elements 4000 --MPS FILE beaconfd.mps --ERROR FILE beaconfd.err --SOLUT FILE beaconfd.res --minimize --end -//GO.SYSIN DD specs/beaconfd.spc -echo specs/bl.spc 1>&2 -sed >specs/bl.spc <<'//GO.SYSIN DD specs/bl.spc' 's/^-//' --begin --rows 7000 --cols 20000 --elements 80000 --MPS FILE BL.mps --ERROR FILE BL.err --SOLUT FILE BL.res --minimize --end -//GO.SYSIN DD specs/bl.spc -echo specs/bl2.spc 1>&2 -sed >specs/bl2.spc <<'//GO.SYSIN DD specs/bl2.spc' 's/^-//' --begin --rows 7000 --cols 20000 --elements 80000 --MPS FILE BL2.mps --ERROR FILE BL2.err --SOLUT FILE BL2.res --minimize --end -//GO.SYSIN DD specs/bl2.spc -echo specs/blend.spc 1>&2 -sed >specs/blend.spc <<'//GO.SYSIN DD specs/blend.spc' 's/^-//' --begin --rows 100 --cols 200 --elements 1000 --MPS FILE blend.mps --ERROR FILE blend.err --SOLUT FILE blend.res --minimize --end -//GO.SYSIN DD specs/blend.spc -echo specs/bnl1.spc 1>&2 -sed >specs/bnl1.spc <<'//GO.SYSIN DD specs/bnl1.spc' 's/^-//' --begin --rows 700 --cols 2000 --elements 7000 --MPS FILE bnl1.mps --ERROR FILE bnl1.err --SOLUT FILE bnl1.res --minimize --end -//GO.SYSIN DD specs/bnl1.spc -echo specs/bnl2.spc 1>&2 -sed >specs/bnl2.spc <<'//GO.SYSIN DD specs/bnl2.spc' 's/^-//' --begin --rows 2400 --cols 6000 --elements 20000 --MPS FILE bnl2.mps --ERROR FILE bnl2.err --SOLUT FILE bnl2.res --minimize --end -//GO.SYSIN DD specs/bnl2.spc -echo specs/boeing1.spc 1>&2 -sed >specs/boeing1.spc <<'//GO.SYSIN DD specs/boeing1.spc' 's/^-//' --begin --rows 400 --cols 800 --elements 5000 --B0 tol 0.05 --fac freq 40 --MPS FILE boeing1.mps --ERROR FILE boeing1.err --SOLUT FILE boeing1.res --minimize --end -//GO.SYSIN DD specs/boeing1.spc -echo specs/boeing2.spc 1>&2 -sed >specs/boeing2.spc <<'//GO.SYSIN DD specs/boeing2.spc' 's/^-//' --begin --rows 200 --cols 400 --elements 2000 --MPS FILE boeing2.mps --ERROR FILE boeing2.err --SOLUT FILE boeing2.res --minimize --end -//GO.SYSIN DD specs/boeing2.spc -echo specs/bore3d.spc 1>&2 -sed >specs/bore3d.spc <<'//GO.SYSIN DD specs/bore3d.spc' 's/^-//' --begin --rows 250 --cols 1000 --elements 2000 --MPS FILE bore3d.mps --ERROR FILE bore3d.err --SOLUT FILE bore3d.res --minimize --end -//GO.SYSIN DD specs/bore3d.spc -echo specs/brandy.spc 1>&2 -sed >specs/brandy.spc <<'//GO.SYSIN DD specs/brandy.spc' 's/^-//' --begin --rows 250 --cols 500 --elements 2500 --MPS FILE brandy.mps --ERROR FILE brandy.err --SOLUT FILE brandy.res --minimize --end -//GO.SYSIN DD specs/brandy.spc -echo specs/capri.spc 1>&2 -sed >specs/capri.spc <<'//GO.SYSIN DD specs/capri.spc' 's/^-//' --begin --rows 300 --cols 1000 --elements 4000 --MPS FILE capri.mps --ERROR FILE capri.err --SOLUT FILE capri.res --minimize --end -//GO.SYSIN DD specs/capri.spc -echo specs/capuc.spc 1>&2 -sed >specs/capuc.spc <<'//GO.SYSIN DD specs/capuc.spc' 's/^-//' --begin --rows 271 --cols 361 --elements 8065 --MPS FILE capuc.mps --ERROR FILE capuc.err --SOLUT FILE capuc.res --RHS name RHS1 --objective OBJECTIF --minimize --end -//GO.SYSIN DD specs/capuc.spc -echo specs/car4.spc 1>&2 -sed >specs/car4.spc <<'//GO.SYSIN DD specs/car4.spc' 's/^-//' --begin --rows 18000 --cols 50000 --elements 100000 --MPS FILE car4.mps --ERROR FILE car4.err --SOLUT FILE car4.res --minimize --end -//GO.SYSIN DD specs/car4.spc -echo specs/cari.spc 1>&2 -sed >specs/cari.spc <<'//GO.SYSIN DD specs/cari.spc' 's/^-//' --begin --rows 1000 --cols 5000 --elements 160000 --MPS FILE cari.mps --ERROR FILE cari.err --SOLUT FILE cari.res --minimize --end -//GO.SYSIN DD specs/cari.spc -echo specs/ch.spc 1>&2 -sed >specs/ch.spc <<'//GO.SYSIN DD specs/ch.spc' 's/^-//' --begin --rows 5000 --cols 10000 --elements 60000 --B0 tol 0.1 --fac freq 30 --MPS FILE CH.mps --ERROR FILE CH.err --SOLUT FILE CH.res --minimize --end -//GO.SYSIN DD specs/ch.spc -echo specs/co5.spc 1>&2 -sed >specs/co5.spc <<'//GO.SYSIN DD specs/co5.spc' 's/^-//' --begin --rows 6000 --cols 20000 --elements 100000 --MPS FILE CO5.mps --ERROR FILE CO5.err --SOLUT FILE CO5.res --minimize --end -//GO.SYSIN DD specs/co5.spc -echo specs/co9.spc 1>&2 -sed >specs/co9.spc <<'//GO.SYSIN DD specs/co9.spc' 's/^-//' --begin --rows 12000 --cols 30000 --elements 200000 --MPS FILE CO9.mps --ERROR FILE CO9.err --SOLUT FILE CO9.res --minimize --end -//GO.SYSIN DD specs/co9.spc -echo specs/complex.spc 1>&2 -sed >specs/complex.spc <<'//GO.SYSIN DD specs/complex.spc' 's/^-//' --begin --rows 1200 --cols 5000 --elements 100000 --MPS FILE complex.mps --ERROR FILE complex.err --SOLUT FILE complex.res --minimize --end -//GO.SYSIN DD specs/complex.spc -echo specs/cq5.spc 1>&2 -sed >specs/cq5.spc <<'//GO.SYSIN DD specs/cq5.spc' 's/^-//' --begin --rows 6000 --cols 20000 --elements 100000 --MPS FILE CQ5.mps --ERROR FILE CQ5.err --SOLUT FILE CQ5.res --minimize --end -//GO.SYSIN DD specs/cq5.spc -echo specs/cq9.spc 1>&2 -sed >specs/cq9.spc <<'//GO.SYSIN DD specs/cq9.spc' 's/^-//' --begin --rows 10000 --cols 30000 --elements 170000 --MPS FILE CQ9.mps --ERROR FILE CQ9.err --SOLUT FILE CQ9.res --minimize --end -//GO.SYSIN DD specs/cq9.spc -echo specs/cr42.spc 1>&2 -sed >specs/cr42.spc <<'//GO.SYSIN DD specs/cr42.spc' 's/^-//' --begin --rows 1000 --cols 5000 --elements 10000 --MPS FILE cr42.mps --ERROR FILE cr42.err --SOLUT FILE cr42.res --minimize --end -//GO.SYSIN DD specs/cr42.spc -echo specs/cre-a.spc 1>&2 -sed >specs/cre-a.spc <<'//GO.SYSIN DD specs/cre-a.spc' 's/^-//' --begin --rows 4000 --cols 10000 --elements 40000 --MPS FILE cre-a.mps --ERROR FILE cre-a.err --SOLUT FILE cre-a.res --minimize --end -//GO.SYSIN DD specs/cre-a.spc -echo specs/cre-b.spc 1>&2 -sed >specs/cre-b.spc <<'//GO.SYSIN DD specs/cre-b.spc' 's/^-//' --begin --rows 10000 --cols 85000 --elements 350000 --MPS FILE cre-b.mps --ERROR FILE cre-b.err --SOLUT FILE cre-b.res --minimize --end -//GO.SYSIN DD specs/cre-b.spc -echo specs/cre-c.spc 1>&2 -sed >specs/cre-c.spc <<'//GO.SYSIN DD specs/cre-c.spc' 's/^-//' --begin --rows 4000 --cols 10000 --elements 40000 --MPS FILE cre-c.mps --ERROR FILE cre-c.err --SOLUT FILE cre-c.res --minimize --end -//GO.SYSIN DD specs/cre-c.spc -echo specs/cre-d.spc 1>&2 -sed >specs/cre-d.spc <<'//GO.SYSIN DD specs/cre-d.spc' 's/^-//' --begin --rows 10000 --cols 80000 --elements 350000 --MPS FILE cre-d.mps --ERROR FILE cre-d.err --SOLUT FILE cre-d.res --minimize --end -//GO.SYSIN DD specs/cre-d.spc -echo specs/cycle.spc 1>&2 -sed >specs/cycle.spc <<'//GO.SYSIN DD specs/cycle.spc' 's/^-//' --begin --rows 2000 --cols 5000 --elements 25000 --MPS FILE cycle.mps --ERROR FILE cycle.err --SOLUT FILE cycle.res --minimize --end -//GO.SYSIN DD specs/cycle.spc -echo specs/czprob.spc 1>&2 -sed >specs/czprob.spc <<'//GO.SYSIN DD specs/czprob.spc' 's/^-//' --begin --rows 1000 --cols 5500 --elements 16000 --MPS FILE czprob.mps --ERROR FILE czprob.err --SOLUT FILE czprob.res --minimize --end -//GO.SYSIN DD specs/czprob.spc -echo specs/d2q06c.spc 1>&2 -sed >specs/d2q06c.spc <<'//GO.SYSIN DD specs/d2q06c.spc' 's/^-//' --begin --rows 2400 --cols 8000 --elements 40000 --B0 tol 0.1 --fac freq 40 --MPS FILE d2q06c.mps --ERROR FILE d2q06c.err --SOLUT FILE d2q06c.res --minimize --end -//GO.SYSIN DD specs/d2q06c.spc -echo specs/d6cube.spc 1>&2 -sed >specs/d6cube.spc <<'//GO.SYSIN DD specs/d6cube.spc' 's/^-//' --begin --rows 500 --cols 8000 --elements 50000 --MPS FILE d6cube.mps --ERROR FILE d6cube.err --SOLUT FILE d6cube.res --minimize --end -//GO.SYSIN DD specs/d6cube.spc -echo specs/degen2.spc 1>&2 -sed >specs/degen2.spc <<'//GO.SYSIN DD specs/degen2.spc' 's/^-//' --begin --rows 500 --cols 1000 --elements 6000 --B0 tol 0.02 --fac freq 40 --MPS FILE degen2.mps --ERROR FILE degen2.err --SOLUT FILE degen2.res --minimize --end -//GO.SYSIN DD specs/degen2.spc -echo specs/degen3.spc 1>&2 -sed >specs/degen3.spc <<'//GO.SYSIN DD specs/degen3.spc' 's/^-//' --begin --rows 1600 --cols 4000 --elements 30000 --B0 tol 0.05 --fac freq 40 --MPS FILE degen3.mps --ERROR FILE degen3.err --SOLUT FILE degen3.res --minimize --end -//GO.SYSIN DD specs/degen3.spc -echo specs/df2177.spc 1>&2 -sed >specs/df2177.spc <<'//GO.SYSIN DD specs/df2177.spc' 's/^-//' --begin --rows 20000 --cols 30000 --elements 180000 --MPS FILE df2177.mps --ERROR FILE df2177.err --SOLUT FILE df2177.res --minimize --end -//GO.SYSIN DD specs/df2177.spc -echo specs/dfl001.spc 1>&2 -sed >specs/dfl001.spc <<'//GO.SYSIN DD specs/dfl001.spc' 's/^-//' --begin --rows 6200 --cols 19000 --elements 50000 --B0 tol 0.02 --fac freq 40 --MPS FILE dfl001.mps --ERROR FILE dfl001.err --SOLUT FILE dfl001.res --opt tol 1.0d-4 --minimize --end -//GO.SYSIN DD specs/dfl001.spc -echo specs/disp3.spc 1>&2 -sed >specs/disp3.spc <<'//GO.SYSIN DD specs/disp3.spc' 's/^-//' --begin --rows 10000 --cols 20000 --elements 100000 --MPS FILE disp3.mps --ERROR FILE disp3.err --SOLUT FILE disp3.res --minimize --end -//GO.SYSIN DD specs/disp3.spc -echo specs/e226.spc 1>&2 -sed >specs/e226.spc <<'//GO.SYSIN DD specs/e226.spc' 's/^-//' --begin --rows 300 --cols 1000 --elements 4000 --MPS FILE e226.mps --ERROR FILE e226.err --SOLUT FILE e226.res --minimize --end -//GO.SYSIN DD specs/e226.spc -echo specs/embed.spc 1>&2 -sed >specs/embed.spc <<'//GO.SYSIN DD specs/embed.spc' 's/^-//' --begin --rows 150 --cols 300 --elements 800 --MPS FILE embed.mps --ERROR FILE embed.err --SOLUT FILE embed.res --RHS name RHS1 --objective OBJECTIF --minimize --end -//GO.SYSIN DD specs/embed.spc -echo specs/etamacro.spc 1>&2 -sed >specs/etamacro.spc <<'//GO.SYSIN DD specs/etamacro.spc' 's/^-//' --begin --rows 450 --cols 1500 --elements 3500 --MPS FILE etamacro.mps --ERROR FILE etamacro.err --SOLUT FILE etamacro.res --minimize --end -//GO.SYSIN DD specs/etamacro.spc -echo specs/farm.spc 1>&2 -sed >specs/farm.spc <<'//GO.SYSIN DD specs/farm.spc' 's/^-//' --begin --rows 100 --cols 500 --elements 2000 --MPS FILE farm.mps --ERROR FILE farm.err --SOLUT FILE farm.res --minimize --end -//GO.SYSIN DD specs/farm.spc -echo specs/fffff800.spc 1>&2 -sed >specs/fffff800.spc <<'//GO.SYSIN DD specs/fffff800.spc' 's/^-//' --begin --rows 540 --cols 2000 --elements 7000 --MPS FILE fffff800.mps --ERROR FILE fffff800.err --SOLUT FILE fffff800.res --minimize --end -//GO.SYSIN DD specs/fffff800.spc -echo specs/finnis.spc 1>&2 -sed >specs/finnis.spc <<'//GO.SYSIN DD specs/finnis.spc' 's/^-//' --begin --rows 500 --cols 1100 --elements 4000 --MPS FILE finnis.mps --ERROR FILE finnis.err --SOLUT FILE finnis.res --minimize --end -//GO.SYSIN DD specs/finnis.spc -echo specs/fit1d.spc 1>&2 -sed >specs/fit1d.spc <<'//GO.SYSIN DD specs/fit1d.spc' 's/^-//' --begin --rows 30 --cols 1100 --elements 15000 --MPS FILE fit1d.mps --ERROR FILE fit1d.err --SOLUT FILE fit1d.res --minimize --end -//GO.SYSIN DD specs/fit1d.spc -echo specs/fit1p.spc 1>&2 -sed >specs/fit1p.spc <<'//GO.SYSIN DD specs/fit1p.spc' 's/^-//' --begin --rows 800 --cols 3000 --elements 13000 --MPS FILE fit1p.mps --ERROR FILE fit1p.err --SOLUT FILE fit1p.res --minimize --end -//GO.SYSIN DD specs/fit1p.spc -echo specs/fit2d.spc 1>&2 -sed >specs/fit2d.spc <<'//GO.SYSIN DD specs/fit2d.spc' 's/^-//' --begin --rows 30 --cols 11000 --elements 140000 --MPS FILE fit2d.mps --ERROR FILE fit2d.err --SOLUT FILE fit2d.res --minimize --end -//GO.SYSIN DD specs/fit2d.spc -echo specs/fit2p.spc 1>&2 -sed >specs/fit2p.spc <<'//GO.SYSIN DD specs/fit2p.spc' 's/^-//' --begin --rows 4000 --cols 18000 --elements 70000 --MPS FILE fit2p.mps --ERROR FILE fit2p.err --SOLUT FILE fit2p.res --minimize --end -//GO.SYSIN DD specs/fit2p.spc -echo specs/forplan.spc 1>&2 -sed >specs/forplan.spc <<'//GO.SYSIN DD specs/forplan.spc' 's/^-//' --begin --rows 200 --cols 1000 --elements 6000 --MPS FILE forplan.mps --ERROR FILE forplan.err --SOLUT FILE forplan.res --minimize --end -//GO.SYSIN DD specs/forplan.spc -echo specs/ganges.spc 1>&2 -sed >specs/ganges.spc <<'//GO.SYSIN DD specs/ganges.spc' 's/^-//' --begin --rows 1400 --cols 4500 --elements 10000 --MPS FILE ganges.mps --ERROR FILE ganges.err --SOLUT FILE ganges.res --minimize --end -//GO.SYSIN DD specs/ganges.spc -echo specs/ge.spc 1>&2 -sed >specs/ge.spc <<'//GO.SYSIN DD specs/ge.spc' 's/^-//' --begin --rows 11000 --cols 20000 --elements 80000 --B0 tol 0.1 --fac freq 20 --MPS FILE GE.mps --ERROR FILE GE.err --SOLUT FILE GE.res --minimize --end -//GO.SYSIN DD specs/ge.spc -echo specs/gen.spc 1>&2 -sed >specs/gen.spc <<'//GO.SYSIN DD specs/gen.spc' 's/^-//' --begin --rows 1000 --cols 5000 --elements 80000 --MPS FILE gen.mps --ERROR FILE gen.err --SOLUT FILE gen.res --objective OBJECT --minimize --end -//GO.SYSIN DD specs/gen.spc -echo specs/gen1.spc 1>&2 -sed >specs/gen1.spc <<'//GO.SYSIN DD specs/gen1.spc' 's/^-//' --begin --rows 800 --cols 5000 --elements 80000 --MPS FILE gen1.mps --ERROR FILE gen1.err --SOLUT FILE gen1.res --minimize --end -//GO.SYSIN DD specs/gen1.spc -echo specs/gen2.spc 1>&2 -sed >specs/gen2.spc <<'//GO.SYSIN DD specs/gen2.spc' 's/^-//' --begin --rows 1200 --cols 6000 --elements 100000 --MPS FILE gen2.mps --ERROR FILE gen2.err --SOLUT FILE gen2.res --minimize --end -//GO.SYSIN DD specs/gen2.spc -echo specs/geneva.spc 1>&2 -sed >specs/geneva.spc <<'//GO.SYSIN DD specs/geneva.spc' 's/^-//' --begin --rows 22000 --cols 50000 --elements 140000 --MPS FILE geneva.mps --ERROR FILE geneva.err --SOLUT FILE geneva.res --minimize --end -//GO.SYSIN DD specs/geneva.spc -echo specs/gfrd-pnc.spc 1>&2 -sed >specs/gfrd-pnc.spc <<'//GO.SYSIN DD specs/gfrd-pnc.spc' 's/^-//' --begin --rows 620 --cols 2000 --elements 5000 --MPS FILE gfrd-pnc.mps --ERROR FILE gfrd-pnc.err --SOLUT FILE gfrd-pnc.res --minimize --end -//GO.SYSIN DD specs/gfrd-pnc.spc -echo specs/greenbea.spc 1>&2 -sed >specs/greenbea.spc <<'//GO.SYSIN DD specs/greenbea.spc' 's/^-//' --begin --rows 2500 --cols 10000 --elements 35000 --MPS FILE greenbea.mps --ERROR FILE greenbea.err --SOLUT FILE greenbea.res --minimize --end -//GO.SYSIN DD specs/greenbea.spc -echo specs/greenbeb.spc 1>&2 -sed >specs/greenbeb.spc <<'//GO.SYSIN DD specs/greenbeb.spc' 's/^-//' --begin --rows 2500 --cols 10000 --elements 35000 --MPS FILE greenbeb.mps --ERROR FILE greenbeb.err --SOLUT FILE greenbeb.res --minimize --end -//GO.SYSIN DD specs/greenbeb.spc -echo specs/grow15.spc 1>&2 -sed >specs/grow15.spc <<'//GO.SYSIN DD specs/grow15.spc' 's/^-//' --begin --rows 310 --cols 1000 --elements 6000 --MPS FILE grow15.mps --ERROR FILE grow15.err --SOLUT FILE grow15.res --minimize --end -//GO.SYSIN DD specs/grow15.spc -echo specs/grow22.spc 1>&2 -sed >specs/grow22.spc <<'//GO.SYSIN DD specs/grow22.spc' 's/^-//' --begin --rows 450 --cols 1500 --elements 9000 --MPS FILE grow22.mps --ERROR FILE grow22.err --SOLUT FILE grow22.res --minimize --end -//GO.SYSIN DD specs/grow22.spc -echo specs/grow7.spc 1>&2 -sed >specs/grow7.spc <<'//GO.SYSIN DD specs/grow7.spc' 's/^-//' --begin --rows 150 --cols 500 --elements 3000 --MPS FILE grow7.mps --ERROR FILE grow7.err --SOLUT FILE grow7.res --minimize --end -//GO.SYSIN DD specs/grow7.spc -echo specs/hedge.spc 1>&2 -sed >specs/hedge.spc <<'//GO.SYSIN DD specs/hedge.spc' 's/^-//' --begin --rows 100 --cols 500 --elements 2000 --MPS FILE hedge.mps --ERROR FILE hedge.err --SOLUT FILE hedge.res --minimize --end -//GO.SYSIN DD specs/hedge.spc -echo specs/israel.spc 1>&2 -sed >specs/israel.spc <<'//GO.SYSIN DD specs/israel.spc' 's/^-//' --begin --rows 240 --cols 400 --elements 2600 --MPS FILE israel.mps --ERROR FILE israel.err --SOLUT FILE israel.res --minimize --end -//GO.SYSIN DD specs/israel.spc -echo specs/kb2.spc 1>&2 -sed >specs/kb2.spc <<'//GO.SYSIN DD specs/kb2.spc' 's/^-//' --begin --rows 50 --cols 100 --elements 1000 --MPS FILE kb2.mps --ERROR FILE kb2.err --SOLUT FILE kb2.res --minimize --end -//GO.SYSIN DD specs/kb2.spc -echo specs/ken-07.spc 1>&2 -sed >specs/ken-07.spc <<'//GO.SYSIN DD specs/ken-07.spc' 's/^-//' --begin --rows 3000 --cols 10000 --elements 20000 --MPS FILE ken-07.mps --ERROR FILE ken-07.err --SOLUT FILE ken-07.res --minimize --end -//GO.SYSIN DD specs/ken-07.spc -echo specs/ken-11.spc 1>&2 -sed >specs/ken-11.spc <<'//GO.SYSIN DD specs/ken-11.spc' 's/^-//' --begin --rows 15000 --cols 32000 --elements 100000 --MPS FILE ken-11.mps --ERROR FILE ken-11.err --SOLUT FILE ken-11.res --minimize --end -//GO.SYSIN DD specs/ken-11.spc -echo specs/ken-13.spc 1>&2 -sed >specs/ken-13.spc <<'//GO.SYSIN DD specs/ken-13.spc' 's/^-//' --begin --rows 30000 --cols 75000 --elements 200000 --MPS FILE ken-13.mps --ERROR FILE ken-13.err --SOLUT FILE ken-13.res --minimize --end -//GO.SYSIN DD specs/ken-13.spc -echo specs/ken-18.spc 1>&2 -sed >specs/ken-18.spc <<'//GO.SYSIN DD specs/ken-18.spc' 's/^-//' --begin --rows 106000 --cols 250000 --elements 700000 --MPS FILE ken-18.mps --ERROR FILE ken-18.err --SOLUT FILE ken-18.res --minimize --end -//GO.SYSIN DD specs/ken-18.spc -echo specs/klopot1.spc 1>&2 -sed >specs/klopot1.spc <<'//GO.SYSIN DD specs/klopot1.spc' 's/^-//' --begin --rows 12 --cols 20 --elements 100 --MPS FILE klopot1.mps --ERROR FILE klopot1.err --SOLUT FILE klopot1.res --RHS name RHS1 --objective OBJECTIF --minimize --end -//GO.SYSIN DD specs/klopot1.spc -echo specs/klopot2.spc 1>&2 -sed >specs/klopot2.spc <<'//GO.SYSIN DD specs/klopot2.spc' 's/^-//' --begin --rows 11 --cols 30 --elements 100 --MPS FILE klopot2.mps --ERROR FILE klopot2.err --SOLUT FILE klopot2.res --RHS name RHS1 --objective OBJECTIF --minimize --end -//GO.SYSIN DD specs/klopot2.spc -echo specs/l30.spc 1>&2 -sed >specs/l30.spc <<'//GO.SYSIN DD specs/l30.spc' 's/^-//' --begin --rows 5000 --cols 30000 --elements 100000 --MPS FILE l30.mps --ERROR FILE l30.err --SOLUT FILE l30.res --minimize --end -//GO.SYSIN DD specs/l30.spc -echo specs/l9.spc 1>&2 -sed >specs/l9.spc <<'//GO.SYSIN DD specs/l9.spc' 's/^-//' --begin --rows 500 --cols 3000 --elements 10000 --MPS FILE l9.mps --ERROR FILE l9.err --SOLUT FILE l9.res --minimize --end -//GO.SYSIN DD specs/l9.spc -echo specs/lotfi.spc 1>&2 -sed >specs/lotfi.spc <<'//GO.SYSIN DD specs/lotfi.spc' 's/^-//' --begin --rows 200 --cols 500 --elements 2000 --MPS FILE lotfi.mps --ERROR FILE lotfi.err --SOLUT FILE lotfi.res --minimize --end -//GO.SYSIN DD specs/lotfi.spc -echo specs/marek.spc 1>&2 -sed >specs/marek.spc <<'//GO.SYSIN DD specs/marek.spc' 's/^-//' --begin --rows 20 --cols 30 --elements 100 --MPS FILE marek.mps --ERROR FILE marek.err --SOLUT FILE marek.res --minimize --end -//GO.SYSIN DD specs/marek.spc -echo specs/maros-r7.spc 1>&2 -sed >specs/maros-r7.spc <<'//GO.SYSIN DD specs/maros-r7.spc' 's/^-//' --begin --rows 3200 --cols 20000 --elements 160000 --B0 tol 0.1 --fac freq 40 --MPS FILE maros-r7.mps --ERROR FILE maros-r7.err --SOLUT FILE maros-r7.res --minimize --end -//GO.SYSIN DD specs/maros-r7.spc -echo specs/maros.spc 1>&2 -sed >specs/maros.spc <<'//GO.SYSIN DD specs/maros.spc' 's/^-//' --begin --rows 900 --cols 2500 --elements 11000 --MPS FILE maros.mps --ERROR FILE maros.err --SOLUT FILE maros.res --minimize --end -//GO.SYSIN DD specs/maros.spc -echo specs/mod2.spc 1>&2 -sed >specs/mod2.spc <<'//GO.SYSIN DD specs/mod2.spc' 's/^-//' --begin --rows 36000 --cols 68000 --elements 260000 --B0 tol 0.01 --fac freq 40 --MPS FILE mod2.mps --ERROR FILE mod2.err --SOLUT FILE mod2.res --minimize --end -//GO.SYSIN DD specs/mod2.spc -echo specs/modszk1.spc 1>&2 -sed >specs/modszk1.spc <<'//GO.SYSIN DD specs/modszk1.spc' 's/^-//' --begin --rows 1000 --cols 3000 --elements 5000 --MPS FILE modszk1.mps --ERROR FILE modszk1.err --SOLUT FILE modszk1.res --minimize --end -//GO.SYSIN DD specs/modszk1.spc -echo specs/nesm.spc 1>&2 -sed >specs/nesm.spc <<'//GO.SYSIN DD specs/nesm.spc' 's/^-//' --begin --rows 700 --cols 4500 --elements 15000 --MPS FILE nesm.mps --ERROR FILE nesm.err --SOLUT FILE nesm.res --minimize --end -//GO.SYSIN DD specs/nesm.spc -echo specs/nl.spc 1>&2 -sed >specs/nl.spc <<'//GO.SYSIN DD specs/nl.spc' 's/^-//' --begin --rows 8000 --cols 20000 --elements 120000 --B0 tol 0.05 --fac freq 25 --MPS FILE NL.mps --ERROR FILE NL.err --SOLUT FILE NL.res --minimize --end -//GO.SYSIN DD specs/nl.spc -echo specs/orswq2.spc 1>&2 -sed >specs/orswq2.spc <<'//GO.SYSIN DD specs/orswq2.spc' 's/^-//' --begin --rows 10000 --cols 30000 --elements 120000 --MPS FILE orswq2.mps --ERROR FILE orswq2.err --SOLUT FILE orswq2.res --minimize --end -//GO.SYSIN DD specs/orswq2.spc -echo specs/osa-07.spc 1>&2 -sed >specs/osa-07.spc <<'//GO.SYSIN DD specs/osa-07.spc' 's/^-//' --begin --rows 1200 --cols 26000 --elements 170000 --MPS FILE osa-07.mps --ERROR FILE osa-07.err --SOLUT FILE osa-07.res --minimize --end -//GO.SYSIN DD specs/osa-07.spc -echo specs/osa-14.spc 1>&2 -sed >specs/osa-14.spc <<'//GO.SYSIN DD specs/osa-14.spc' 's/^-//' --begin --rows 2400 --cols 55000 --elements 380000 --MPS FILE osa-14.mps --ERROR FILE osa-14.err --SOLUT FILE osa-14.res --minimize --end -//GO.SYSIN DD specs/osa-14.spc -echo specs/osa-30.spc 1>&2 -sed >specs/osa-30.spc <<'//GO.SYSIN DD specs/osa-30.spc' 's/^-//' --begin --rows 4400 --cols 110000 --elements 710000 --MPS FILE osa-30.mps --ERROR FILE osa-30.err --SOLUT FILE osa-30.res --minimize --end -//GO.SYSIN DD specs/osa-30.spc -echo specs/pata01.spc 1>&2 -sed >specs/pata01.spc <<'//GO.SYSIN DD specs/pata01.spc' 's/^-//' --begin --rows 500 --cols 2000 --elements 5000 --MPS FILE pata01.mps --ERROR FILE pata01.err --SOLUT FILE pata01.res --minimize --end -//GO.SYSIN DD specs/pata01.spc -echo specs/pata02.spc 1>&2 -sed >specs/pata02.spc <<'//GO.SYSIN DD specs/pata02.spc' 's/^-//' --begin --rows 500 --cols 2000 --elements 5000 --MPS FILE pata02.mps --ERROR FILE pata02.err --SOLUT FILE pata02.res --minimize --end -//GO.SYSIN DD specs/pata02.spc -echo specs/patb01.spc 1>&2 -sed >specs/patb01.spc <<'//GO.SYSIN DD specs/patb01.spc' 's/^-//' --begin --rows 500 --cols 1000 --elements 5000 --MPS FILE patb01.mps --ERROR FILE patb01.err --SOLUT FILE patb01.res --minimize --end -- -//GO.SYSIN DD specs/patb01.spc -echo specs/patb02.spc 1>&2 -sed >specs/patb02.spc <<'//GO.SYSIN DD specs/patb02.spc' 's/^-//' --begin --rows 500 --cols 1000 --elements 5000 --MPS FILE patb02.mps --ERROR FILE patb02.err --SOLUT FILE patb02.res --minimize --end -- -//GO.SYSIN DD specs/patb02.spc -echo specs/pc001.spc 1>&2 -sed >specs/pc001.spc <<'//GO.SYSIN DD specs/pc001.spc' 's/^-//' --begin --rows 700 --cols 2000 --elements 4000 --MPS FILE pc001.mps --ERROR FILE pc001.err --SOLUT FILE pc001.res --minimize --end -//GO.SYSIN DD specs/pc001.spc -echo specs/pc002.spc 1>&2 -sed >specs/pc002.spc <<'//GO.SYSIN DD specs/pc002.spc' 's/^-//' --begin --rows 300 --cols 1000 --elements 3000 --MPS FILE pc002.mps --ERROR FILE pc002.err --SOLUT FILE pc002.res --minimize --end -//GO.SYSIN DD specs/pc002.spc -echo specs/pds-02.spc 1>&2 -sed >specs/pds-02.spc <<'//GO.SYSIN DD specs/pds-02.spc' 's/^-//' --begin --rows 3000 --cols 12000 --elements 30000 --MPS FILE pds-02.mps --ERROR FILE pds-02.err --SOLUT FILE pds-02.res --minimize --end -//GO.SYSIN DD specs/pds-02.spc -echo specs/pds-06.spc 1>&2 -sed >specs/pds-06.spc <<'//GO.SYSIN DD specs/pds-06.spc' 's/^-//' --begin --rows 10000 --cols 60000 --elements 100000 --B0 tol 0.01 --fac freq 40 --MPS FILE pds-06.mps --ERROR FILE pds-06.err --SOLUT FILE pds-06.res --minimize --end -//GO.SYSIN DD specs/pds-06.spc -echo specs/pds-10.spc 1>&2 -sed >specs/pds-10.spc <<'//GO.SYSIN DD specs/pds-10.spc' 's/^-//' --begin --rows 17000 --cols 70000 --elements 170000 --B0 tol 0.01 --fac freq 40 --MPS FILE pds-10.mps --ERROR FILE pds-10.err --SOLUT FILE pds-10.res --minimize --end -//GO.SYSIN DD specs/pds-10.spc -echo specs/pds-20.spc 1>&2 -sed >specs/pds-20.spc <<'//GO.SYSIN DD specs/pds-20.spc' 's/^-//' --begin --rows 34000 --cols 110000 --elements 310000 --B0 tol 0.01 --fac freq 40 --MPS FILE pds-20.mps --ERROR FILE pds-20.err --SOLUT FILE pds-20.res --minimize --end -//GO.SYSIN DD specs/pds-20.spc -echo specs/perold.spc 1>&2 -sed >specs/perold.spc <<'//GO.SYSIN DD specs/perold.spc' 's/^-//' --begin --rows 1000 --cols 2500 --elements 10000 --B0 tol 0.02 --fac freq 40 --MPS FILE perold.mps --ERROR FILE perold.err --SOLUT FILE perold.res --minimize --end -//GO.SYSIN DD specs/perold.spc -echo specs/pf2177.spc 1>&2 -sed >specs/pf2177.spc <<'//GO.SYSIN DD specs/pf2177.spc' 's/^-//' --begin --rows 20000 --cols 30000 --elements 180000 --MPS FILE pf2177.mps --ERROR FILE pf2177.err --SOLUT FILE pf2177.res --minimize --end -//GO.SYSIN DD specs/pf2177.spc -echo specs/pilot.spc 1>&2 -sed >specs/pilot.spc <<'//GO.SYSIN DD specs/pilot.spc' 's/^-//' --begin --rows 1600 --cols 7000 --elements 48000 --B0 tol 0.025 --fac freq 20 --MPS FILE pilot.mps --ERROR FILE pilot.err --SOLUT FILE pilot.res --minimize --end -//GO.SYSIN DD specs/pilot.spc -echo specs/pilot4.spc 1>&2 -sed >specs/pilot4.spc <<'//GO.SYSIN DD specs/pilot4.spc' 's/^-//' --begin --rows 500 --cols 2000 --elements 10000 --MPS FILE pilot4.mps --ERROR FILE pilot4.err --SOLUT FILE pilot4.res --minimize --end -//GO.SYSIN DD specs/pilot4.spc -echo specs/pilot87.spc 1>&2 -sed >specs/pilot87.spc <<'//GO.SYSIN DD specs/pilot87.spc' 's/^-//' --begin --rows 2400 --cols 7000 --elements 80000 --B0 tol 0.2 --fac freq 20 --MPS FILE pilot87.mps --ERROR FILE pilot87.err --SOLUT FILE pilot87.res --minimize --end -//GO.SYSIN DD specs/pilot87.spc -echo specs/pilot_ja.spc 1>&2 -sed >specs/pilot_ja.spc <<'//GO.SYSIN DD specs/pilot_ja.spc' 's/^-//' --begin --rows 1000 --cols 4000 --elements 18000 --B0 tol 0.02 --fac freq 25 --MPS FILE pilot_ja.mps --ERROR FILE pilot_ja.err --SOLUT FILE pilot_ja.res --minimize --end -//GO.SYSIN DD specs/pilot_ja.spc -echo specs/pilot_we.spc 1>&2 -sed >specs/pilot_we.spc <<'//GO.SYSIN DD specs/pilot_we.spc' 's/^-//' --begin --rows 750 --cols 5000 --elements 13000 --MPS FILE pilot_we.mps --ERROR FILE pilot_we.err --SOLUT FILE pilot_we.res --minimize --end -//GO.SYSIN DD specs/pilot_we.spc -echo specs/pilotnov.spc 1>&2 -sed >specs/pilotnov.spc <<'//GO.SYSIN DD specs/pilotnov.spc' 's/^-//' --begin --rows 1000 --cols 4000 --elements 15000 --B0 tol 0.02 --fac freq 40 --MPS FILE pilotnov.mps --ERROR FILE pilotnov.err --SOLUT FILE pilotnov.res --minimize --end -//GO.SYSIN DD specs/pilotnov.spc -echo specs/progas.spc 1>&2 -sed >specs/progas.spc <<'//GO.SYSIN DD specs/progas.spc' 's/^-//' --begin --rows 2000 --cols 5000 --elements 12000 --MPS FILE progas.mps --ERROR FILE progas.err --SOLUT FILE progas.res --minimize --end -//GO.SYSIN DD specs/progas.spc -echo specs/recipe.spc 1>&2 -sed >specs/recipe.spc <<'//GO.SYSIN DD specs/recipe.spc' 's/^-//' --begin --rows 100 --cols 400 --elements 1500 --MPS FILE recipe.mps --ERROR FILE recipe.err --SOLUT FILE recipe.res --minimize --end -//GO.SYSIN DD specs/recipe.spc -echo specs/refine.spc 1>&2 -sed >specs/refine.spc <<'//GO.SYSIN DD specs/refine.spc' 's/^-//' --begin --rows 100 --cols 200 --elements 2000 --MPS FILE refine.mps --ERROR FILE refine.err --SOLUT FILE refine.res --minimize --end -//GO.SYSIN DD specs/refine.spc -echo specs/sc105.spc 1>&2 -sed >specs/sc105.spc <<'//GO.SYSIN DD specs/sc105.spc' 's/^-//' --begin --rows 200 --cols 400 --elements 1000 --MPS FILE sc105.mps --ERROR FILE sc105.err --SOLUT FILE sc105.res --minimize --end -//GO.SYSIN DD specs/sc105.spc -echo specs/sc205.spc 1>&2 -sed >specs/sc205.spc <<'//GO.SYSIN DD specs/sc205.spc' 's/^-//' --begin --rows 300 --cols 800 --elements 1000 --MPS FILE sc205.mps --ERROR FILE sc205.err --SOLUT FILE sc205.res --minimize --end -//GO.SYSIN DD specs/sc205.spc -echo specs/sc50a.spc 1>&2 -sed >specs/sc50a.spc <<'//GO.SYSIN DD specs/sc50a.spc' 's/^-//' --begin --rows 100 --cols 200 --elements 1000 --MPS FILE sc50a.mps --ERROR FILE sc50a.err --SOLUT FILE sc50a.res --minimize --end -//GO.SYSIN DD specs/sc50a.spc -echo specs/sc50b.spc 1>&2 -sed >specs/sc50b.spc <<'//GO.SYSIN DD specs/sc50b.spc' 's/^-//' --begin --rows 100 --cols 200 --elements 1000 --MPS FILE sc50b.mps --ERROR FILE sc50b.err --SOLUT FILE sc50b.res --minimize --end -//GO.SYSIN DD specs/sc50b.spc -echo specs/scagr25.spc 1>&2 -sed >specs/scagr25.spc <<'//GO.SYSIN DD specs/scagr25.spc' 's/^-//' --begin --rows 480 --cols 1000 --elements 3000 --MPS FILE scagr25.mps --ERROR FILE scagr25.err --SOLUT FILE scagr25.res --minimize --end -//GO.SYSIN DD specs/scagr25.spc -echo specs/scagr7.spc 1>&2 -sed >specs/scagr7.spc <<'//GO.SYSIN DD specs/scagr7.spc' 's/^-//' --begin --rows 150 --cols 500 --elements 1500 --MPS FILE scagr7.mps --ERROR FILE scagr7.err --SOLUT FILE scagr7.res --minimize --end -//GO.SYSIN DD specs/scagr7.spc -echo specs/scfxm1.spc 1>&2 -sed >specs/scfxm1.spc <<'//GO.SYSIN DD specs/scfxm1.spc' 's/^-//' --begin --rows 340 --cols 1000 --elements 3000 --MPS FILE scfxm1.mps --ERROR FILE scfxm1.err --SOLUT FILE scfxm1.res --minimize --end -//GO.SYSIN DD specs/scfxm1.spc -echo specs/scfxm2.spc 1>&2 -sed >specs/scfxm2.spc <<'//GO.SYSIN DD specs/scfxm2.spc' 's/^-//' --begin --rows 700 --cols 2000 --elements 7000 --MPS FILE scfxm2.mps --ERROR FILE scfxm2.err --SOLUT FILE scfxm2.res --minimize --end -//GO.SYSIN DD specs/scfxm2.spc -echo specs/scfxm3.spc 1>&2 -sed >specs/scfxm3.spc <<'//GO.SYSIN DD specs/scfxm3.spc' 's/^-//' --begin --rows 1000 --cols 3000 --elements 9000 --MPS FILE scfxm3.mps --ERROR FILE scfxm3.err --SOLUT FILE scfxm3.res --minimize --end -//GO.SYSIN DD specs/scfxm3.spc -echo specs/scorpion.spc 1>&2 -sed >specs/scorpion.spc <<'//GO.SYSIN DD specs/scorpion.spc' 's/^-//' --begin --rows 400 --cols 1500 --elements 3500 --MPS FILE scorpion.mps --ERROR FILE scorpion.err --SOLUT FILE scorpion.res --minimize --end -//GO.SYSIN DD specs/scorpion.spc -echo specs/scrs8.spc 1>&2 -sed >specs/scrs8.spc <<'//GO.SYSIN DD specs/scrs8.spc' 's/^-//' --begin --rows 500 --cols 1700 --elements 5000 --MPS FILE scrs8.mps --ERROR FILE scrs8.err --SOLUT FILE scrs8.res --minimize --end -//GO.SYSIN DD specs/scrs8.spc -echo specs/scsd1.spc 1>&2 -sed >specs/scsd1.spc <<'//GO.SYSIN DD specs/scsd1.spc' 's/^-//' --begin --rows 100 --cols 1000 --elements 4000 --MPS FILE scsd1.mps --ERROR FILE scsd1.err --SOLUT FILE scsd1.res --minimize --end -//GO.SYSIN DD specs/scsd1.spc -echo specs/scsd6.spc 1>&2 -sed >specs/scsd6.spc <<'//GO.SYSIN DD specs/scsd6.spc' 's/^-//' --begin --rows 150 --cols 1600 --elements 6000 --MPS FILE scsd6.mps --ERROR FILE scsd6.err --SOLUT FILE scsd6.res --minimize --end -//GO.SYSIN DD specs/scsd6.spc -echo specs/scsd8.spc 1>&2 -sed >specs/scsd8.spc <<'//GO.SYSIN DD specs/scsd8.spc' 's/^-//' --begin --rows 400 --cols 3600 --elements 12000 --B0 tol 0.1 --fac freq 40 --MPS FILE scsd8.mps --ERROR FILE scsd8.err --SOLUT FILE scsd8.res --minimize --end -//GO.SYSIN DD specs/scsd8.spc -echo specs/sctap1.spc 1>&2 -sed >specs/sctap1.spc <<'//GO.SYSIN DD specs/sctap1.spc' 's/^-//' --begin --rows 310 --cols 1000 --elements 2500 --MPS FILE sctap1.mps --ERROR FILE sctap1.err --SOLUT FILE sctap1.res --minimize --end -//GO.SYSIN DD specs/sctap1.spc -echo specs/sctap2.spc 1>&2 -sed >specs/sctap2.spc <<'//GO.SYSIN DD specs/sctap2.spc' 's/^-//' --begin --rows 1100 --cols 3000 --elements 10000 --MPS FILE sctap2.mps --ERROR FILE sctap2.err --SOLUT FILE sctap2.res --minimize --end -//GO.SYSIN DD specs/sctap2.spc -echo specs/sctap3.spc 1>&2 -sed >specs/sctap3.spc <<'//GO.SYSIN DD specs/sctap3.spc' 's/^-//' --begin --rows 1500 --cols 5000 --elements 13000 --MPS FILE sctap3.mps --ERROR FILE sctap3.err --SOLUT FILE sctap3.res --minimize --end -//GO.SYSIN DD specs/sctap3.spc -echo specs/seba.spc 1>&2 -sed >specs/seba.spc <<'//GO.SYSIN DD specs/seba.spc' 's/^-//' --begin --rows 650 --cols 1600 --elements 5500 --MPS FILE seba.mps --ERROR FILE seba.err --SOLUT FILE seba.res --minimize --end -//GO.SYSIN DD specs/seba.spc -echo specs/share1b.spc 1>&2 -sed >specs/share1b.spc <<'//GO.SYSIN DD specs/share1b.spc' 's/^-//' --begin --rows 120 --cols 500 --elements 1500 --MPS FILE share1b.mps --ERROR FILE share1b.err --SOLUT FILE share1b.res --minimize --end -//GO.SYSIN DD specs/share1b.spc -echo specs/share2b.spc 1>&2 -sed >specs/share2b.spc <<'//GO.SYSIN DD specs/share2b.spc' 's/^-//' --begin --rows 100 --cols 300 --elements 1000 --MPS FILE share2b.mps --ERROR FILE share2b.err --SOLUT FILE share2b.res --minimize --end -//GO.SYSIN DD specs/share2b.spc -echo specs/shell.spc 1>&2 -sed >specs/shell.spc <<'//GO.SYSIN DD specs/shell.spc' 's/^-//' --begin --rows 550 --cols 3000 --elements 6000 --MPS FILE shell.mps --ERROR FILE shell.err --SOLUT FILE shell.res --minimize --end -//GO.SYSIN DD specs/shell.spc -echo specs/ship04l.spc 1>&2 -sed >specs/ship04l.spc <<'//GO.SYSIN DD specs/ship04l.spc' 's/^-//' --begin --rows 410 --cols 3000 --elements 9000 --MPS FILE ship04l.mps --ERROR FILE ship04l.err --SOLUT FILE ship04l.res --minimize --end -//GO.SYSIN DD specs/ship04l.spc -echo specs/ship04s.spc 1>&2 -sed >specs/ship04s.spc <<'//GO.SYSIN DD specs/ship04s.spc' 's/^-//' --begin --rows 410 --cols 2000 --elements 7000 --MPS FILE ship04s.mps --ERROR FILE ship04s.err --SOLUT FILE ship04s.res --minimize --end -//GO.SYSIN DD specs/ship04s.spc -echo specs/ship08l.spc 1>&2 -sed >specs/ship08l.spc <<'//GO.SYSIN DD specs/ship08l.spc' 's/^-//' --begin --rows 800 --cols 5000 --elements 20000 --MPS FILE ship08l.mps --ERROR FILE ship08l.err --SOLUT FILE ship08l.res --minimize --end -//GO.SYSIN DD specs/ship08l.spc -echo specs/ship08s.spc 1>&2 -sed >specs/ship08s.spc <<'//GO.SYSIN DD specs/ship08s.spc' 's/^-//' --begin --rows 800 --cols 3300 --elements 10000 --MPS FILE ship08s.mps --ERROR FILE ship08s.err --SOLUT FILE ship08s.res --minimize --end -//GO.SYSIN DD specs/ship08s.spc -echo specs/ship12l.spc 1>&2 -sed >specs/ship12l.spc <<'//GO.SYSIN DD specs/ship12l.spc' 's/^-//' --begin --rows 1200 --cols 7000 --elements 24000 --MPS FILE ship12l.mps --ERROR FILE ship12l.err --SOLUT FILE ship12l.res --minimize --end -//GO.SYSIN DD specs/ship12l.spc -echo specs/ship12s.spc 1>&2 -sed >specs/ship12s.spc <<'//GO.SYSIN DD specs/ship12s.spc' 's/^-//' --begin --rows 1200 --cols 4100 --elements 12000 --MPS FILE ship12s.mps --ERROR FILE ship12s.err --SOLUT FILE ship12s.res --minimize --end -//GO.SYSIN DD specs/ship12s.spc -echo specs/sierra.spc 1>&2 -sed >specs/sierra.spc <<'//GO.SYSIN DD specs/sierra.spc' 's/^-//' --begin --rows 1300 --cols 5000 --elements 11000 --B0 tol 0.5 --fac freq 40 --MPS FILE sierra.mps --ERROR FILE sierra.err --SOLUT FILE sierra.res --minimize --end -//GO.SYSIN DD specs/sierra.spc -echo specs/slptsk.spc 1>&2 -sed >specs/slptsk.spc <<'//GO.SYSIN DD specs/slptsk.spc' 's/^-//' --begin --rows 5000 --cols 10000 --elements 100000 --MPS FILE slptsk.mps --ERROR FILE slptsk.err --SOLUT FILE slptsk.res --minimize --end -//GO.SYSIN DD specs/slptsk.spc -echo specs/south31.spc 1>&2 -sed >specs/south31.spc <<'//GO.SYSIN DD specs/south31.spc' 's/^-//' --begin --rows 19000 --cols 60000 --elements 150000 --MPS FILE south31.mps --ERROR FILE south31.err --SOLUT FILE south31.res --minimize --end -//GO.SYSIN DD specs/south31.spc -echo specs/stair.spc 1>&2 -sed >specs/stair.spc <<'//GO.SYSIN DD specs/stair.spc' 's/^-//' --begin --rows 360 --cols 1000 --elements 6000 --B0 tol 0.01 --MPS FILE stair.mps --ERROR FILE stair.err --SOLUT FILE stair.res --minimize --end -//GO.SYSIN DD specs/stair.spc -echo specs/standata.spc 1>&2 -sed >specs/standata.spc <<'//GO.SYSIN DD specs/standata.spc' 's/^-//' --begin --rows 400 --cols 2000 --elements 5000 --MPS FILE standata.mps --ERROR FILE standata.err --SOLUT FILE standata.res --minimize --end -//GO.SYSIN DD specs/standata.spc -echo specs/standgub.spc 1>&2 -sed >specs/standgub.spc <<'//GO.SYSIN DD specs/standgub.spc' 's/^-//' --begin --rows 500 --cols 2000 --elements 5000 --MPS FILE standgub.mps --ERROR FILE standgub.err --SOLUT FILE standgub.res --minimize --end -//GO.SYSIN DD specs/standgub.spc -echo specs/standmps.spc 1>&2 -sed >specs/standmps.spc <<'//GO.SYSIN DD specs/standmps.spc' 's/^-//' --begin --rows 500 --cols 2000 --elements 5000 --MPS FILE standmps.mps --ERROR FILE standmps.err --SOLUT FILE standmps.res --minimize --end -//GO.SYSIN DD specs/standmps.spc -echo specs/stocfor1.spc 1>&2 -sed >specs/stocfor1.spc <<'//GO.SYSIN DD specs/stocfor1.spc' 's/^-//' --begin --rows 120 --cols 500 --elements 2000 --B0 tol 0.01 --fac freq 40 --MPS FILE stocfor1.mps --ERROR FILE stocfor1.err --SOLUT FILE stocfor1.res --minimize --end -//GO.SYSIN DD specs/stocfor1.spc -echo specs/stocfor2.spc 1>&2 -sed >specs/stocfor2.spc <<'//GO.SYSIN DD specs/stocfor2.spc' 's/^-//' --begin --rows 2200 --cols 7000 --elements 15000 --B0 tol 0.01 --fac freq 40 --MPS FILE stocfor2.mps --ERROR FILE stocfor2.err --SOLUT FILE stocfor2.res --minimize --end -//GO.SYSIN DD specs/stocfor2.spc -echo specs/stocfor3.spc 1>&2 -sed >specs/stocfor3.spc <<'//GO.SYSIN DD specs/stocfor3.spc' 's/^-//' --begin --rows 17000 --cols 32500 --elements 120000 --B0 tol 0.01 --fac freq 40 --MPS FILE stocfor3.mps --ERROR FILE stocfor3.err --SOLUT FILE stocfor3.res --minimize --end -//GO.SYSIN DD specs/stocfor3.spc -echo specs/t7.spc 1>&2 -sed >specs/t7.spc <<'//GO.SYSIN DD specs/t7.spc' 's/^-//' --begin --rows 20 --cols 30 --elements 100 --MPS FILE t7.mps --ERROR FILE t7.err --SOLUT FILE t7.res --minimize --end -//GO.SYSIN DD specs/t7.spc -echo specs/t7b.spc 1>&2 -sed >specs/t7b.spc <<'//GO.SYSIN DD specs/t7b.spc' 's/^-//' --begin --rows 20 --cols 30 --elements 100 --MPS FILE t7b.mps --ERROR FILE t7b.err --SOLUT FILE t7b.res --minimize --end -//GO.SYSIN DD specs/t7b.spc -echo specs/t7be.spc 1>&2 -sed >specs/t7be.spc <<'//GO.SYSIN DD specs/t7be.spc' 's/^-//' --begin --rows 20 --cols 30 --elements 100 --MPS FILE t7be.mps --ERROR FILE t7be.err --SOLUT FILE t7be.res --minimize --end -//GO.SYSIN DD specs/t7be.spc -echo specs/t9.spc 1>&2 -sed >specs/t9.spc <<'//GO.SYSIN DD specs/t9.spc' 's/^-//' --begin --rows 20 --cols 30 --elements 100 --MPS FILE t9.mps --ERROR FILE t9.err --SOLUT FILE t9.res --minimize --end -//GO.SYSIN DD specs/t9.spc -echo specs/t9b.spc 1>&2 -sed >specs/t9b.spc <<'//GO.SYSIN DD specs/t9b.spc' 's/^-//' --begin --rows 20 --cols 30 --elements 100 --MPS FILE t9b.mps --ERROR FILE t9b.err --SOLUT FILE t9b.res --minimize --end -//GO.SYSIN DD specs/t9b.spc -echo specs/testbig.spc 1>&2 -sed >specs/testbig.spc <<'//GO.SYSIN DD specs/testbig.spc' 's/^-//' --begin --rows 18000 --cols 50000 --elements 100000 --MPS FILE testbig.mps --ERROR FILE testbig.err --SOLUT FILE testbig.res --minimize --end -//GO.SYSIN DD specs/testbig.spc -echo specs/trans3.spc 1>&2 -sed >specs/trans3.spc <<'//GO.SYSIN DD specs/trans3.spc' 's/^-//' --begin --rows 200 --cols 500 --elements 6000 --MPS FILE trans3.mps --ERROR FILE trans3.err --SOLUT FILE trans3.res --RHS name RHS1 --objective OBJECTIF --minimize --end -//GO.SYSIN DD specs/trans3.spc -echo specs/trans4.spc 1>&2 -sed >specs/trans4.spc <<'//GO.SYSIN DD specs/trans4.spc' 's/^-//' --begin --rows 400 --cols 700 --elements 40000 --MPS FILE trans4.mps --ERROR FILE trans4.err --SOLUT FILE trans4.res --RHS name RHS1 --objective OBJECTIF --minimize --end -//GO.SYSIN DD specs/trans4.spc -echo specs/truss.spc 1>&2 -sed >specs/truss.spc <<'//GO.SYSIN DD specs/truss.spc' 's/^-//' --begin --rows 1200 --cols 10000 --elements 40000 --B0 tol 0.05 --fac freq 40 --MPS FILE truss.mps --ERROR FILE truss.err --SOLUT FILE truss.res --minimize --end -//GO.SYSIN DD specs/truss.spc -echo specs/tuff.spc 1>&2 -sed >specs/tuff.spc <<'//GO.SYSIN DD specs/tuff.spc' 's/^-//' --begin --rows 350 --cols 1000 --elements 5000 --MPS FILE tuff.mps --ERROR FILE tuff.err --SOLUT FILE tuff.res --minimize --end -//GO.SYSIN DD specs/tuff.spc -echo specs/uk.spc 1>&2 -sed >specs/uk.spc <<'//GO.SYSIN DD specs/uk.spc' 's/^-//' --begin --rows 10500 --cols 25000 --elements 140000 --MPS FILE UK.mps --ERROR FILE UK.err --SOLUT FILE UK.res --minimize --end -//GO.SYSIN DD specs/uk.spc -echo specs/unzul.spc 1>&2 -sed >specs/unzul.spc <<'//GO.SYSIN DD specs/unzul.spc' 's/^-//' --begin --rows 500 --cols 1000 --elements 3000 --MPS FILE unzul.mps --ERROR FILE unzul.err --SOLUT FILE unzul.res --minimize --end -//GO.SYSIN DD specs/unzul.spc -echo specs/vschna02.spc 1>&2 -sed >specs/vschna02.spc <<'//GO.SYSIN DD specs/vschna02.spc' 's/^-//' --begin --rows 300 --cols 1500 --elements 5000 --MPS FILE vschna02.mps --ERROR FILE vschna02.err --SOLUT FILE vschna02.res --end -//GO.SYSIN DD specs/vschna02.spc -echo specs/vschnb01.spc 1>&2 -sed >specs/vschnb01.spc <<'//GO.SYSIN DD specs/vschnb01.spc' 's/^-//' --begin --rows 200 --cols 1000 --elements 5000 --MPS FILE vschnb01.mps --ERROR FILE vschnb01.err --SOLUT FILE vschnb01.res --end -//GO.SYSIN DD specs/vschnb01.spc -echo specs/vschnb02.spc 1>&2 -sed >specs/vschnb02.spc <<'//GO.SYSIN DD specs/vschnb02.spc' 's/^-//' --begin --rows 300 --cols 1500 --elements 5000 --MPS FILE vschnb02.mps --ERROR FILE vschnb02.err --SOLUT FILE vschnb02.res --end -//GO.SYSIN DD specs/vschnb02.spc -echo specs/vtp_base.spc 1>&2 -sed >specs/vtp_base.spc <<'//GO.SYSIN DD specs/vtp_base.spc' 's/^-//' --begin --rows 200 --cols 500 --elements 1500 --MPS FILE vtp_base.mps --ERROR FILE vtp_base.err --SOLUT FILE vtp_base.res --minimize --end -//GO.SYSIN DD specs/vtp_base.spc -echo specs/willett.spc 1>&2 -sed >specs/willett.spc <<'//GO.SYSIN DD specs/willett.spc' 's/^-//' --begin --rows 200 --cols 700 --elements 4000 --MPS FILE willett.mps --ERROR FILE willett.err --SOLUT FILE willett.res --minimize --end -//GO.SYSIN DD specs/willett.spc -echo specs/wood1p.spc 1>&2 -sed >specs/wood1p.spc <<'//GO.SYSIN DD specs/wood1p.spc' 's/^-//' --begin --rows 300 --cols 3000 --elements 71000 --MPS FILE wood1p.mps --ERROR FILE wood1p.err --SOLUT FILE wood1p.res --minimize --end -//GO.SYSIN DD specs/wood1p.spc -echo specs/woodw.spc 1>&2 -sed >specs/woodw.spc <<'//GO.SYSIN DD specs/woodw.spc' 's/^-//' --begin --rows 1100 --cols 10000 --elements 40000 --MPS FILE woodw.mps --ERROR FILE woodw.err --SOLUT FILE woodw.res --minimize --end -//GO.SYSIN DD specs/woodw.spc -echo specs/world.spc 1>&2 -sed >specs/world.spc <<'//GO.SYSIN DD specs/world.spc' 's/^-//' --begin --rows 35900 --cols 70000 --elements 260000 --B0 tol 0.05 --fac freq 30 --MPS FILE world.mps --ERROR FILE world.err --SOLUT FILE world.res --minimize --end -//GO.SYSIN DD specs/world.spc -echo specs/world2.spc 1>&2 -sed >specs/world2.spc <<'//GO.SYSIN DD specs/world2.spc' 's/^-//' --begin --rows 4000 --cols 8000 --elements 30000 --B0 tol 0.05 --fac freq 40 --MPS FILE world2.mps --ERROR FILE world2.err --SOLUT FILE world2.res --minimize --end -//GO.SYSIN DD specs/world2.spc -echo specs/world3.spc 1>&2 -sed >specs/world3.spc <<'//GO.SYSIN DD specs/world3.spc' 's/^-//' --begin --rows 37000 --cols 70000 --elements 270000 --B0 tol 0.01 --fac freq 40 --MPS FILE world3.mps --ERROR FILE world3.err --SOLUT FILE world3.res --opt tol 1.0D-6 --minimize --end -//GO.SYSIN DD specs/world3.spc -echo specs/world4.spc 1>&2 -sed >specs/world4.spc <<'//GO.SYSIN DD specs/world4.spc' 's/^-//' --begin --rows 53000 --cols 88000 --elements 380000 --B0 tol 0.05 --fac freq 30 --MPS FILE world4.mps --ERROR FILE world4.err --SOLUT FILE world4.res --minimize --end -//GO.SYSIN DD specs/world4.spc -echo specs/world5.spc 1>&2 -sed >specs/world5.spc <<'//GO.SYSIN DD specs/world5.spc' 's/^-//' --begin --rows 53000 --cols 88000 --elements 380000 --B0 tol 0.05 --fac freq 30 --MPS FILE world5.mps --ERROR FILE world5.err --SOLUT FILE world5.res --minimize --end -//GO.SYSIN DD specs/world5.spc -echo specs/zed.spc 1>&2 -sed >specs/zed.spc <<'//GO.SYSIN DD specs/zed.spc' 's/^-//' --begin --rows 10000 --cols 20000 --elements 100000 --MPS FILE zed.mps --ERROR FILE zed.err --SOLUT FILE zed.res --minimize --end -//GO.SYSIN DD specs/zed.spc //GO.SYSIN DD hopdm.src/specs.shar echo hopdm.src/get 1>&2 sed >hopdm.src/get <<'//GO.SYSIN DD hopdm.src/get' 's/^-//' -unzip ../netlib/$1 -mv $1 $1.mps -unzip ../netlib/specs $1.spc //GO.SYSIN DD hopdm.src/get