/[ascend]/trunk/minos54/mi35inpt.f
ViewVC logotype

Contents of /trunk/minos54/mi35inpt.f

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations) (download)
Fri Oct 29 20:54:12 2004 UTC (17 years, 9 months ago) by aw0a
File size: 52377 byte(s)
Setting up web subdirectory in repository
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

john.pye@anu.edu.au
ViewVC Help
Powered by ViewVC 1.1.22