| 1 |
************************************************************************ |
| 2 |
* |
| 3 |
* File mi35inpt fortran. |
| 4 |
* |
| 5 |
* m3getp m3hash m3imov |
| 6 |
* m3inpt m3mpsa m3mpsb m3mpsc m3read |
| 7 |
* |
| 8 |
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 9 |
|
| 10 |
subroutine m3getp( maxm, lenh ) |
| 11 |
|
| 12 |
* ------------------------------------------------------------------ |
| 13 |
* m3getp finds a prime number lenh suitably larger than maxm. |
| 14 |
* It is used as the length of the hash table for the MPS row names. |
| 15 |
* |
| 16 |
* 20 Apr 1992: Implemented for use in m3inpt and matmps. |
| 17 |
* ------------------------------------------------------------------ |
| 18 |
|
| 19 |
lenh = maxm*2 |
| 20 |
lenh = max( lenh, 100 ) |
| 21 |
lenh = (lenh/2)*2 - 1 |
| 22 |
k = lenh/20 + 6 |
| 23 |
|
| 24 |
100 k = k + 1 |
| 25 |
lenh = lenh + 2 |
| 26 |
do 120 i = 3, k, 2 |
| 27 |
if (mod(lenh,i) .eq. 0) go to 100 |
| 28 |
120 continue |
| 29 |
|
| 30 |
* end of m3getp |
| 31 |
end |
| 32 |
|
| 33 |
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 34 |
|
| 35 |
subroutine m3hash( len , nen , ncoll, |
| 36 |
$ key1 , key2 , mode , keytab, |
| 37 |
$ name1, name2, ka , found ) |
| 38 |
|
| 39 |
integer keytab(len), name1(nen), name2(nen) |
| 40 |
logical found |
| 41 |
|
| 42 |
* ------------------------------------------------------------------ |
| 43 |
* m3hash looks up and/or inserts integer keys in a table. |
| 44 |
* Reference: R.P. Brent, CACM 16,2 (Feb 1973), pp. 105-109. |
| 45 |
* This version is simplified for the case where no entries are |
| 46 |
* deleted. |
| 47 |
* keytab is used as an index into a consecutive list of unique |
| 48 |
* identifiers name1 and name2. |
| 49 |
* Each pair name1(i), name2(i) is two 4-character identifiers, |
| 50 |
* treated as one 8-character identifier. |
| 51 |
* ------------------------------------------------------------------ |
| 52 |
|
| 53 |
len2 = len - 2 |
| 54 |
ic = -1 |
| 55 |
|
| 56 |
* Compute address of first probe (ir) and increment (iq). |
| 57 |
* ****************************************************************** |
| 58 |
* NOTE -- the next statements are machine dependent. The aim |
| 59 |
* is to produce a valid positive integer key out of the |
| 60 |
* two words key1 and key2 . The latter contain four |
| 61 |
* characters left-justified (read under a4 format). These |
| 62 |
* may turn on the sign bit (e.g. IBM 360/370) or give a |
| 63 |
* non-zero floating point exponent (e.g. Burroughs B6700). |
| 64 |
* ****************************************************************** |
| 65 |
*---+ DEC VAX |
| 66 |
k1 = abs(key1) |
| 67 |
k2 = abs(key2) |
| 68 |
|
| 69 |
*---- On CDC systems (and possibly CRAY systems), change the previous 2 |
| 70 |
*- lines to comments, and uncomment the next 3 lines. |
| 71 |
*- decode( 4, 10, key1 ) k1 |
| 72 |
*- decode( 4, 10, key2 ) k2 |
| 73 |
*- 10 format( r4 ) |
| 74 |
|
| 75 |
key = abs(k1 - k2) |
| 76 |
iq = mod(key, len2) + 1 |
| 77 |
ir = mod(key, len) + 1 |
| 78 |
ka = ir |
| 79 |
|
| 80 |
* Look in the table. |
| 81 |
20 kt = keytab(ka) |
| 82 |
|
| 83 |
* Check for an empty space or a match. |
| 84 |
if (kt .eq. 0) go to 30 |
| 85 |
if (key1 .eq. name1(kt) .and. key2 .eq. name2(kt)) go to 60 |
| 86 |
ic = ic + 1 |
| 87 |
ncoll = ncoll + 1 |
| 88 |
|
| 89 |
* Compute address of next probe. |
| 90 |
ka = ka + iq |
| 91 |
if (ka .gt. len) ka = ka - len |
| 92 |
|
| 93 |
* See if whole table has been searched. |
| 94 |
if (ka .ne. ir ) go to 20 |
| 95 |
|
| 96 |
* The key is not in the table. |
| 97 |
30 found = .false. |
| 98 |
|
| 99 |
* Return with KA = 0 unless an entry has to be made. |
| 100 |
if ((mode .eq. 2) .and. (ic .le. len2)) go to 70 |
| 101 |
ka = 0 |
| 102 |
return |
| 103 |
|
| 104 |
60 found = .true. |
| 105 |
return |
| 106 |
|
| 107 |
* Look for the best way to make an entry. |
| 108 |
70 if (ic .le. 0) return |
| 109 |
ia = ka |
| 110 |
is = 0 |
| 111 |
|
| 112 |
* Compute the maximum length to search along current chain. |
| 113 |
80 ix = ic - is |
| 114 |
kt = keytab(ir) |
| 115 |
|
| 116 |
* Compute increment JQ for current chain. |
| 117 |
* ****************************************************************** |
| 118 |
* NOTE -- the next statements are machine dependent. The same |
| 119 |
* transformation as discussed in the note above should be |
| 120 |
* applied to name1(kt) and name2(kt) to produce an integer key. |
| 121 |
* ****************************************************************** |
| 122 |
*---+ DEC VAX |
| 123 |
k1 = abs(name1(kt)) |
| 124 |
k2 = abs(name2(kt)) |
| 125 |
|
| 126 |
*---- On CDC systems (and possibly CRAY systems), change the previous 2 |
| 127 |
*- lines to comments, and uncomment the next 2 lines. |
| 128 |
*- decode( 4, 10, name1(kt) ) k1 |
| 129 |
*- decode( 4, 10, name2(kt) ) k2 |
| 130 |
|
| 131 |
key = abs(k1 - k2) |
| 132 |
jq = mod(key, len2) + 1 |
| 133 |
jr = ir |
| 134 |
|
| 135 |
* Look along the chain. |
| 136 |
90 jr = jr + jq |
| 137 |
if (jr .gt. len) jr = jr - len |
| 138 |
|
| 139 |
* Check for a hole. |
| 140 |
if (keytab(jr) .eq. 0) go to 100 |
| 141 |
ix = ix - 1 |
| 142 |
if (ix .gt. 0) go to 90 |
| 143 |
go to 110 |
| 144 |
|
| 145 |
* Save location of hole. |
| 146 |
100 ia = jr |
| 147 |
ka = ir |
| 148 |
ic = ic - ix |
| 149 |
|
| 150 |
* Move down to the next chain. |
| 151 |
110 is = is + 1 |
| 152 |
ir = ir + iq |
| 153 |
if (ir .gt. len) ir = ir - len |
| 154 |
|
| 155 |
* Go back if a better hole might still be found. |
| 156 |
if (ic .gt. is ) go to 80 |
| 157 |
|
| 158 |
* If necessary move an old entry. |
| 159 |
if (ia .ne. ka ) keytab(ia) = keytab(ka) |
| 160 |
|
| 161 |
* end of m3hash |
| 162 |
end |
| 163 |
|
| 164 |
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 165 |
|
| 166 |
subroutine m3imov( lennm, lrow, m, n, name ) |
| 167 |
|
| 168 |
integer name(lennm) |
| 169 |
|
| 170 |
* ------------------------------------------------------------------ |
| 171 |
* m3imov is needed by m3inpt and matmps to move the row names |
| 172 |
* to be contiguous with the column names inside the integer array |
| 173 |
* name(*), once the true number of columns is known. |
| 174 |
* On entry, the column names begin at name(1) and the row names |
| 175 |
* begin at name(lrow). |
| 176 |
* On exit, the row names begin at name(n+1). |
| 177 |
* |
| 178 |
* 20 Apr 1992: m3imov implemented to help matmps. |
| 179 |
* ------------------------------------------------------------------ |
| 180 |
|
| 181 |
if (lrow .gt. n+1) then |
| 182 |
call icopy ( m, name(lrow), 1, name(n+1), 1 ) |
| 183 |
end if |
| 184 |
|
| 185 |
* end of m3imov |
| 186 |
end |
| 187 |
|
| 188 |
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 189 |
|
| 190 |
subroutine m3inpt( objadd, z, nwcore ) |
| 191 |
|
| 192 |
implicit double precision (a-h,o-z) |
| 193 |
double precision z(nwcore) |
| 194 |
|
| 195 |
* ------------------------------------------------------------------ |
| 196 |
* m3inpt inputs constraint data in MPS format, and sets up |
| 197 |
* various quantities as follows: |
| 198 |
* |
| 199 |
* objadd (output) is minus the coefficient in row iobj of the |
| 200 |
* RHS section (zero by default). MINOS adds it to the |
| 201 |
* objective function. |
| 202 |
* |
| 203 |
* m, n, ne are the number of rows, columns and elements in A. |
| 204 |
* |
| 205 |
* iobj is the row number for the linear objective (if any). |
| 206 |
* It must come after any nonlinear rows. |
| 207 |
* iobj = 0 if there is no linear objective. |
| 208 |
* |
| 209 |
* a, ha, ka is the matrix a stored in z at locations la, lha, lka. |
| 210 |
* bl, bu are the bounds stored in z at locations lbl, lbu. |
| 211 |
* hs, xn are states and values stored in z at lhs, lxn. |
| 212 |
* |
| 213 |
* hs(j) is set to 0, 1 to indicate a plausible initial state |
| 214 |
* (at lo or up bnd) for each variable j (j = 1 to nb). |
| 215 |
* If crash is to be used, i.e., crash option gt 0 and |
| 216 |
* if no basis file will be supplied, the initial bounds |
| 217 |
* set may initialize hs(j) as follows to assist crash: |
| 218 |
* |
| 219 |
* -1 if column or row j is likely to be in the optimal basis, |
| 220 |
* 4 if column j is likely to be nonbasic at its lower bound, |
| 221 |
* 5 if column j is likely to be nonbasic at its upper bound, |
| 222 |
* 2 if column or row j should initially be superbasic, |
| 223 |
* 0 or 1 otherwise. |
| 224 |
* |
| 225 |
* xn(j) is a corresponding set of initial values. |
| 226 |
* Safeguards are applied later by m4chek, so the |
| 227 |
* values of hs and xn are not desperately critical. |
| 228 |
* |
| 229 |
* The arrays name(*), mobj(*), mrhs(*), mrng(*), mbnd(*) are loaded |
| 230 |
* with the appropriate names in 2a4 format. |
| 231 |
* |
| 232 |
* m3inpt (and hence m3hash, m3mpsa, m3mpsb, m3mpsc and m3read) |
| 233 |
* may be replaced by routines that output the same information. |
| 234 |
* |
| 235 |
* 31 Oct 1991: Modified to be compatible with subroutine minoss. |
| 236 |
* 10 Apr 1992: objadd added as an output parameter. |
| 237 |
* 04 May 1992: m3mpsb now outputs pi. |
| 238 |
* ------------------------------------------------------------------ |
| 239 |
|
| 240 |
common /m1file/ iread,iprint,isumm |
| 241 |
common /m2file/ iback,idump,iload,imps,inewb,insrt, |
| 242 |
$ ioldb,ipnch,iprob,iscr,isoln,ispecs,ireprt |
| 243 |
common /m2len / mrows ,mcols ,melms |
| 244 |
common /m2mapa/ ne ,nka ,la ,lha ,lka |
| 245 |
common /m2mapz/ maxw ,maxz |
| 246 |
common /m3len / m ,n ,nb ,nscl |
| 247 |
common /m3loc / lascal,lbl ,lbu ,lbbl ,lbbu , |
| 248 |
$ lhrtyp,lhs ,lkb |
| 249 |
common /m3mps1/ lname1,lname2,lkeynm,nname |
| 250 |
common /m3mps3/ aijtol,bstruc(2),mlst,mer, |
| 251 |
$ aijmin,aijmax,na0,line,ier(20) |
| 252 |
common /m5len / maxr ,maxs ,mbs ,nn ,nn0 ,nr ,nx |
| 253 |
common /m5loc / lpi ,lpi2 ,lw ,lw2 , |
| 254 |
$ lx ,lx2 ,ly ,ly2 , |
| 255 |
$ lgsub ,lgsub2,lgrd ,lgrd2 , |
| 256 |
$ lr ,lrg ,lrg2 ,lxn |
| 257 |
common /m5log1/ idebug,ierr,lprint |
| 258 |
common /m7len / fobj ,fobj2 ,nnobj ,nnobj0 |
| 259 |
common /m7loc / lgobj ,lgobj2 |
| 260 |
common /m8len / njac ,nncon ,nncon0,nnjac |
| 261 |
common /m8loc / lfcon ,lfcon2,lfdif ,lfdif2,lfold , |
| 262 |
$ lblslk,lbuslk,lxlam ,lrhs , |
| 263 |
$ lgcon ,lgcon2,lxdif ,lxold |
| 264 |
|
| 265 |
intrinsic max, mod |
| 266 |
|
| 267 |
integer ncard(6) |
| 268 |
logical allnn |
| 269 |
character*4 key |
| 270 |
character*4 lenda |
| 271 |
data lenda /'ENDA'/ |
| 272 |
|
| 273 |
* ------------------------------------------------------------------ |
| 274 |
* Here's a kludge to let users say they want all columns to be |
| 275 |
* nonlinear. They should specify |
| 276 |
* Columns n |
| 277 |
* Nonlinear variables n |
| 278 |
* for any large enough n (ge the true n). |
| 279 |
* here we just test if the two n's are the same. |
| 280 |
* Later we reset nn once we know the true n. |
| 281 |
* ------------------------------------------------------------------ |
| 282 |
allnn = mcols .eq. nn |
| 283 |
|
| 284 |
* We may come back here to try again with more workspace. |
| 285 |
* key retains the first 4 characters of the NAME, ROWS, COLUMNS |
| 286 |
* RHS, RANGES and BOUNDS cards. |
| 287 |
* ncard counts the number of data records in each section. |
| 288 |
* m3getp finds a prime number for the length of the row hash table. |
| 289 |
|
| 290 |
10 ierr = 0 |
| 291 |
ncoll = 0 |
| 292 |
key = ' ' |
| 293 |
call iload1( 6, 0, ncard, 1 ) |
| 294 |
call m3getp( mrows, lenh ) |
| 295 |
|
| 296 |
call m2core( 2, mincor ) |
| 297 |
if (maxz .lt. mincor) go to 600 |
| 298 |
|
| 299 |
* ------------------------------------------------------------------ |
| 300 |
* Input ROWS. |
| 301 |
* lrow is the location of the first rowname in name1, name2. |
| 302 |
* lennm is the initial length of name1, name2, |
| 303 |
* i.e. the maximum no. of names allowed for. |
| 304 |
* ------------------------------------------------------------------ |
| 305 |
lrow = mcols + 1 |
| 306 |
lennm = mcols + mrows |
| 307 |
call m3mpsa( mrows, mcols, melms, ncoll, m, |
| 308 |
$ lrow, lennm, lenh, nn, nncon, key, ncard, |
| 309 |
$ z(lhrtyp), z(lname1), z(lname2), z(lkeynm) ) |
| 310 |
if (ierr .eq. 40) go to 400 |
| 311 |
if (ierr .eq. 41) go to 500 |
| 312 |
|
| 313 |
* ------------------------------------------------------------------ |
| 314 |
* m is now known. |
| 315 |
* Input COLUMNS, RHS, RANGES. |
| 316 |
* ------------------------------------------------------------------ |
| 317 |
mrows = m |
| 318 |
call m3mpsb( mcols, melms, lrow, lennm, lenh, ncoll, objadd, |
| 319 |
$ m, n, nb, ne, nka, |
| 320 |
$ nn, nncon, nnjac, nnobj, njac, key, ncard, |
| 321 |
$ z(lhrtyp), z(lname1), z(lname2), z(lkeynm), |
| 322 |
$ z(lka), z(lha), z(la), z(lbl), z(lbu), |
| 323 |
$ z(lkb), z(lpi) ) |
| 324 |
if (ierr .eq. 40) go to 400 |
| 325 |
if (ierr .eq. 41) go to 510 |
| 326 |
|
| 327 |
* ------------------------------------------------------------------ |
| 328 |
* n and ne are now known. |
| 329 |
* Move the row names to be contiguous with the column names. |
| 330 |
* Input BOUNDS. |
| 331 |
* ------------------------------------------------------------------ |
| 332 |
call m3imov( lennm, lrow, m, n, z(lname1) ) |
| 333 |
call m3imov( lennm, lrow, m, n, z(lname2) ) |
| 334 |
mcols = n |
| 335 |
melms = ne |
| 336 |
np1 = n + 1 |
| 337 |
nb = n + m |
| 338 |
if (maxs .gt. np1) maxs = np1 |
| 339 |
if (maxr .gt. np1) maxr = np1 |
| 340 |
if (nn .ge. nb ) nn = nb |
| 341 |
if ( allnn ) then |
| 342 |
nn = n |
| 343 |
if (nnobj .gt. 0) nnobj = n |
| 344 |
if (nnjac .gt. 0) nnjac = n |
| 345 |
end if |
| 346 |
|
| 347 |
call m3mpsc( m, n, nb, ne, ns, lennm, |
| 348 |
$ key, ncard, z(lname1), z(lname2), |
| 349 |
$ z(lbl), z(lbu), z(lhs), z(lxn) ) |
| 350 |
|
| 351 |
if (iprint .gt. 0) then |
| 352 |
write(iprint, '(/)') |
| 353 |
if (lprint .gt. 0) write(iprint, 1300) lenh, ncoll |
| 354 |
if (na0 .gt. 0) write(iprint, 1320) na0 |
| 355 |
if (nncon .gt. 0) write(iprint, 1350) njac |
| 356 |
if (nncon .gt. 0 .or. ncard(5) .gt. 0) |
| 357 |
$ write(iprint, 1400) ncard(5) |
| 358 |
if (nn .gt. 0 .or. ncard(6) .gt. 0) |
| 359 |
$ write(iprint, 1420) ncard(6), ns |
| 360 |
end if |
| 361 |
|
| 362 |
* ------------------------------------------------------------------ |
| 363 |
* Compress storage, now that we know the size of everything. |
| 364 |
* ------------------------------------------------------------------ |
| 365 |
|
| 366 |
* Save current positions of bl, bu, etc. |
| 367 |
|
| 368 |
kha = lha |
| 369 |
kka = lka |
| 370 |
kbl = lbl |
| 371 |
kbu = lbu |
| 372 |
kn1 = lname1 |
| 373 |
kn2 = lname2 |
| 374 |
khs = lhs |
| 375 |
kxn = lxn |
| 376 |
kpi = lpi |
| 377 |
|
| 378 |
* Redefine addresses in z in terms of the known dimensions. |
| 379 |
|
| 380 |
call m2core( 3, mincor ) |
| 381 |
if (maxz .lt. mincor) go to 800 |
| 382 |
|
| 383 |
* Move bl, bu, etc. into their final positions. |
| 384 |
|
| 385 |
call hcopy ( ne, z(kha), 1, z(lha), 1 ) |
| 386 |
call icopy ( nka,z(kka), 1, z(lka), 1 ) |
| 387 |
call dcopy ( nb, z(kbl), 1, z(lbl), 1 ) |
| 388 |
call dcopy ( nb, z(kbu), 1, z(lbu), 1 ) |
| 389 |
if (nname .eq. nb) then |
| 390 |
call icopy ( nb, z(kn1), 1, z(lname1), 1 ) |
| 391 |
call icopy ( nb, z(kn2), 1, z(lname2), 1 ) |
| 392 |
end if |
| 393 |
call hcopy ( nb, z(khs), 1, z(lhs), 1 ) |
| 394 |
call dcopy ( nb, z(kxn), 1, z(lxn), 1 ) |
| 395 |
call dcopy ( m , z(kpi), 1, z(lpi), 1 ) |
| 396 |
go to 900 |
| 397 |
|
| 398 |
* --------------------------- |
| 399 |
* Fatal error in MPS file. |
| 400 |
* --------------------------- |
| 401 |
400 call m1page( 2 ) |
| 402 |
if (iprint .gt. 0) write(iprint, 1100) |
| 403 |
if (isumm .gt. 0) write(isumm , 1100) |
| 404 |
go to 700 |
| 405 |
|
| 406 |
* --------------------------- |
| 407 |
* Too many rows. |
| 408 |
* --------------------------- |
| 409 |
500 mrows = m |
| 410 |
go to 520 |
| 411 |
|
| 412 |
* ----------------------------- |
| 413 |
* Too many columns or elements. |
| 414 |
* ----------------------------- |
| 415 |
510 mcols = n |
| 416 |
melms = ne |
| 417 |
|
| 418 |
* Try again. |
| 419 |
|
| 420 |
520 if (imps .ne. iread .and. imps .ne. ispecs) then |
| 421 |
rewind imps |
| 422 |
go to 10 |
| 423 |
end if |
| 424 |
|
| 425 |
* --------------------------------- |
| 426 |
* Not enough core to read MPS file. |
| 427 |
* --------------------------------- |
| 428 |
600 call m1page(2) |
| 429 |
if (iprint .gt. 0) write(iprint, 1110) |
| 430 |
if (isumm .gt. 0) write(isumm , 1110) |
| 431 |
ierr = 41 |
| 432 |
|
| 433 |
* ------------------------------------ |
| 434 |
* Flush MPS file to the ENDATA card |
| 435 |
* if it is the same as the SPECS file. |
| 436 |
* ------------------------------------ |
| 437 |
700 if (imps .eq. ispecs) then |
| 438 |
do 750 idummy = 1, 100000 |
| 439 |
if (key .eq. lenda) go to 900 |
| 440 |
read(imps, 1700, end=900) key |
| 441 |
750 continue |
| 442 |
end if |
| 443 |
go to 900 |
| 444 |
|
| 445 |
* ------------------------------------- |
| 446 |
* Not enough core to solve the problem. |
| 447 |
* ------------------------------------- |
| 448 |
800 call m1page(2) |
| 449 |
if (iprint .gt. 0) write(iprint, 1120) mincor |
| 450 |
if (isumm .gt. 0) write(isumm , 1120) mincor |
| 451 |
ierr = 42 |
| 452 |
|
| 453 |
* Exit. |
| 454 |
|
| 455 |
900 if (imps .ne. iread .and. imps .ne. ispecs) rewind imps |
| 456 |
return |
| 457 |
|
| 458 |
1100 format(' EXIT -- fatal errors in the MPS file') |
| 459 |
1110 format(' EXIT -- not enough storage to read the MPS file') |
| 460 |
1120 format(' EXIT -- not enough storage to start solving', |
| 461 |
$ ' the problem' |
| 462 |
$ // ' Workspace (total) should be significantly', |
| 463 |
$ ' more than', i8) |
| 464 |
1300 format(/ ' Length of row-name hash table ', i12 |
| 465 |
$ / ' Collisions during table lookup ', i12) |
| 466 |
1320 format( ' No. of rejected coefficients ', i12) |
| 467 |
1350 format( ' No. of Jacobian entries specified', i10) |
| 468 |
1400 format( ' No. of LAGRANGE entries specified', i10) |
| 469 |
1420 format( ' No. of INITIAL bounds specified', i10 |
| 470 |
$ / ' No. of superbasics specified ', i12) |
| 471 |
1700 format(a4) |
| 472 |
|
| 473 |
* end of m3inpt |
| 474 |
end |
| 475 |
|
| 476 |
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 477 |
|
| 478 |
subroutine m3mpsa( mrows, mcols, melms, ncoll, m, |
| 479 |
$ lrow, lennm, lenh, nn, nncon, key, ncard, |
| 480 |
$ hrtype, name1, name2, keynam ) |
| 481 |
|
| 482 |
implicit double precision (a-h,o-z) |
| 483 |
character*4 key |
| 484 |
integer*4 hrtype(mrows) |
| 485 |
integer ncard(6), name1(lennm), name2(lennm), |
| 486 |
$ keynam(lenh) |
| 487 |
|
| 488 |
* ------------------------------------------------------------------ |
| 489 |
* m3mpsa inputs the name and rows sections of an MPS file. |
| 490 |
* |
| 491 |
* Original version written by Keith Morris, Wellington, 1973. |
| 492 |
* 1975: Use a hash table for the row names. |
| 493 |
* 1979: Treat the (nncon by nnjac) principal submatrix |
| 494 |
* as a Jacobian for nonlinear constraints. |
| 495 |
* 1980: Add Phantom columns to the end of A. |
| 496 |
* 1982: Store the rhs as bounds on the logicals, |
| 497 |
* instead of the last column of A. The constraints now have |
| 498 |
* the form A*x + I*s = 0, bl .le. (x, s) .le. bu, |
| 499 |
* where A has m rows, n columns and ne nonzero elements. |
| 500 |
* 1982 Treat * in column 1 correctly, and retry if the MPS file |
| 501 |
* is on disk and mrows, mcols or melms are too small. |
| 502 |
* Apr 1984: Added check for duplicate row entries in columns. |
| 503 |
* Mar 1985: Changes made to handle characters as in Fortran 77. |
| 504 |
* Oct 1985: m3mps split into m3mpsa, m3mpsb, m3mpsc. |
| 505 |
* Revisions made to handle characters more efficiently. |
| 506 |
* Oct 1991: More f77. Row names now at end of name1, name2. |
| 507 |
* ------------------------------------------------------------------ |
| 508 |
|
| 509 |
common /m1file/ iread,iprint,isumm |
| 510 |
common /m2file/ iback,idump,iload,imps,inewb,insrt, |
| 511 |
$ ioldb,ipnch,iprob,iscr,isoln,ispecs,ireprt |
| 512 |
common /m3mps3/ aijtol,bstruc(2),mlst,mer, |
| 513 |
$ aijmin,aijmax,na0,line,ier(20) |
| 514 |
common /m3mps4/ name(2),mobj(2),mrhs(2),mrng(2),mbnd(2),minmax |
| 515 |
common /m3mps5/ aelem(2), id(6), iblank |
| 516 |
common /m5lobj/ sinf,wtobj,minimz,ninf,iobj,jobj,kobj |
| 517 |
common /m5log1/ idebug,ierr,lprint |
| 518 |
|
| 519 |
logical found,gotnm |
| 520 |
character*4 a4 ,lblank, |
| 521 |
$ lname,lrows,lcolu, |
| 522 |
$ lex,lgx,llx,lnx,lxe,lxg,lxl,lxn |
| 523 |
data a4 ,lblank /'(a4)',' '/ |
| 524 |
data lname,lrows,lcolu /'NAME','ROWS','COLU' / |
| 525 |
data lex,lgx,llx,lnx /' E ',' G ',' L ',' N '/ |
| 526 |
data lxe,lxg,lxl,lxn /' E ',' G ',' L ',' N '/ |
| 527 |
* ------------------------------------------------------------------ |
| 528 |
|
| 529 |
call m1page( 1 ) |
| 530 |
if (iprint .gt. 0) write(iprint, 1000) |
| 531 |
read (lblank, '(a4)') iblank |
| 532 |
inform = 0 |
| 533 |
iobj = 0 |
| 534 |
line = 0 |
| 535 |
m = 0 |
| 536 |
gotnm = mobj(1) .ne. iblank |
| 537 |
call iload1( 20 , 0, ier , 1 ) |
| 538 |
call iload1( lenh, 0, keynam, 1 ) |
| 539 |
|
| 540 |
* Look for the NAME card. |
| 541 |
|
| 542 |
10 call m3read( 1, imps, line, 5, key, inform ) |
| 543 |
if (key .ne. lname) then |
| 544 |
if (ier(1) .eq. 0) then |
| 545 |
ier(1) = 1 |
| 546 |
if (iprint .gt. 0) write(iprint, 1100) |
| 547 |
if (isumm .gt. 0) write(isumm , 1100) |
| 548 |
end if |
| 549 |
go to 10 |
| 550 |
end if |
| 551 |
|
| 552 |
name(1) = id(3) |
| 553 |
name(2) = id(4) |
| 554 |
if (isumm .gt. 0) write(isumm, 5000) name |
| 555 |
|
| 556 |
* Look for the ROWS card. |
| 557 |
|
| 558 |
call m3read( 1, imps, line, 5, key, inform ) |
| 559 |
inform = 0 |
| 560 |
if (key .ne. lrows) then |
| 561 |
ier(1) = ier(1) + 1 |
| 562 |
if (iprint .gt. 0) write(iprint, 1120) |
| 563 |
if (isumm .gt. 0) write(isumm , 1120) |
| 564 |
go to 35 |
| 565 |
end if |
| 566 |
|
| 567 |
* ================================================================== |
| 568 |
* Read the row names and check if the relationals are valid. |
| 569 |
* ================================================================== |
| 570 |
30 call m3read( 1, imps, line, mlst, key, inform ) |
| 571 |
if (inform .ne. 0) go to 110 |
| 572 |
|
| 573 |
35 if (key .eq. lgx .or. key .eq. lxg) then |
| 574 |
it = -1 |
| 575 |
else if (key .eq. lex .or. key .eq. lxe) then |
| 576 |
it = 0 |
| 577 |
else if (key .eq. llx .or. key .eq. lxl) then |
| 578 |
it = 1 |
| 579 |
else if (key .eq. lnx .or. key .eq. lxn) then |
| 580 |
it = 2 |
| 581 |
|
| 582 |
* Record objective name if we don't already have one. |
| 583 |
|
| 584 |
if (iobj .eq. 0) then |
| 585 |
if (.not. gotnm) then |
| 586 |
mobj(1) = id(1) |
| 587 |
mobj(2) = id(2) |
| 588 |
if (nn .gt. 0) then |
| 589 |
if (iprint .gt. 0) write(iprint, 1170) mobj |
| 590 |
if (isumm .gt. 0) write(isumm , 1170) mobj |
| 591 |
end if |
| 592 |
end if |
| 593 |
|
| 594 |
if (id(1) .eq. mobj(1) .and. id(2) .eq. mobj(2)) then |
| 595 |
iobj = m + 1 |
| 596 |
ncard(1) = ncard(1) + 1 |
| 597 |
end if |
| 598 |
end if |
| 599 |
else |
| 600 |
ier(3) = ier(3) + 1 |
| 601 |
if (ier(3) .le. mer) then |
| 602 |
if (iprint .gt. 0) write(iprint, 1160) line,key,id(1),id(2) |
| 603 |
if (isumm .gt. 0) write(isumm , 1160) line,key,id(1),id(2) |
| 604 |
end if |
| 605 |
go to 30 |
| 606 |
end if |
| 607 |
|
| 608 |
* .................................................................. |
| 609 |
* Look up the row name id(1), id(2) in the hash table. |
| 610 |
* .................................................................. |
| 611 |
call m3hash( lenh, mrows, ncoll, id(1), id(2), 2, |
| 612 |
$ keynam, name1(lrow), name2(lrow), ia, found ) |
| 613 |
|
| 614 |
* Error if the row name was already there. |
| 615 |
* Otherwise, enter the new name into the hash table. |
| 616 |
|
| 617 |
if (found) then |
| 618 |
ier(4) = ier(4) + 1 |
| 619 |
if (ier(4) .le. mer) then |
| 620 |
if (iprint .gt. 0) write(iprint, 1200) id(1), id(2) |
| 621 |
if (isumm .gt. 0) write(isumm , 1200) id(1), id(2) |
| 622 |
end if |
| 623 |
else |
| 624 |
m = m + 1 |
| 625 |
if (m .le. mrows) then |
| 626 |
jrow = mcols + m |
| 627 |
keynam(ia) = m |
| 628 |
name1(jrow) = id(1) |
| 629 |
name2(jrow) = id(2) |
| 630 |
hrtype(m) = it |
| 631 |
end if |
| 632 |
end if |
| 633 |
go to 30 |
| 634 |
|
| 635 |
* ================================================================== |
| 636 |
* Should be COLUMNS card. |
| 637 |
* ================================================================== |
| 638 |
110 if (key .ne. lcolu) then |
| 639 |
ier(1) = ier(1) + 1 |
| 640 |
if (iprint .gt. 0) write(iprint, 1130) |
| 641 |
if (isumm .gt. 0) write(isumm , 1130) |
| 642 |
end if |
| 643 |
|
| 644 |
* Error if no rows or too many rows. |
| 645 |
|
| 646 |
if (m .le. 0) then |
| 647 |
if (iprint .gt. 0) write(iprint, 1300) |
| 648 |
if (isumm .gt. 0) write(isumm , 1300) |
| 649 |
ier(1) = ier(1) + 1 |
| 650 |
ierr = 40 |
| 651 |
return |
| 652 |
else if (m .gt. mrows) then |
| 653 |
if (iprint .gt. 0) write(iprint, 3030) mrows, m |
| 654 |
if (isumm .gt. 0) write(isumm , 3030) mrows, m |
| 655 |
ier(1) = ier(1) + 1 |
| 656 |
ierr = 41 |
| 657 |
return |
| 658 |
end if |
| 659 |
|
| 660 |
* Warning if no objective row found. |
| 661 |
* Error if linear objective is ahead of nonlinear rows. |
| 662 |
|
| 663 |
if (iobj .eq. 0) then |
| 664 |
if (iprint .gt. 0) write(iprint, 1600) |
| 665 |
if (isumm .gt. 0) write(isumm , 1600) |
| 666 |
else if (iobj .le. nncon) then |
| 667 |
if (iprint .gt. 0) write(iprint, 1180) mobj |
| 668 |
if (isumm .gt. 0) write(isumm , 1180) mobj |
| 669 |
ierr = 40 |
| 670 |
return |
| 671 |
end if |
| 672 |
|
| 673 |
if (isumm .gt. 0) write(isumm, 5100) m |
| 674 |
return |
| 675 |
|
| 676 |
1000 format(' MPS file' / ' --------') |
| 677 |
1100 format(' XXXX Garbage before NAME card') |
| 678 |
1120 format(' XXXX ROWS card not found') |
| 679 |
1130 format(' XXXX COLUMNS card not found') |
| 680 |
1160 format(' XXXX Illegal row type at line', i7, '... ', 3a4) |
| 681 |
1170 format(' XXXX Note: row ', 2a4, |
| 682 |
$ ' selected as linear part of objective.') |
| 683 |
1180 format(/ ' XXXX The linear objective card N ', 2a4 |
| 684 |
$ / ' XXXX is out of place. Nonlinear constraints' |
| 685 |
$ / ' XXXX must be listed first in the ROWS section.') |
| 686 |
1200 format(' XXXX Duplicate row name --', 2a4, ' -- ignored') |
| 687 |
1300 format(' XXXX No rows specified') |
| 688 |
1600 format(' XXXX Warning - no linear objective selected') |
| 689 |
2000 format(2a4) |
| 690 |
3030 format(' XXXX Too many rows. Limit was', i8, |
| 691 |
$ 4x, ' Actual number is', i8) |
| 692 |
5000 format(' Name ', 2a4) |
| 693 |
5100 format(' Rows ', i8) |
| 694 |
|
| 695 |
* end of m3mpsa |
| 696 |
end |
| 697 |
|
| 698 |
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 699 |
|
| 700 |
subroutine m3mpsb( mcols, melms, lrow, lennm, lenh, ncoll, objadd, |
| 701 |
$ m, n, nb, ne, nka, |
| 702 |
$ nn, nncon, nnjac, nnobj, njac, key, ncard, |
| 703 |
$ hrtype, name1, name2, keynam, |
| 704 |
$ ka, ha, a, bl, bu, kb, pi ) |
| 705 |
|
| 706 |
implicit double precision (a-h,o-z) |
| 707 |
character*4 key |
| 708 |
integer*4 hrtype(m), ha(melms) |
| 709 |
integer ncard(6) , name1(lennm), name2(lennm), |
| 710 |
$ keynam(lenh), ka(nka) , kb(m) |
| 711 |
double precision a(melms) , bl(nb), bu(nb) |
| 712 |
double precision pi(m) |
| 713 |
|
| 714 |
* ------------------------------------------------------------------ |
| 715 |
* m3mpsb inputs the COLUMNS, RHS and RANGES sections of an MPS file. |
| 716 |
* 10 Apr 1992: objadd added as an output parameter. It is minus |
| 717 |
* the coefficient in row iobj of the RHS. |
| 718 |
* 04 May 1992: pi(m) added as an output parameter to return the |
| 719 |
* special RHS called LAGRANGE. |
| 720 |
* ------------------------------------------------------------------ |
| 721 |
|
| 722 |
common /m1eps / eps,eps0,eps1,eps2,eps3,eps4,eps5,plinfy |
| 723 |
common /m1file/ iread,iprint,isumm |
| 724 |
common /m2file/ iback,idump,iload,imps,inewb,insrt, |
| 725 |
$ ioldb,ipnch,iprob,iscr,isoln,ispecs,ireprt |
| 726 |
common /m3mps3/ aijtol,bstruc(2),mlst,mer, |
| 727 |
$ aijmin,aijmax,na0,line,ier(20) |
| 728 |
common /m3mps4/ name(2),mobj(2),mrhs(2),mrng(2),mbnd(2),minmax |
| 729 |
common /m3mps5/ aelem(2), id(6), iblank |
| 730 |
common /m5lobj/ sinf,wtobj,minimz,ninf,iobj,jobj,kobj |
| 731 |
common /m5log1/ idebug,ierr,lprint |
| 732 |
common /m8al1 / penpar,rowtol,ncom,nden,nlag,nmajor,nminor |
| 733 |
common /cyclcm/ cnvtol,jnew,materr,maxcy,nephnt,nphant,nprint |
| 734 |
|
| 735 |
intrinsic abs |
| 736 |
parameter ( zero = 0.0d+0 ) |
| 737 |
|
| 738 |
logical dense, found, gotnm |
| 739 |
character*4 lrhs , lrhsx, lrang, |
| 740 |
$ llagr, lange |
| 741 |
data lrhs , lrhsx, lrang /'RHS ','RHS''','RANG'/ |
| 742 |
data llagr, lange /'LAGR','ANGE'/ |
| 743 |
* ------------------------------------------------------------------ |
| 744 |
|
| 745 |
read (llagr , '(a4)') ilagr |
| 746 |
read (lange , '(a4)') iange |
| 747 |
objadd = zero |
| 748 |
dense = nden .eq. 1 |
| 749 |
bplus = plinfy |
| 750 |
bminus = - bplus |
| 751 |
nmcol1 = 1234 |
| 752 |
nmcol2 = 5678 |
| 753 |
n = 0 |
| 754 |
na0 = 0 |
| 755 |
ne = 0 |
| 756 |
ne1 = -1 |
| 757 |
njac = 0 |
| 758 |
inform = 0 |
| 759 |
call iload1( m, 0, kb, 1 ) |
| 760 |
call dload ( m, zero, pi, 1 ) |
| 761 |
|
| 762 |
* ================================================================== |
| 763 |
* Read the next columns card. |
| 764 |
* ================================================================== |
| 765 |
210 call m3read( 2, imps, line, mlst, key, inform ) |
| 766 |
if (inform .ne. 0) go to 310 |
| 767 |
|
| 768 |
220 if (id(1) .ne. nmcol1 .or. id(2) .ne. nmcol2) then |
| 769 |
|
| 770 |
* Start a new column. |
| 771 |
|
| 772 |
if (ne .le. ne1) go to 310 |
| 773 |
n = n + 1 |
| 774 |
ne1 = ne |
| 775 |
nmcol1 = id(1) |
| 776 |
nmcol2 = id(2) |
| 777 |
if (n .le. mcols) then |
| 778 |
ka(n) = ne + 1 |
| 779 |
name1(n) = nmcol1 |
| 780 |
name2(n) = nmcol2 |
| 781 |
|
| 782 |
* Make room for a dense Jacobian column. |
| 783 |
|
| 784 |
if (nncon .gt. 0) then |
| 785 |
ljac = ne |
| 786 |
if (dense .and. n .le. nnjac) then |
| 787 |
ne = ne + nncon |
| 788 |
if (ne .le. melms) then |
| 789 |
ne = ne - nncon |
| 790 |
do 225 i = 1, nncon |
| 791 |
ne = ne + 1 |
| 792 |
ha(ne) = i |
| 793 |
a(ne) = zero |
| 794 |
225 continue |
| 795 |
end if |
| 796 |
end if |
| 797 |
end if |
| 798 |
end if |
| 799 |
end if |
| 800 |
|
| 801 |
* Process two row names and values. |
| 802 |
|
| 803 |
do 260 i = 1, 2 |
| 804 |
|
| 805 |
* Check for only one on the card. |
| 806 |
|
| 807 |
k = i + i |
| 808 |
id1 = id(k+1) |
| 809 |
id2 = id(k+2) |
| 810 |
if (id1 .ne. iblank) go to 230 |
| 811 |
if (id2 .eq. iblank) go to 260 |
| 812 |
|
| 813 |
* Look up the row name. |
| 814 |
|
| 815 |
230 call m3hash( lenh, m, ncoll, id1, id2, 1, |
| 816 |
$ keynam, name1(lrow), name2(lrow), ia, found ) |
| 817 |
|
| 818 |
if ( found ) then |
| 819 |
aij = aelem(i) |
| 820 |
irow = keynam(ia) |
| 821 |
|
| 822 |
* Test for a duplicate entry. |
| 823 |
|
| 824 |
if (kb(irow) .eq. n) then |
| 825 |
ier(8) = ier(8) + 1 |
| 826 |
if (iprint .gt. 0 .and. ier(8) .le. mer) |
| 827 |
$ write(iprint, 1420) nmcol1, nmcol2, id1, id2, aij, line |
| 828 |
go to 260 |
| 829 |
end if |
| 830 |
|
| 831 |
kb(irow) = n |
| 832 |
if (irow .le. nncon .and. n .le. nnjac) then |
| 833 |
|
| 834 |
* Deal with Jacobian elements. |
| 835 |
|
| 836 |
njac = njac + 1 |
| 837 |
if ( dense ) then |
| 838 |
a(ne1 + irow) = aij |
| 839 |
go to 260 |
| 840 |
end if |
| 841 |
|
| 842 |
* Sparse Jacobian -- make sure the new element is |
| 843 |
* squeezed in ahead of any linear-constraint elements. |
| 844 |
|
| 845 |
ljac = ljac + 1 |
| 846 |
if (ljac .le. ne) then |
| 847 |
aij = a(ljac) |
| 848 |
irow = ha(ljac) |
| 849 |
a(ljac) = aelem(i) |
| 850 |
ha(ljac) = keynam(ia) |
| 851 |
end if |
| 852 |
|
| 853 |
else if (abs( aij ) .lt. aijtol) then |
| 854 |
|
| 855 |
* Ignore small aijs. |
| 856 |
|
| 857 |
na0 = na0 + 1 |
| 858 |
go to 260 |
| 859 |
end if |
| 860 |
|
| 861 |
* Pack the nonzero. |
| 862 |
|
| 863 |
ne = ne + 1 |
| 864 |
if (ne .le. melms) then |
| 865 |
ha(ne) = irow |
| 866 |
a(ne) = aij |
| 867 |
end if |
| 868 |
else |
| 869 |
ier(5) = ier(5) + 1 |
| 870 |
if (iprint .gt. 0 .and. ier(5) .le. mer) |
| 871 |
$ write(iprint, 1400) id1, id2, line |
| 872 |
end if |
| 873 |
260 continue |
| 874 |
go to 210 |
| 875 |
|
| 876 |
* Test for an empty column. |
| 877 |
|
| 878 |
310 if (ne .le. ne1) then |
| 879 |
|
| 880 |
* Column with no rows. Warning unless variable is nonlinear. |
| 881 |
* Insert dummy column with zero in first row. |
| 882 |
|
| 883 |
if (n .gt. nn) then |
| 884 |
ier(6) = ier(6) + 1 |
| 885 |
if (iprint .gt. 0 .and. ier(6) .le. mer) |
| 886 |
$ write(iprint, 1500) nmcol1, nmcol2 |
| 887 |
end if |
| 888 |
|
| 889 |
ne = ne + 1 |
| 890 |
if (ne .le. melms) then |
| 891 |
ha(ne) = 1 |
| 892 |
a(ne) = zero |
| 893 |
end if |
| 894 |
if (inform .eq. 0) go to 220 |
| 895 |
end if |
| 896 |
|
| 897 |
* ================================================================== |
| 898 |
* See if we have hit the RHS. |
| 899 |
* ================================================================== |
| 900 |
if (key .ne. lrhs .and. key .ne. lrhsx) then |
| 901 |
|
| 902 |
* Nope sumpins rong. |
| 903 |
* Terminate the COLUMNS section anyway. |
| 904 |
|
| 905 |
ier(7) = ier(7) + 1 |
| 906 |
if (iprint .gt. 0) write(iprint, 1140) |
| 907 |
if (isumm .gt. 0) write(isumm , 1140) |
| 908 |
end if |
| 909 |
|
| 910 |
* Are there any columns at all? |
| 911 |
* Or too many columns or elements? |
| 912 |
* Include phantom columns and elements too. |
| 913 |
|
| 914 |
nephnt = max( nephnt, nphant ) |
| 915 |
if (n .le. 0) then |
| 916 |
if (iprint .gt. 0) write(iprint, 1610) |
| 917 |
if (isumm .gt. 0) write(isumm , 1610) |
| 918 |
ier(2) = ier(2) + 1 |
| 919 |
ierr = 40 |
| 920 |
return |
| 921 |
else if (n + nphant .gt. mcols) then |
| 922 |
n = n + nphant |
| 923 |
if (iprint .gt. 0) write(iprint, 3040) mcols, n |
| 924 |
if (isumm .gt. 0) write(isumm , 3040) mcols, n |
| 925 |
ier(2) = ier(2) + 1 |
| 926 |
ierr = 41 |
| 927 |
return |
| 928 |
else if (ne + nephnt .gt. melms) then |
| 929 |
ne = ne + nephnt |
| 930 |
if (iprint .gt. 0) write(iprint, 3050) melms, ne |
| 931 |
if (isumm .gt. 0) write(isumm , 3050) melms, ne |
| 932 |
ier(2) = ier(2) + 1 |
| 933 |
ierr = 41 |
| 934 |
return |
| 935 |
end if |
| 936 |
|
| 937 |
* ------------------------------------------------------------------ |
| 938 |
* Input the RHS. |
| 939 |
* ------------------------------------------------------------------ |
| 940 |
if (isumm .gt. 0) write(isumm, 5200) n, ne |
| 941 |
|
| 942 |
* Insert phantom columns for cycling algorithm. |
| 943 |
* Give them names PHNT 1, PHNT 2, ... |
| 944 |
* (Trouble if more than 9999 phantom columns.) |
| 945 |
|
| 946 |
if (nphant .gt. 0) then |
| 947 |
do 402 i = 1, nephnt |
| 948 |
j = ne + i |
| 949 |
ha(j) = 1 |
| 950 |
a(j) = zero |
| 951 |
402 continue |
| 952 |
|
| 953 |
do 403 k = 1, nphant |
| 954 |
n = n + 1 |
| 955 |
ne = ne + 1 |
| 956 |
write(name1(n), '(a4)') 'PHNT' |
| 957 |
write(name2(n), '(i4)') k |
| 958 |
ka(n) = ne |
| 959 |
if (k .eq. 1) ne = ne + nephnt - nphant |
| 960 |
403 continue |
| 961 |
end if |
| 962 |
|
| 963 |
* We finally know how big the problem is. |
| 964 |
|
| 965 |
ka(n+1) = ne + 1 |
| 966 |
|
| 967 |
* Set bounds to default values. |
| 968 |
|
| 969 |
call dload ( n, bstruc(1), bl, 1 ) |
| 970 |
call dload ( n, bstruc(2), bu, 1 ) |
| 971 |
|
| 972 |
do 408 i = 1, m |
| 973 |
k = hrtype(i) |
| 974 |
jslack = n + i |
| 975 |
if (k .lt. 0) bl(jslack) = bminus |
| 976 |
if (k .le. 0) bu(jslack) = zero |
| 977 |
if (k .ge. 0) bl(jslack) = zero |
| 978 |
if (k .gt. 0) bu(jslack) = bplus |
| 979 |
if (k .eq. 2) bl(jslack) = bminus |
| 980 |
408 continue |
| 981 |
|
| 982 |
* Check for no RHS. |
| 983 |
|
| 984 |
if (key .ne. lrhs .and. key .ne. lrhsx) go to 600 |
| 985 |
gotnm = mrhs(1) .ne. iblank |
| 986 |
inform = 0 |
| 987 |
|
| 988 |
* ================================================================== |
| 989 |
* Read next RHS card and see if it is the one we want. |
| 990 |
* ================================================================== |
| 991 |
410 call m3read( 2, imps, line, mlst, key, inform ) |
| 992 |
if (inform .ne. 0) go to 600 |
| 993 |
|
| 994 |
* A normal RHS is terminated if LAGRANGE is found. |
| 995 |
|
| 996 |
if (id(1) .eq. ilagr .and. id(2) .eq. iange) go to 490 |
| 997 |
|
| 998 |
if (.not. gotnm) then |
| 999 |
gotnm = .true. |
| 1000 |
mrhs(1) = id(1) |
| 1001 |
mrhs(2) = id(2) |
| 1002 |
end if |
| 1003 |
|
| 1004 |
if (id(1) .eq. mrhs(1) .and. id(2) .eq. mrhs(2)) then |
| 1005 |
|
| 1006 |
* Look at both halves of the record. |
| 1007 |
|
| 1008 |
do 440 i = 1, 2 |
| 1009 |
k = i + i |
| 1010 |
id1 = id(k+1) |
| 1011 |
id2 = id(k+2) |
| 1012 |
if (id1 .eq. iblank .and. id2 .eq. iblank) go to 440 |
| 1013 |
call m3hash( lenh, m, ncoll, id1, id2, 1, |
| 1014 |
$ keynam, name1(lrow), name2(lrow), ia,found ) |
| 1015 |
|
| 1016 |
if ( found ) then |
| 1017 |
ncard(2) = ncard(2) + 1 |
| 1018 |
bnd = aelem(i) |
| 1019 |
irow = keynam(ia) |
| 1020 |
jslack = n + irow |
| 1021 |
k = hrtype(irow) |
| 1022 |
if (irow .eq. iobj) then |
| 1023 |
objadd = - bnd |
| 1024 |
else if (k .ne. 2) then |
| 1025 |
if (k .le. 0) bu(jslack) = - bnd |
| 1026 |
if (k .ge. 0) bl(jslack) = - bnd |
| 1027 |
end if |
| 1028 |
else |
| 1029 |
ier(5) = ier(5) + 1 |
| 1030 |
if (iprint .gt. 0 .and. ier(5) .le. mer) |
| 1031 |
$ write(iprint, 1400) id1, id2, line |
| 1032 |
end if |
| 1033 |
440 continue |
| 1034 |
end if |
| 1035 |
go to 410 |
| 1036 |
|
| 1037 |
* LAGRANGE RHS found. |
| 1038 |
|
| 1039 |
490 if (ncard(2) .eq. 0) then |
| 1040 |
mrhs(1) = iblank |
| 1041 |
mrhs(2) = iblank |
| 1042 |
if (iprint .gt. 0) write(iprint, 1720) |
| 1043 |
end if |
| 1044 |
go to 520 |
| 1045 |
|
| 1046 |
* ================================================================== |
| 1047 |
* Read next RHS card and see if it is a LAGRANGE one. |
| 1048 |
* ================================================================== |
| 1049 |
510 call m3read( 2, imps, line, mlst, key, inform ) |
| 1050 |
if (inform .ne. 0) go to 600 |
| 1051 |
|
| 1052 |
if (id(1) .ne. ilagr .or. id(2) .ne. iange) go to 510 |
| 1053 |
|
| 1054 |
* Find which row. |
| 1055 |
* Look at both halves of the record. |
| 1056 |
|
| 1057 |
520 do 540 i = 1, 2 |
| 1058 |
k = i + i |
| 1059 |
id1 = id(k+1) |
| 1060 |
id2 = id(k+2) |
| 1061 |
if (id1 .eq. iblank .and. id2 .eq. iblank) go to 540 |
| 1062 |
call m3hash( lenh, m, ncoll, id1, id2, 1, |
| 1063 |
$ keynam, name1(lrow), name2(lrow), ia,found ) |
| 1064 |
|
| 1065 |
if ( found ) then |
| 1066 |
ncard(5) = ncard(5) + 1 |
| 1067 |
irow = keynam(ia) |
| 1068 |
pi(irow) = aelem(i) |
| 1069 |
else |
| 1070 |
ier(5) = ier(5) + 1 |
| 1071 |
if (iprint .gt. 0 .and. ier(5) .le. mer) |
| 1072 |
$ write(iprint, 1400) id1, id2, line |
| 1073 |
end if |
| 1074 |
540 continue |
| 1075 |
go to 510 |
| 1076 |
|
| 1077 |
* ------------------------------------------------------------------ |
| 1078 |
* RHS has been input. |
| 1079 |
* ------------------------------------------------------------------ |
| 1080 |
600 if (ncard(2) .eq. 0) then |
| 1081 |
if (iprint .gt. 0) write(iprint, 1620) |
| 1082 |
if (isumm .gt. 0) write(isumm , 1620) |
| 1083 |
end if |
| 1084 |
|
| 1085 |
if (objadd .ne. zero) then |
| 1086 |
if (iprint .gt. 0) write(iprint, 1630) objadd |
| 1087 |
if (isumm .gt. 0) write(isumm , 1630) objadd |
| 1088 |
end if |
| 1089 |
|
| 1090 |
* ------------------------------------------------------------------ |
| 1091 |
* Input RANGES. |
| 1092 |
* ------------------------------------------------------------------ |
| 1093 |
|
| 1094 |
* Check for no RANGES. |
| 1095 |
|
| 1096 |
if (key .ne. lrang) go to 800 |
| 1097 |
gotnm = mrng(1) .ne. iblank |
| 1098 |
inform = 0 |
| 1099 |
|
| 1100 |
* ================================================================== |
| 1101 |
* Read card and see if it is the range we want. |
| 1102 |
* ================================================================== |
| 1103 |
610 call m3read( 2, imps, line, mlst, key, inform ) |
| 1104 |
if (inform .ne. 0) go to 800 |
| 1105 |
|
| 1106 |
if (.not. gotnm) then |
| 1107 |
gotnm = .true. |
| 1108 |
mrng(1) = id(1) |
| 1109 |
mrng(2) = id(2) |
| 1110 |
end if |
| 1111 |
|
| 1112 |
if (id(1) .eq. mrng(1) .and. id(2) .eq. mrng(2)) then |
| 1113 |
|
| 1114 |
* Look at both halves of the record. |
| 1115 |
|
| 1116 |
do 640 i = 1, 2 |
| 1117 |
k = i + i |
| 1118 |
id1 = id(k+1) |
| 1119 |
id2 = id(k+2) |
| 1120 |
if (id1 .eq. iblank .and. id2 .eq. iblank) go to 640 |
| 1121 |
call m3hash( lenh, m, ncoll, id1, id2, 1, |
| 1122 |
$ keynam, name1(lrow), name2(lrow), ia,found ) |
| 1123 |
|
| 1124 |
if ( found ) then |
| 1125 |
ncard(3) = ncard(3)+1 |
| 1126 |
brng = aelem(i) |
| 1127 |
arng = abs( brng ) |
| 1128 |
irow = keynam(ia) |
| 1129 |
jslack = n + irow |
| 1130 |
k = hrtype(irow) |
| 1131 |
if (k .ne. 2) then |
| 1132 |
if (k .lt. 0) bl(jslack) = bu(jslack) - arng |
| 1133 |
if (k .gt. 0) bu(jslack) = bl(jslack) + arng |
| 1134 |
if (k .eq. 0) then |
| 1135 |
if (brng .gt. zero) bl(jslack) = bu(jslack) - arng |
| 1136 |
if (brng .lt. zero) bu(jslack) = bl(jslack) + arng |
| 1137 |
end if |
| 1138 |
end if |
| 1139 |
else |
| 1140 |
ier(5) = ier(5) + 1 |
| 1141 |
if (iprint .gt. 0 .and. ier(5) .le. mer) |
| 1142 |
$ write(iprint, 1400) id1, id2, line |
| 1143 |
end if |
| 1144 |
640 continue |
| 1145 |
end if |
| 1146 |
go to 610 |
| 1147 |
|
| 1148 |
* RANGES have been input. |
| 1149 |
|
| 1150 |
800 return |
| 1151 |
|
| 1152 |
1140 format(' XXXX RHS card not found') |
| 1153 |
1400 format(' XXXX Non-existent row specified -- ', 2a4, |
| 1154 |
$ ' -- entry ignored in line', i7) |
| 1155 |
1420 format(' XXXX Column ', 2a4, ' has more than one entry', |
| 1156 |
$ ' in row ', 2a4 |
| 1157 |
$ / ' XXXX Coefficient', 1p, e15.5, ' ignored in line', i10) |
| 1158 |
1500 format(' XXXX No valid row entries in column ', 2a4) |
| 1159 |
1610 format(' XXXX No columns specified') |
| 1160 |
1620 format(' XXXX Warning - the RHS is zero') |
| 1161 |
1630 format(' XXXX Note: constant', 1p, e15.7, |
| 1162 |
$ ' is added to the objective.') |
| 1163 |
1720 format(' XXXX Warning - first RHS is LAGRANGE.', |
| 1164 |
$ ' Other RHS''s will be ignored.') |
| 1165 |
2000 format(2a4) |
| 1166 |
3040 format(' XXXX Too many columns. The limit was', i8, |
| 1167 |
$ 4x, ' Actual number is', i8) |
| 1168 |
3050 format(' XXXX Too many elements. The limit was', i8, |
| 1169 |
$ 4x, ' Actual number is', i8) |
| 1170 |
5200 format(' Columns', i8 / ' Elements', i7) |
| 1171 |
|
| 1172 |
* end of m3mpsb |
| 1173 |
end |
| 1174 |
|
| 1175 |
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 1176 |
|
| 1177 |
subroutine m3mpsc( m, n, nb, ne, ns, lennm, |
| 1178 |
$ key, ncard, name1, name2, |
| 1179 |
$ bl, bu, hs, xn ) |
| 1180 |
|
| 1181 |
implicit double precision (a-h,o-z) |
| 1182 |
character*4 key |
| 1183 |
integer*4 hs(nb) |
| 1184 |
integer ncard(6), name1(lennm), name2(lennm) |
| 1185 |
double precision bl(nb), bu(nb) |
| 1186 |
double precision xn(nb) |
| 1187 |
|
| 1188 |
* ------------------------------------------------------------------ |
| 1189 |
* m3mpsc inputs the BOUNDS section of an MPS file. |
| 1190 |
* ------------------------------------------------------------------ |
| 1191 |
|
| 1192 |
common /m1eps / eps,eps0,eps1,eps2,eps3,eps4,eps5,plinfy |
| 1193 |
common /m1file/ iread,iprint,isumm |
| 1194 |
common /m2file/ iback,idump,iload,imps,inewb,insrt, |
| 1195 |
$ ioldb,ipnch,iprob,iscr,isoln,ispecs,ireprt |
| 1196 |
common /m3mps3/ aijtol,bstruc(2),mlst,mer, |
| 1197 |
$ aijmin,aijmax,na0,line,ier(20) |
| 1198 |
common /m3mps4/ name(2),mobj(2),mrhs(2),mrng(2),mbnd(2),minmax |
| 1199 |
common /m3mps5/ aelem(2), id(6), iblank |
| 1200 |
common /m5log1/ idebug,ierr,lprint |
| 1201 |
common /cyclcm/ cnvtol,jnew,materr,maxcy,nephnt,nphant,nprint |
| 1202 |
|
| 1203 |
intrinsic abs, max, min |
| 1204 |
parameter ( zero = 0.0d+0 ) |
| 1205 |
|
| 1206 |
logical gotnm, ignore |
| 1207 |
character*4 a4, |
| 1208 |
$ lboun, lenda, |
| 1209 |
$ lfr , lfx, llo, lmi, lpl, lup, |
| 1210 |
$ linit, lial |
| 1211 |
data a4 /'(a4)'/ |
| 1212 |
data lboun, lenda /'BOUN','ENDA'/ |
| 1213 |
data lfr , lfx, llo /' FR ',' FX ',' LO '/ |
| 1214 |
data lmi , lpl, lup /' MI ',' PL ',' UP '/ |
| 1215 |
data linit, lial /'INIT', 'IAL '/ |
| 1216 |
* ------------------------------------------------------------------ |
| 1217 |
|
| 1218 |
read (linit , '(a4)') iinit |
| 1219 |
read (lial , '(a4)') iial |
| 1220 |
inform = 1 |
| 1221 |
bplus = plinfy |
| 1222 |
bminus = -bplus |
| 1223 |
|
| 1224 |
* Fix phantom variables at zero. |
| 1225 |
|
| 1226 |
j1 = n - nphant + 1 |
| 1227 |
call dload ( nphant, zero, bl(j1), 1 ) |
| 1228 |
call dload ( nphant, zero, bu(j1), 1 ) |
| 1229 |
|
| 1230 |
* Check for no BOUNDS. |
| 1231 |
|
| 1232 |
if (key .ne. lboun) go to 700 |
| 1233 |
gotnm = mbnd(1). ne. iblank |
| 1234 |
inform = 0 |
| 1235 |
jmark = 1 |
| 1236 |
|
| 1237 |
* ================================================================== |
| 1238 |
* Read and check BOUNDS cards. Notice the double plural. |
| 1239 |
* ================================================================== |
| 1240 |
610 call m3read( 3, imps, line, mlst, key, inform ) |
| 1241 |
if (inform .ne. 0) go to 700 |
| 1242 |
|
| 1243 |
* A normal bounds set is terminated if INITIAL is found. |
| 1244 |
|
| 1245 |
bnd = aelem(1) |
| 1246 |
if (id(1) .eq. iinit .and. id(2) .eq. iial ) go to 690 |
| 1247 |
|
| 1248 |
if (.not. gotnm) then |
| 1249 |
gotnm = .true. |
| 1250 |
mbnd(1) = id(1) |
| 1251 |
mbnd(2) = id(2) |
| 1252 |
end if |
| 1253 |
|
| 1254 |
if (id(1) .ne. mbnd(1) .or. id(2) .ne. mbnd(2)) go to 610 |
| 1255 |
|
| 1256 |
* Find which column. |
| 1257 |
|
| 1258 |
call m4name( n, name1, name2, id(3), id(4), |
| 1259 |
$ line, ier(10), 0, 1, n, jmark, j ) |
| 1260 |
|
| 1261 |
if (j .le. 0) then |
| 1262 |
if (iprint .gt. 0 .and. ier(10) .le. mer) |
| 1263 |
$ write(iprint, 1400) id(3), id(4), line |
| 1264 |
else |
| 1265 |
|
| 1266 |
* Select bound type for column j. |
| 1267 |
|
| 1268 |
ncard(4) = ncard(4) + 1 |
| 1269 |
if (key .eq. lup) then |
| 1270 |
bu(j) = bnd |
| 1271 |
else if (key .eq. llo) then |
| 1272 |
bl(j) = bnd |
| 1273 |
else if (key .eq. lfx) then |
| 1274 |
bu(j) = bnd |
| 1275 |
bl(j) = bnd |
| 1276 |
else if (key .eq. lfr) then |
| 1277 |
bu(j) = bplus |
| 1278 |
bl(j) = bminus |
| 1279 |
else if (key .eq. lmi) then |
| 1280 |
if (bu(j) .ge. bplus) bu(j) = zero |
| 1281 |
bl(j) = bminus |
| 1282 |
else if (key .eq. lpl) then |
| 1283 |
bu(j) = bplus |
| 1284 |
*--- bl(j) = zero |
| 1285 |
*--- 31-oct-1989: John Stone suggests delete this line |
| 1286 |
*--- and add the "if" above. |
| 1287 |
else |
| 1288 |
* This lad didn't even make it to Form 1. |
| 1289 |
|
| 1290 |
ier(11) = ier(11) + 1 |
| 1291 |
if (iprint .gt. 0 .and. ier(11) .le. mer) |
| 1292 |
$ write(iprint, 1700) line, key, (id(i), i=1,4) |
| 1293 |
end if |
| 1294 |
end if |
| 1295 |
go to 610 |
| 1296 |
|
| 1297 |
* INITIAL bounds set found. |
| 1298 |
|
| 1299 |
690 if (ncard(4) .eq. 0) then |
| 1300 |
mbnd(1) = iblank |
| 1301 |
mbnd(2) = iblank |
| 1302 |
if (iprint .gt. 0) write(iprint, 1720) |
| 1303 |
end if |
| 1304 |
|
| 1305 |
* ------------------------------------------------------------------ |
| 1306 |
* End of normal bounds. |
| 1307 |
* ------------------------------------------------------------------ |
| 1308 |
700 ns = 0 |
| 1309 |
bplus = 0.9*bplus |
| 1310 |
bminus = - bplus |
| 1311 |
|
| 1312 |
* Set variables to be nonbasic at zero (as long as that's feasible). |
| 1313 |
|
| 1314 |
do 706 j = 1, nb |
| 1315 |
xn(j) = max( zero , bl(j) ) |
| 1316 |
xn(j) = min( xn(j), bu(j) ) |
| 1317 |
hs(j) = 0 |
| 1318 |
if (xn(j) .eq. bu(j)) hs(j) = 1 |
| 1319 |
706 continue |
| 1320 |
|
| 1321 |
* Ignore INITIAL bounds if a basis will be loaded. |
| 1322 |
|
| 1323 |
if (inform .ne. 0) go to 790 |
| 1324 |
ignore = ioldb .gt. 0 .or. insrt .gt. 0 .or. iload .gt. 0 |
| 1325 |
if (.not. ignore ) then |
| 1326 |
jmark = 1 |
| 1327 |
go to 720 |
| 1328 |
end if |
| 1329 |
|
| 1330 |
* ================================================================== |
| 1331 |
* Read INITIAL bounds set. |
| 1332 |
* ================================================================== |
| 1333 |
710 call m3read( 3, imps, line, mlst, key, inform ) |
| 1334 |
if (inform .ne. 0) go to 790 |
| 1335 |
|
| 1336 |
bnd = aelem(1) |
| 1337 |
if (ignore .or. id(1).ne.iinit .or. id(2).ne.iial) go to 710 |
| 1338 |
|
| 1339 |
* Find which column. |
| 1340 |
|
| 1341 |
720 call m4name( n, name1, name2, id(3), id(4), |
| 1342 |
$ line, ier(12), 0, 1, n, jmark, j ) |
| 1343 |
|
| 1344 |
if (j .le. 0) then |
| 1345 |
if (iprint .gt. 0 .and. ier(12) .le. mer) |
| 1346 |
$ write(iprint, 1400) id(3), id(4), line |
| 1347 |
else |
| 1348 |
|
| 1349 |
* Select bound type for column j. |
| 1350 |
|
| 1351 |
ncard(6) = ncard(6)+1 |
| 1352 |
if (key .eq. lfr) then |
| 1353 |
js = -1 |
| 1354 |
else if (key .eq. lfx) then |
| 1355 |
js = 2 |
| 1356 |
ns = ns + 1 |
| 1357 |
else if (key .eq. llo) then |
| 1358 |
js = 4 |
| 1359 |
bnd = bl(j) |
| 1360 |
else if (key .eq. lup) then |
| 1361 |
js = 5 |
| 1362 |
bnd = bu(j) |
| 1363 |
else if (key .eq. lmi) then |
| 1364 |
js = 4 |
| 1365 |
else if (key .eq. lpl) then |
| 1366 |
js = 5 |
| 1367 |
else |
| 1368 |
ier(13) = ier(13) + 1 |
| 1369 |
if (iprint .gt. 0 .and. ier(13) .le. mer) |
| 1370 |
$ write(iprint, 1700) line, key, (id(i), i=1,4) |
| 1371 |
go to 710 |
| 1372 |
end if |
| 1373 |
end if |
| 1374 |
|
| 1375 |
if (abs( bnd ) .ge. bplus) bnd = zero |
| 1376 |
xn(j) = bnd |
| 1377 |
hs(j) = js |
| 1378 |
go to 710 |
| 1379 |
|
| 1380 |
* Should be ENDATA card. |
| 1381 |
|
| 1382 |
790 if (key .ne. lenda) then |
| 1383 |
ier(14) = 1 |
| 1384 |
if (iprint .gt. 0) write(iprint, 1150) |
| 1385 |
if (isumm .gt. 0) write(isumm , 1150) |
| 1386 |
end if |
| 1387 |
|
| 1388 |
* ------------------------------------------------------------------ |
| 1389 |
* Pass the buck - not got to Truman yet. |
| 1390 |
* ------------------------------------------------------------------ |
| 1391 |
|
| 1392 |
* Check that bl .le. bu |
| 1393 |
|
| 1394 |
do 802 j = 1, n |
| 1395 |
b1 = bl(j) |
| 1396 |
b2 = bu(j) |
| 1397 |
if (b1 .gt. b2) then |
| 1398 |
ier(20) = ier(20) + 1 |
| 1399 |
if (iprint .gt. 0 .and. ier(20) .le. mer) |
| 1400 |
$ write(iprint, 1740) j, b1, b2 |
| 1401 |
bl(j) = b2 |
| 1402 |
bu(j) = b1 |
| 1403 |
end if |
| 1404 |
802 continue |
| 1405 |
|
| 1406 |
* Count the errors. |
| 1407 |
|
| 1408 |
k = 0 |
| 1409 |
do 804 i = 1, 20 |
| 1410 |
k = k + ier(i) |
| 1411 |
804 continue |
| 1412 |
if (k .gt. 0) then |
| 1413 |
if (iprint .gt. 0) write(iprint, 1900) k |
| 1414 |
if (isumm .gt. 0) write(isumm , 1900) k |
| 1415 |
end if |
| 1416 |
if (iprint .gt. 0) then |
| 1417 |
write(iprint, 2100) mobj, minmax, ncard(1), |
| 1418 |
$ mrhs, ncard(2), |
| 1419 |
$ mrng, ncard(3), |
| 1420 |
$ mbnd, ncard(4) |
| 1421 |
end if |
| 1422 |
return |
| 1423 |
|
| 1424 |
1150 format(' XXXX ENDATA card not found') |
| 1425 |
1400 format(' XXXX Non-existent column specified -- ', 2a4, |
| 1426 |
$ ' -- entry ignored in line', i7) |
| 1427 |
1700 format(' XXXX Illegal bound type at line', i7, '... ', |
| 1428 |
$ a1, a2, a1, 2a4, 2x, 2a4) |
| 1429 |
1720 format(' XXXX Warning - first bounds set is INITIAL .', |
| 1430 |
$ ' Other bounds will be ignored.') |
| 1431 |
1740 format(/' XXXX Bounds back to front on column', i6,' :', |
| 1432 |
$ 1p, 2e15.5) |
| 1433 |
1900 format(/' XXXX Total no. of errors in MPS file', i6) |
| 1434 |
2100 format(/// |
| 1435 |
$ ' Names selected' / |
| 1436 |
$ ' --------------' / |
| 1437 |
$ ' Objective', 6x, 2a4, ' (', a3, ')', i8 / |
| 1438 |
$ ' RHS ', 6x, 2a4, i14 / |
| 1439 |
$ ' RANGES ', 6x, 2a4, i14 / |
| 1440 |
$ ' BOUNDS ', 6x, 2a4, i14) |
| 1441 |
|
| 1442 |
* end of m3mpsc |
| 1443 |
end |
| 1444 |
|
| 1445 |
*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 1446 |
|
| 1447 |
subroutine m3read( mode, imps, line, mxlist, key, inform ) |
| 1448 |
|
| 1449 |
implicit double precision (a-h,o-z) |
| 1450 |
character*4 key |
| 1451 |
|
| 1452 |
* ------------------------------------------------------------------ |
| 1453 |
* m3read reads data from file imps and prints a listing on file |
| 1454 |
* iprint. The data is assumed to be in MPS format, with items of |
| 1455 |
* interest in the following six fields... |
| 1456 |
* |
| 1457 |
* Field: 1 2 3 4 5 6 |
| 1458 |
* |
| 1459 |
* Columns: 01-04 05-12 15-22 25-36 40-47 50-61 |
| 1460 |
* |
| 1461 |
* Format: a4 2a4 2a4 e12.0 2a4 e12.0 |
| 1462 |
* |
| 1463 |
* Data: key id(1-2) id(3-4) aelem(1) id(5-6) aelem(2) |
| 1464 |
* |
| 1465 |
* |
| 1466 |
* Comments may contain a * in column 1 and anything in columns 2-61. |
| 1467 |
* They are listed and then ignored. |
| 1468 |
* |
| 1469 |
* |
| 1470 |
* On entry, mode specifies which fields are to be processed. |
| 1471 |
* On exit , inform is set to 1 if column 1 is not blank. |
| 1472 |
* |
| 1473 |
* 04 Oct 1985: First version. |
| 1474 |
* 27 Sep 1991: More f77. Each line read into a character buffer |
| 1475 |
* to simplify handling of comments and key. |
| 1476 |
* ------------------------------------------------------------------ |
| 1477 |
|
| 1478 |
common /m1file/ iread,iprint,isumm |
| 1479 |
common /m3mps5/ aelem(2), id(6), iblank |
| 1480 |
|
| 1481 |
character*61 buffer |
| 1482 |
character*1 buff1 |
| 1483 |
character*1 lblank , lstar |
| 1484 |
data lblank /' '/, lstar /'*'/ |
| 1485 |
|
| 1486 |
* ------------------------------------------------------------------ |
| 1487 |
* Read a data card and look for keywords and comments. |
| 1488 |
* ------------------------------------------------------------------ |
| 1489 |
10 read (imps, 1000) buffer |
| 1490 |
buff1 = buffer(1:1) |
| 1491 |
line = line + 1 |
| 1492 |
|
| 1493 |
* Print the buffer if column 1 is nonblank |
| 1494 |
* or if a listing is wanted. |
| 1495 |
|
| 1496 |
if (buff1 .ne. lblank .or. line .le. mxlist) then |
| 1497 |
|
| 1498 |
* Find the last nonblank character. |
| 1499 |
|
| 1500 |
do 20 last = 61, 2, -1 |
| 1501 |
if (buffer(last:last) .ne. lblank) go to 30 |
| 1502 |
20 continue |
| 1503 |
last = 1 |
| 1504 |
|
| 1505 |
30 if (iprint .gt. 0) write(iprint, 2000) line, buffer(1:last) |
| 1506 |
end if |
| 1507 |
|
| 1508 |
* Ignore comments. |
| 1509 |
|
| 1510 |
if (buff1 .eq. lstar ) go to 10 |
| 1511 |
|
| 1512 |
* If column 1 is nonblank, load key and exit. |
| 1513 |
* The NAME card is unusual in having some data in field 3. |
| 1514 |
* We have to load it into id(3)-id(4). |
| 1515 |
|
| 1516 |
if (buff1 .ne. lblank) then |
| 1517 |
read(buffer, 1100) key, id(1), id(2), id(3), id(4) |
| 1518 |
inform = 1 |
| 1519 |
return |
| 1520 |
end if |
| 1521 |
|
| 1522 |
* ------------------------------------------------------------------ |
| 1523 |
* Process normal data cards. |
| 1524 |
* ------------------------------------------------------------------ |
| 1525 |
if (mode .eq. 1) then |
| 1526 |
|
| 1527 |
* NAME or ROWS sections. |
| 1528 |
|
| 1529 |
read(buffer, 1100) key, id(1), id(2), id(3), id(4) |
| 1530 |
else if (mode .eq. 2) then |
| 1531 |
|
| 1532 |
* COLUMNS, RHS or RANGES sections. |
| 1533 |
|
| 1534 |
read(buffer, 1100) key, id(1), id(2), |
| 1535 |
$ id(3), id(4), aelem(1), |
| 1536 |
$ id(5), id(6), aelem(2) |
| 1537 |
else |
| 1538 |
|
| 1539 |
* BOUNDS section. |
| 1540 |
|
| 1541 |
read(buffer, 1100) key, id(1), id(2), id(3), id(4), aelem(1) |
| 1542 |
end if |
| 1543 |
|
| 1544 |
return |
| 1545 |
|
| 1546 |
1000 format(a61) |
| 1547 |
1100 format(a4, 2a4, 2x, 2a4, 2x, e12.0, 3x, 2a4, 2x, e12.0) |
| 1548 |
2000 format(i7, 4x, a) |
| 1549 |
|
| 1550 |
* end of m3read |
| 1551 |
end |
Parent Directory
| 
Revision Log