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

Contents of /trunk/minos54/mi30spec.f

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations) (download)
Fri Oct 29 20:54:12 2004 UTC (19 years, 7 months ago) by aw0a
File size: 79259 byte(s)
Setting up web subdirectory in repository
1 *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2 * File mi30spec fortran
3 *
4 * miopt miopti mioptr m3char m3dflt m3key
5 * opfile oplook opnumb opscan optokn opuppr
6 *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
7
8 subroutine miopt ( buffer, iprint, isumm, inform )
9
10 implicit double precision (a-h,o-z)
11 character*(72) buffer
12
13 * ------------------------------------------------------------------
14 * miopt decodes the option contained in buffer.
15 *
16 * The buffer is output to file iprint, minus trailing blanks.
17 * Error messages are output to files iprint and isumm.
18 * buffer is echoed to iprint but normally not to isumm.
19 * It is echoed to isumm before any error msg.
20 *
21 * On entry,
22 * iprint is the Print file. No output occurs if iprint .le 0.
23 * isumm is the Summary file. No output occurs if isumm .le 0.
24 * inform is the number of errors so far.
25 *
26 * On exit,
27 * inform is the number of errors so far.
28 *
29 * 27 Nov 1991: First version.
30 * ------------------------------------------------------------------
31
32 character*16 key
33
34 call m3key ( buffer, key, iprint, isumm, inform )
35
36 * end of miopt
37 end
38
39 *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
40
41 subroutine miopti( buffer, ivalue, iprint, isumm, inform )
42
43 implicit double precision (a-h,o-z)
44 character*(56) buffer
45 integer ivalue
46
47 * ------------------------------------------------------------------
48 * miopti decodes the option contained in buffer // ivalue.
49 * The parameters other than ivalue are as in miopt.
50 *
51 * 27 Nov 1991: First version.
52 * 17 Jan 1992: buff72 needed to comply with f77 standard.
53 * ------------------------------------------------------------------
54
55 character*16 key
56 character*72 buff72
57
58 write(key, '(i16)') ivalue
59 lenbuf = len(buffer)
60 buff72 = buffer
61 buff72(lenbuf+1:lenbuf+16) = key
62 call m3key ( buff72, key, iprint, isumm, inform )
63
64 * end of miopti
65 end
66
67 *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
68
69 subroutine mioptr( buffer, rvalue, iprint, isumm, inform )
70
71 implicit double precision (a-h,o-z)
72 character*(56) buffer
73 double precision rvalue
74
75 * ------------------------------------------------------------------
76 * mioptr decodes the option contained in buffer // rvalue.
77 * The parameters other than rvalue are as in miopt.
78 *
79 * 27 Nov 1991: First version.
80 * 17 Jan 1992: buff72 needed to comply with f77 standard.
81 * ------------------------------------------------------------------
82
83 character*16 key
84 character*72 buff72
85
86 write(key, '(1p, e16.8)') rvalue
87 lenbuf = len(buffer)
88 buff72 = buffer
89 buff72(lenbuf+1:lenbuf+16) = key
90 call m3key ( buff72, key, iprint, isumm, inform )
91
92 * end of mioptr
93 end
94
95 *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
96
97 subroutine m3char( lname, iname )
98
99 character*4 lname
100 integer iname
101
102 * ------------------------------------------------------------------
103 * m3char copies lname into iname.
104 * lname contains character data in a4 format.
105 * ------------------------------------------------------------------
106
107 read (lname, '(a4)') iname
108
109 * end of m3char
110 end
111
112 *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
113
114 subroutine m3dflt( mode )
115
116 implicit double precision (a-h,o-z)
117
118 * ------------------------------------------------------------------
119 * If mode = 1, m3dflt sets default values for most of the parameters
120 * that can be altered by opfile via the OPTIONS file.
121 * If mode = 2, the parameter values are checked and possibly changed
122 * to reasonable values.
123 * If mode = 3 and iprint > 0 and iparm(3) > 0, the parameters are
124 * printed. (In the OPTIONS file, Suppress parameters
125 * sets iparm(3) = 0.)
126 *
127 * 26 Apr 1992: mode 3 added.
128 * ------------------------------------------------------------------
129
130 logical conv,restrt
131 logical alone, AMPL, GAMS, MINT, page1, page2
132 common /m1env / alone, AMPL, GAMS, MINT, page1, page2
133 common /m1eps / eps,eps0,eps1,eps2,eps3,eps4,eps5,plinfy
134 common /m1file/ iread,iprint,isumm
135 parameter ( ntime = 5 )
136 common /m1tim / tlast(ntime), tsum(ntime), numt(ntime), ltime
137 common /m1word/ nwordr,nwordi,nwordh
138 common /m2file/ iback,idump,iload,imps,inewb,insrt,
139 $ ioldb,ipnch,iprob,iscr,isoln,ispecs,ireprt
140 common /m2len / mrows,mcols,melms
141 common /m2lu4 / parmlu(30),luparm(30)
142 common /m2mapz/ maxw,maxz
143 common /m2parm/ dparm(30),iparm(30)
144 common /m3mps3/ aijtol,bstruc(2),mlst,mer,
145 $ aijmin,aijmax,na0,line,ier(20)
146 common /m3mps4/ name(2),mobj(2),mrhs(2),mrng(2),mbnd(2),minmax
147 common /m3scal/ sclobj,scltol,lscale
148 common /m5len / maxr ,maxs ,mbs ,nn ,nn0 ,nr ,nx
149 common /m5freq/ kchk,kinv,ksav,klog,ksumm,i1freq,i2freq,msoln
150 common /m5lobj/ sinf,wtobj,minimz,ninf,iobj,jobj,kobj
151 common /m5log1/ idebug,ierr,lprint
152 logical prnt0 ,prnt1 ,summ0 ,summ1 ,newhed
153 common /m5log4/ prnt0 ,prnt1 ,summ0 ,summ1 ,newhed
154 common /m5lp1 / itn,itnlim,nphs,kmodlu,kmodpi
155 common /m5prc / nparpr,nmulpr,kprc,newsb
156 common /m5step/ featol, tolx0,tolinc,kdegen,ndegen,
157 $ itnfix, nfix(2)
158 common /m5tols/ toldj(3),tolx,tolpiv,tolrow,rowerr,xnorm
159 common /m7len / fobj ,fobj2 ,nnobj ,nnobj0
160 common /m7cg1 / cgbeta,itncg,msgcg,modcg,restrt
161 common /m7cg2 / lcg1,lcg2,lcg3,lcg4,modtcg,nitncg,nsubsp
162 common /m7conv/ etash,etarg,lvltol,nfail,conv(4)
163 common /m7tols/ xtol(2),ftol(2),gtol(2),pinorm,rgnorm,tolrg
164 common /m8len / njac ,nncon ,nncon0,nnjac
165 common /m8al1 / penpar,rowtol,ncom,nden,nlag,nmajor,nminor
166 common /m8al2 / radius,rhsmod,modpen,modrhs
167 common /m8diff/ difint(2),gdummy,lderiv,lvldif,knowng(2)
168 common /m8func/ nfcon(4),nfobj(4),nprob,nstat1,nstat2
169 common /m8veri/ jverif(4),lverif(2)
170 common /cyclcm/ cnvtol,jnew,materr,maxcy,nephnt,nphant,nprint
171
172 intrinsic max, min, sqrt
173
174 parameter (idummy = -11111, rdummy = -11111.0d+0,
175 $ zero = 0.0d+0, one = 1.0d+0)
176
177 logical lincon, linear, nlncon, nonlin, SYSTEM
178
179 character*4 lblank, lmax, lmin, id(6)
180 data lblank /' '/,
181 $ lmax /'Max '/,
182 $ lmin /'Min '/,
183 $ id /'No ', 'Yes ', 'Part',
184 $ 'Full', ' Den', 'Spar'/
185
186 * SYSTEM means that MINOS is being used "behind the scenes"
187 * by some other system such as GAMS or AMPL or ASCEND.
188 * Certain defaults should then be different.
189
190 SYSTEM = GAMS .or. AMPL
191
192 * Set some local machine-dependent constants.
193
194 c3 = max( 1.0d-3, eps4 )
195 c4 = max( 1.0d-4, eps3 )
196 c5 = max( 1.0d-5, eps2 )
197 c6 = max( 1.0d-6, eps2 )
198 c7 = max( 1.0d-7, eps2 )
199
200 * Set the Reduced-Gradient tolerances.
201
202 xtol(1) = 0.1
203 xtol(2) = c6
204 ftol(1) = xtol(1)*0.1
205 ftol(2) = xtol(2)**2
206 gtol(1) = c3
207 gtol(2) = c7
208 gdummy = -111111.0d+0
209
210 if (mode .eq. 1) then
211 * ---------------------------------------------------------------
212 * mode = 1. Set parameters to default or dummy values.
213 *
214 * For some keywords like LAGRANGIAN, the Options file doesn't
215 * allow the user to set illegal values. Sensible defaults can
216 * therefore be set here, and the final values don't need to be
217 * checked later.
218 *
219 * Some of the options with numerical values do need to be checked
220 * and sometimes we need to know if the user set values or not.
221 * Such options are set to dummy values here.
222 * ---------------------------------------------------------------
223 *
224 * Options needed by GAMS.
225 * Things like file numbers have to be initialized.
226 * Genuine options are mostly concerned with solving the problem.
227
228 iback = 0
229 idump = 0
230 iload = 0
231 inewb = 0
232 imps = 0
233 insrt = 0
234 ioldb = 0
235 ipnch = 0
236 iprob = 0
237 ireprt = 0
238 isoln = 0
239
240 idebug = 0
241 itnlim = idummy
242 kchk = idummy
243 kinv = idummy
244 klog = idummy
245 ksav = idummy
246 ksumm = idummy
247 kdegen = idummy
248 lderiv = 3
249 lprint = 0
250 prnt0 = .true.
251 prnt1 = .false.
252 summ0 = .true.
253 summ1 = .false.
254 lscale = idummy
255 ltime = 3
256 lverif(1) = 0
257 lverif(2) = -2
258 maxr = idummy
259 maxs = idummy
260 minimz = 1
261 msoln = 2
262 ncom = idummy
263 nlag = 1
264 nmajor = 50
265 nminor = 40
266 nmulpr = 1
267 nparpr = idummy
268
269 do 60 i = 1, 4
270 jverif(i) = -1
271 60 continue
272
273 * iparm(1) = Crash option
274 * iparm(2) = Linesearch debug -- starting iteration
275 * iparm(3) = Suppress parameters
276 * iparm(4) = Scale print
277 * iparm(5) = Start assigned nonlinears (GAMS only)
278
279 iparm(1) = 3
280 iparm(2) = 9999999
281 iparm(3) = 1
282 iparm(4) = 0
283 iparm(5) = 2
284
285 * dparm(1) = Unbounded objective
286 * dparm(2) = Unbounded step
287 * dparm(3) = Function precision
288 * dparm(4) = Major damping parameter
289 * dparm(5) = Crash tolerance
290 * dparm(6) = Minor damping parameter
291 * dparm(7) = Penalty parameter
292 * dparm(8) = LU swap tolerance
293
294 do 10 i = 1, 8
295 dparm(i) = rdummy
296 10 continue
297
298 difint(1) = rdummy
299 difint(2) = rdummy
300 etarg = rdummy
301 etash = rdummy
302 parmlu(1) = rdummy
303 parmlu(2) = rdummy
304 parmlu(4) = rdummy
305 parmlu(5) = rdummy
306 parmlu(8) = rdummy
307 penpar = rdummy
308 radius = rdummy
309 rowtol = rdummy
310 scltol = rdummy
311 toldj(3) = rdummy
312 tolpiv = rdummy
313 tolrow = c4
314 tolx = rdummy
315 wtobj = rdummy
316
317 * Certain defaults should be different within modeling systems.
318
319 if (SYSTEM) then
320 lverif(1) = -1
321 msoln = 0
322 end if
323
324 * Options not used by GAMS.
325 * These are mostly to do with the MPS file.
326
327 aijtol = 1.0d-10
328 bstruc(1) = zero
329 bstruc(2) = plinfy
330 cnvtol = zero
331
332 i1freq = 0
333 i2freq = 0
334 mrows = 0
335 mcols = 0
336 melms = 0
337 mer = 10
338 mlst = 0
339 modcg = -1
340 modtcg = 1
341 nitncg = 0
342 nden = 1
343 nncon = 0
344 nnjac = 0
345 nnobj = 0
346 nprob = 0
347 maxcy = 1
348 nephnt = 0
349 nphant = 0
350 nprint = 1
351
352 call m3char( lblank, iblank )
353 do 20 i = 1, 2
354 name(i) = iblank
355 mobj(i) = iblank
356 mrhs(i) = iblank
357 mrng(i) = iblank
358 mbnd(i) = iblank
359 20 continue
360
361 else if (mode .eq. 2) then
362 * ---------------------------------------------------------------
363 * mode = 2. Check parameters and assign default values.
364 * ---------------------------------------------------------------
365
366 * Options and variables needed by GAMS.
367
368 if (nncon .eq. 0) nnjac = 0
369 if (nnjac .eq. 0) nncon = 0
370 nn = max( nnjac, nnobj )
371 nncon0 = max( nncon, 1 )
372 lincon = nncon .eq. 0
373 linear = nn .eq. 0
374 nlncon = nncon .gt. 0
375 nonlin = nn .gt. 0
376
377 * Set unspecified frequencies or silly values to defaults.
378
379 if (kchk .eq. idummy) kchk = 60
380 if (kinv .le. 0 ) kinv = 100
381 if (klog .eq. idummy) klog = 100
382 if (ksav .eq. idummy) ksav = 100
383 if (ksumm .eq. idummy) ksumm = 100
384 if (kdegen .eq. idummy) kdegen = 10000
385
386 * Sometimes, frequency 0 means "almost never".
387
388 if (kchk .le. 0) kchk = 99999999
389 if (klog .le. 0) klog = 99999999
390 if (ksav .le. 0) ksav = 99999999
391 if (ksumm .le. 0) ksumm = 99999999
392 if (kdegen .le. 0) kdegen = 99999999
393
394 prnt0 = lprint .eq. 0
395 prnt1 = lprint .gt. 0
396 if (iprint .le. 0) then
397 prnt0 = .false.
398 prnt1 = .false.
399 end if
400 if (isumm .le. 0) then
401 summ0 = .false.
402 summ1 = .false.
403 end if
404
405 * Check Hessian dimension maxr and Superbasics limit maxs.
406
407 if ( nonlin ) then
408 if (maxr .gt. 0 .and. maxs .lt. 0) maxs = maxr
409 if (maxs .gt. 0 .and. maxr .lt. 0) maxr = maxs
410 if (.not. GAMS) then
411 if (maxs .lt. 0) maxs = 50
412 if (maxr .lt. 0) maxr = 50
413 end if
414 end if
415 if (.not. GAMS) then
416 if (maxs .le. 0 ) maxs = 1
417 if (maxr .lt. 0 ) maxr = 0
418 if (maxs .lt. maxr) maxs = maxr
419 end if
420 maxr = min( maxr, maxs )
421
422 * Check other options.
423
424 if (lscale .lt. 0) then
425 lscale = 2
426 if (nonlin) lscale = 1
427 end if
428 if (ncom .lt. 0) then
429 ncom = 1
430 if (nlncon) ncom = 0
431 end if
432 if (nparpr .le. 0) then
433 nparpr = 10
434 if (nonlin) nparpr = 1
435 end if
436
437 * If the Optimality tolerance was not specified, it should not
438 * be smaller than the sqrt of the Function precision.
439
440 if (toldj(3) .le. zero) then
441 toldj(3) = c6
442 if (dparm(3) .gt. zero) toldj(3) = sqrt( dparm(3) )
443 end if
444
445 * See the list of dparms above.
446
447 if (dparm(1) .le. zero) dparm(1) = plinfy
448 if (dparm(2) .le. zero) dparm(2) = 1.0d+10
449 if (dparm(3) .le. zero) dparm(3) = eps0
450 if (dparm(4) .le. zero) dparm(4) = 2.0
451 if (dparm(6) .le. zero) dparm(6) = 2.0
452 if (penpar .lt. zero) penpar = one
453 dparm(7) = penpar
454 if (dparm(8) .le. zero) dparm(8) = eps4
455
456 if (dparm(5) .lt. zero .or. dparm(5) .ge. one) dparm(5)= 0.1
457 if (etarg .le. zero .or. etarg .gt. one) etarg = 0.5
458 if (etash .lt. zero .or. etash .gt. one) etash = 0.1
459
460 if (difint(1).le. zero) difint(1) = sqrt( dparm(3) )
461 if (difint(2).le. zero) difint(2) = dparm(3) ** 0.333333
462 if (parmlu(1).lt. one ) parmlu(1) = 100.0
463 if (parmlu(2).lt. one ) parmlu(2) = 10.0
464 if (parmlu(4).le. zero) parmlu(4) = eps1
465 if (parmlu(5).le. zero) parmlu(5) = eps1
466 if (parmlu(8).le. zero) parmlu(8) = 0.5
467 if (radius .le. eps2) radius = 0.01
468 if (rowtol .le. eps ) rowtol = c6
469 if (scltol .le. zero) scltol = 0.90
470 if (tolpiv .le. zero) tolpiv = eps1
471 if (tolx .le. zero) tolx = c6
472 if (wtobj .lt. zero) wtobj = zero
473
474 * Check the Start and Stop column numbers for gradient checking.
475
476 if (jverif(1) .lt. 0) jverif(1) = 1
477 if (jverif(2) .lt. 0) jverif(2) = nnobj
478 if (jverif(3) .lt. 0) jverif(3) = 1
479 if (jverif(4) .lt. 0) jverif(4) = nnjac
480
481
482 * Options not used by GAMS.
483
484 if (bstruc(1) .gt. bstruc(2)) then
485 t = bstruc(1)
486 bstruc(1) = bstruc(2)
487 bstruc(2) = t
488 end if
489 if (minimz .gt. 0 ) call m3char( lmin, minmax )
490 if (minimz .le. 0 ) call m3char( lmax, minmax )
491 if (iback .eq. inewb ) iback = 0
492 if (mrows .le. 0 ) mrows = 100
493 if (mcols .le. 0 ) mcols = 3*mrows
494 if (melms .le. 0 ) melms = 5*mcols
495 if (itnlim .lt. 0 ) itnlim = 3*mrows + 10*nn
496 maxs = min( maxs, mcols + mrows + 1 )
497
498 else if (mode .eq. 3 .and. iprint .gt. 0) then
499 * ---------------------------------------------------------------
500 * mode = 3. Print the parameters if
501 * Print level > 0 and iparm(3) > 0.
502 * ---------------------------------------------------------------
503 if (prnt1 .and. iparm(3) .gt. 0) then
504 call m1page( 1 )
505 write(iprint, 1000)
506
507 if (SYSTEM) then
508 * relax
509 else
510 write(iprint, 2000) mrows , mlst , bstruc(1),
511 $ mcols , mer , bstruc(2),
512 $ melms , nephnt, aijtol
513 write(iprint, 2100) imps , ioldb , iread ,
514 $ isoln , inewb , iprint,
515 $ insrt , iback , ispecs,
516 $ ipnch , iload , idump
517 end if
518
519 write(iprint, 2200) klog , kchk , ksav ,
520 $ ksumm , kinv , kdegen
521 write(iprint, 2300) lscale , tolx , itnlim ,
522 $ scltol , toldj(3) , nparpr ,
523 $ iparm(1) , tolpiv , nmulpr ,
524 $ dparm(5) , wtobj
525 write(iprint, 2400) nncon , maxr , dparm(3) ,
526 $ nnjac , maxs , difint(1),
527 $ nnobj , etash , difint(2),
528 $ nprob , etarg , lderiv ,
529 $ dparm(1) , dparm(2) , lverif(1)
530 write(iprint, 2450) id(4+nden),nmajor , radius ,
531 $ id(1+nlag),nminor , rowtol ,
532 $ penpar , id(3+ncom),lprint ,
533 $ dparm(4) , dparm(6)
534 write(iprint, 2500) parmlu(1), maxw , idebug ,
535 $ parmlu(2), maxz , iparm(2) ,
536 $ parmlu(4), eps, nwordr,nwordi,nwordh,
537 $ dparm(8) , ltime
538 end if
539 end if
540 return
541
542 1000 format(' Parameters' / ' ----------')
543 2000 format(' MPS INPUT DATA.'
544 $/ ' Row limit..............', i10, 6x,
545 $ ' List limit.............', i10, 6x,
546 $ ' Lower bound default....', 1p, e10.2
547 $/ ' Column limit...........', i10, 6x,
548 $ ' Error message limit....', i10, 6x,
549 $ ' Upper bound default....', e10.2
550 $/ ' Elements limit ........', i10, 6x,
551 $ ' Phantom elements.......', i10, 6x,
552 $ ' Aij tolerance..........', e10.2)
553 2100 format(/ ' FILES.'
554 $/ ' MPS file ..............', i10, 6x,
555 $ ' Old basis file ........', i10, 6x,
556 $ ' (Card reader)..........', i10
557 $/ ' Solution file..........', i10, 6x,
558 $ ' New basis file ........', i10, 6x,
559 $ ' (Printer)..............', i10
560 $/ ' Insert file............', i10, 6x,
561 $ ' Backup basis file......', i10, 6x,
562 $ ' (Specs file)...........', i10
563 $/ ' Punch file.............', i10, 6x,
564 $ ' Load file..............', i10, 6x,
565 $ ' Dump file..............', i10)
566 2200 format(/ ' FREQUENCIES.'
567 $/ ' Log frequency..........', i10, 6x,
568 $ ' Check row error........', i10, 6x,
569 $ ' Save new basis map.....', i10
570 $/ ' Summary frequency......', i10, 6x,
571 $ ' Factorize basis........', i10, 6x,
572 $ ' Expand frequency.......', i10)
573 2300 format(/ ' LP PARAMETERS.'
574 $/ ' Scale option...........', i10, 6x,
575 $ ' Feasibility tolerance..', 1p, e10.2, 6x,
576 $ ' Iteration limit........', i10
577 $/ ' Scale tolerance........', 0p, f10.3, 6x,
578 $ ' Optimality tolerance...', e10.2, 6x,
579 $ ' Partial price.........', i10
580 $/ ' Crash option...........', i10, 6x,
581 $ ' Pivot tolerance........', 1p, e10.2, 6x,
582 $ ' Multiple price.........', i10
583 $/ ' Crash tolerance........', 0p, f10.3, 6x,
584 $ ' Weight on objective....', e10.2)
585 2400 format(/ ' NONLINEAR PROBLEMS.'
586 $/ ' Nonlinear constraints..', i10, 6x,
587 $ ' Hessian dimension......', i10, 6x,
588 $ ' Function precision.....', 1p, e10.2
589 $/ ' Nonlinear Jacobian vars', i10, 6x,
590 $ ' Superbasics limit......', i10, 6x,
591 $ ' Difference interval....', e10.2
592 $/ ' Nonlinear objectiv vars', i10, 6x,
593 $ ' Linesearch tolerance...', 0p, f10.5, 6x,
594 $ ' Central difference int.', 1p, e10.2
595 $/ ' Problem number.........', i10, 6x,
596 $ ' Subspace tolerance.....', 0p, f10.5, 6x,
597 $ ' Derivative level.......', i10
598 $/ ' Unbounded objective val', 1p, e10.2, 6x,
599 $ ' Unbounded step size....', e10.2, 6x,
600 $ ' Verify level...........', i10)
601 2450 format(/ ' AUGMENTED LAGRANGIAN.'
602 $/ ' Jacobian...............', 4x, a4, 'se', 6x,
603 $ ' Major iterations limit.', i10, 6x,
604 $ ' Radius of convergence..', 1p, e10.2
605 $/ ' Lagrangian.............', 7x, a3, 6x,
606 $ ' Minor iterations limit.', i10, 6x,
607 $ ' Row tolerance..........', e10.2
608 $/ ' Penalty parameter......', e10.2, 6x,
609 $ ' Completion.............', 6x, a4, 6x,
610 $ ' Print level..(JFLXB)...', i10
611 $/ ' Major damping parameter', e10.2, 6x,
612 $ ' Minor damping parameter', e10.2)
613 2500 format(/ ' MISCELLANEOUS.'
614 $/ ' LU factor tolerance....', f10.2, 6x,
615 $ ' Workspace (user).......', i10, 6x,
616 $ ' Debug level............', i10
617 $/ ' LU update tolerance....', f10.2, 6x,
618 $ ' Workspace (total)......', i10, 6x,
619 $ ' Linesearch debug after.', i10
620 $/ ' LU singularity tol.....', 1p, e10.2, 6x,
621 $ ' eps (machine precision)', e10.2, 6x,
622 $ ' nwordr, nwordi, nwordh.', 1x, 3i3
623 $/ ' LU swap tolerance......', e10.2, 6x,
624 $ ' Timing level...........', i10)
625
626 * end of m3dflt
627 end
628
629 *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
630
631 subroutine m3key ( buffer, key, lprnt, lsumm, inform )
632
633 implicit double precision (a-h,o-z)
634 character*(*) buffer
635 character*16 key
636
637 ************************************************************************
638 * m3key decodes the option contained in buffer in order to set
639 * a parameter value in the relevant common block.
640 *
641 * The buffer is output to file iprint, minus trailing blanks.
642 * Error messages are output to files iprint and isumm.
643 * buffer is echoed to iprint but normally not to isumm.
644 * It is echoed to isumm before any error msg.
645 *
646 * On entry,
647 * lprnt is iprint as given to opfile.
648 * lsumm is isumm as given to opfile.
649 * inform is the number of errors so far.
650 *
651 * On exit,
652 * key is the first keyword contained in buffer.
653 * inform is the number of errors so far.
654 *
655 * m3key calls opnumb and the subprograms
656 * lookup, scannr, tokens, upcase
657 * (now called oplook, opscan, optokn, opuppr)
658 * supplied by Sterling Software, Palo Alto, California.
659 *
660 * Systems Optimization Laboratory, Stanford University.
661 * 22 Mar 1988: First MINOS version.
662 * 10 Nov 1991: inform added to count errors and allow for no output.
663 ************************************************************************
664
665 parameter (mxparm = 30)
666 logical conv,restrt
667 logical alone, AMPL, GAMS, MINT, page1, page2
668 common /m1env / alone, AMPL, GAMS, MINT, page1, page2
669 common /m1file/ iread,iprint,isumm
670 parameter ( ntime = 5 )
671 common /m1tim / tlast(ntime), tsum(ntime), numt(ntime), ltime
672 common /m2file/ iback,idump,iload,imps,inewb,insrt,
673 $ ioldb,ipnch,iprob,iscr,isoln,ispecs,ireprt
674 common /m2len / mrows,mcols,melms
675 common /m2lu4 / parmlu(30),luparm(30)
676 common /m2mapz/ maxw,maxz
677 common /m2parm/ dparm(30),iparm(30)
678 common /m3mps3/ aijtol,bstruc(2),mlst,mer,
679 $ aijmin,aijmax,na0,line,ier(20)
680 common /m3mps4/ name(2),mobj(2),mrhs(2),mrng(2),mbnd(2),minmax
681 common /m3scal/ sclobj,scltol,lscale
682 common /m5len / maxr ,maxs ,mbs ,nn ,nn0 ,nr ,nx
683 common /m5freq/ kchk,kinv,ksav,klog,ksumm,i1freq,i2freq,msoln
684 common /m5lobj/ sinf,wtobj,minimz,ninf,iobj,jobj,kobj
685 common /m5log1/ idebug,ierr,lprint
686 logical prnt0 ,prnt1 ,summ0 ,summ1 ,newhed
687 common /m5log4/ prnt0 ,prnt1 ,summ0 ,summ1 ,newhed
688 common /m5lp1 / itn,itnlim,nphs,kmodlu,kmodpi
689 common /m5prc / nparpr,nmulpr,kprc,newsb
690 common /m5step/ featol, tolx0,tolinc,kdegen,ndegen,
691 $ itnfix, nfix(2)
692 common /m5tols/ toldj(3),tolx,tolpiv,tolrow,rowerr,xnorm
693 common /m7len / fobj ,fobj2 ,nnobj ,nnobj0
694 common /m7cg1 / cgbeta,itncg,msgcg,modcg,restrt
695 common /m7cg2 / lcg1,lcg2,lcg3,lcg4,modtcg,nitncg,nsubsp
696 common /m7conv/ etash,etarg,lvltol,nfail,conv(4)
697 common /m8len / njac ,nncon ,nncon0,nnjac
698 common /m8al1 / penpar,rowtol,ncom,nden,nlag,nmajor,nminor
699 common /m8al2 / radius,rhsmod,modpen,modrhs
700 common /m8diff/ difint(2),gdummy,lderiv,lvldif,knowng(2)
701 common /m8func/ nfcon(4),nfobj(4),nprob,nstat1,nstat2
702 common /m8veri/ jverif(4),lverif(2)
703 common /cyclcm/ cnvtol,jnew,materr,maxcy,nephnt,nphant,nprint
704 *-----------------------------------------------------------------------
705
706 external opnumb
707 intrinsic abs
708 logical more , number, opnumb, sorted
709
710 parameter ( maxkey = 38, maxtie = 40, maxtok = 10)
711 character*16 keys(maxkey), ties(maxtie), token(maxtok)
712
713 * Next 2 lines not needed by GAMS
714 parameter ( mxmkey = 35)
715 character*16 mkey(mxmkey)
716
717 character*16 key2, k2save, value
718
719 parameter (idummy = -11111, rdummy = -11111.0d+0,
720 $ sorted = .true.,
721 $ maxint = 100000000, zero = 0.0d+0 )
722
723 * maxint above should be larger than any expected integer value.
724
725 * GAMS recognizes the following keywords.
726
727 data keys
728 $ / 'CHECK ', 'COMPLETION ', 'CRASH ',
729 $ 'DEBUG ', 'DEFAULTS ', 'EXPAND ',
730 $ 'FACTORIZATION ', 'FEASIBILITY ', 'HESSIAN ',
731 $ 'IPARM ',
732 $ 'ITERATIONS ', 'ITERS:ITERATIONS', 'ITNS :ITERATIONS',
733 $ 'LAGRANGIAN ', 'LINESEARCH ', 'LOG ',
734 $ 'LU ', 'MAJOR ', 'MINOR ',
735 $ 'MULTIPLE ', 'OPTIMALITY ', 'PARTIAL ',
736 $ 'PENALTY ', 'PIVOT ', 'PRINT ',
737 $ 'RADIUS ', 'ROWS ', 'RPARM ',
738 $ 'SCALE ', 'SOLUTION ', 'START ',
739 $ 'SUBSPACE ', 'SUMMARY ', 'SUPERBASICS ',
740 $ 'TIMING ', 'UNBOUNDED ',
741 $ 'VERIFY ', 'WEIGHT '/
742
743 data ties
744 $ / '(TOTAL) ', '(USER) ',
745 $ 'ALL ', 'BASIC ', 'COLUMNS ',
746 $ 'CONSTRAINTS ', 'DAMPING ', 'DEBUG ',
747 $ 'DENSE ', 'DENSITY ',
748 $ 'ELEMENTS ', 'ELIGIBLE ',
749 $ 'FACTORIZATION ', 'FILE ', 'FREQUENCY ',
750 $ 'FULL ', 'GRADIENTS ',
751 $ 'ITERATIONS ', 'ITERS:ITERATIONS', 'ITNS :ITERATIONS',
752 $ 'JACOBIAN ', 'LEVEL ', 'LIMIT ',
753 $ 'LINEAR ',
754 $ 'NO ', 'NONBASIC ', 'NONLINEAR ',
755 $ 'OBJECTIVE ', 'OPTION ', 'PARTIAL ',
756 $ 'PRINT ', 'SINGULARITY ', 'SPARSE ',
757 $ 'STEP ', 'SUPERBASIC ', 'SWAP ',
758 $ 'TOLERANCE ', 'UPDATE ',
759 $ 'VARIABLES ', 'YES '/
760
761 * More keywords for MINOS --- not needed by GAMS.
762
763 data mkey
764 $ / 'AIJ ', 'BACKUP ', 'BOUNDS ',
765 $ 'CENTRAL ', 'COEFFICIENTS ', 'COLUMNS ',
766 $ 'CYCLE ', 'DERIVATIVE ', 'DIFFERENCE ',
767 $ 'DUMP ', 'ELEMENTS ', 'ERROR ',
768 $ 'FUNCTION ', 'INSERT ', 'JACOBIAN ',
769 $ 'LIST ', 'LOAD ', 'LOWER ',
770 $ 'MAXIMIZE ', 'MINIMIZE ', 'MPS ',
771 $ 'NEW ', 'NONLINEAR ', 'OBJECTIVE ',
772 $ 'OLD ', 'PHANTOM ', 'PROBLEM ',
773 $ 'PUNCH ', 'RANGES ', 'REPORT ',
774 $ 'RHS ', 'SAVE ',
775 $ 'STOP ', 'UPPER ', 'WORKSPACE '/
776 *-----------------------------------------------------------------------
777
778 * iparm(1) = Crash option
779 * iparm(2) = Linesearch debug -- starting iteration
780 * iparm(3) = Suppress parameters
781 * iparm(4) = Scale print
782 * iparm(5) = Start assigned nonlinears
783
784 * dparm(1) = Unbounded objective
785 * dparm(2) = Unbounded step
786 * dparm(3) = Function precision
787 * dparm(4) = Major damping parameter
788 * dparm(5) = Crash tolerance
789 * dparm(6) = Minor damping parameter
790 * dparm(7) = Penalty parameter
791
792 * Set lenbuf = length of buffer without trailing blanks.
793 * Echo to the print file.
794
795 lenbuf = 1
796 do 10 j = 1, len(buffer)
797 if (buffer(j:j) .ne. ' ') lenbuf = j
798 10 continue
799
800 if (lprnt .gt. 0) then
801 write(lprnt, '(6x, a)') buffer(1:lenbuf)
802 end if
803
804 * Set lenb = length of buffer without trailing comments.
805 * Eliminate comments and empty lines.
806 * A '*' appearing anywhere in buffer terminates the string.
807
808 i = index( buffer(1:lenbuf), '*' )
809 if (i .eq. 0) then
810 lenb = lenbuf
811 else
812 lenb = i - 1
813 end if
814 if (lenb .le. 0) then
815 key = '*'
816 go to 900
817 end if
818
819 * ------------------------------------------------------------------
820 * Extract up to maxtok tokens from the record.
821 * ntoken returns how many were actually found.
822 * key, key2, are the first tokens if any, otherwise blank.
823 * For some values of key (BOUNDS, OBJECTIVE, RANGES, RHS)
824 * we have to save key2 before oplook gets a chance to alter it.
825 * For example, if the data is Objective = OBJ
826 * oplook will change obj to objective.
827 * ------------------------------------------------------------------
828 ntoken = maxtok
829 call optokn( buffer(1:lenb), ntoken, token )
830 key = token(1)
831 key2 = token(2)
832 k2save = key2
833
834 * Certain keywords require no action.
835
836 if (key .eq. ' ') go to 900
837 if (key .eq. 'END') go to 900
838
839 * Most keywords will have an associated integer or real value,
840 * so look for it no matter what the keyword.
841
842 i = 1
843 number = .false.
844
845 50 if (i .lt. ntoken .and. .not. number) then
846 i = i + 1
847 value = token(i)
848 number = opnumb( value )
849 go to 50
850 end if
851
852 ivalue = 0
853 rvalue = zero
854 if ( number ) then
855 read (value, '(bn, e16.0)') rvalue
856 if (abs(rvalue) .lt. maxint) ivalue = rvalue
857 end if
858
859 * Convert the keywords to their most fundamental form
860 * (upper case, no abbreviations).
861 * sorted says whether the dictionaries are in alphabetic order.
862 * loci says where the keywords are in the dictionaries.
863 * loci = 0 signals that the keyword wasn't there.
864
865 call oplook( maxkey, keys, sorted, key , loc1 )
866 call oplook( maxtie, ties, sorted, key2, loc2 )
867
868 * ------------------------------------------------------------------
869 * Decide what to do about each keyword.
870 * The second keyword (if any) might be needed to break ties.
871 * Some seemingly redundant testing of more is used
872 * to avoid compiler limits on the number of consecutive else if's.
873 * ------------------------------------------------------------------
874 more = .true.
875 if (more) then
876 more = .false.
877 if (key .eq. 'CHECK ') then
878 kchk = ivalue
879 else if (key .eq. 'COMPLETION ') then
880 if (key2.eq. 'PARTIAL ') ncom = 0
881 if (key2.eq. 'FULL ') ncom = 1
882 if (loc2.eq. 0 ) go to 820
883 else if (key .eq. 'CRASH ') then
884 if (key2.eq. 'OPTION ') iparm(1) = ivalue
885 if (key2.eq. 'TOLERANCE ') dparm(5) = rvalue
886 if (loc2.eq. 0 ) go to 820
887 else if (key .eq. 'DEBUG ') then
888 idebug = ivalue
889 else if (key .eq. 'DEFAULTS ') then
890 call m3dflt( 1 )
891 else if (key .eq. 'EXPAND ') then
892 kdegen = ivalue
893 else if (key .eq. 'FACTORIZATION') then
894 kinv = ivalue
895 else if (key .eq. 'FEASIBILITY ') then
896 tolx = rvalue
897 else if (key .eq. 'HESSIAN ') then
898 maxr = ivalue
899 else
900 more = .true.
901 end if
902 end if
903
904 if (more) then
905 more = .false.
906 if (key .eq. 'IPARM ') then
907 * Allow things like Iparm 21 = 100 to set iparm(21) = 100
908 key2 = token(3)
909 if (ivalue .ge. 1 .and. ivalue .le. mxparm) then
910 read (key2, '(bn, i16)') iparm(ivalue)
911 else
912 go to 880
913 end if
914 else if (key .eq. 'ITERATIONS ') then
915 itnlim = ivalue
916 else if (key .eq. 'LAGRANGIAN ') then
917 if (key2.eq. 'YES ') nlag = 1
918 if (key2.eq. 'NO ') nlag = 0
919 if (loc2.eq. 0 ) go to 820
920 else if (key .eq. 'LINESEARCH ') then
921 if (key2.eq. 'TOLERANCE ') etash = rvalue
922 if (key2.eq. 'DEBUG ') iparm(2) = ivalue
923 if (loc2.eq. 0 ) go to 820
924 else if (key .eq. 'LOG ') then
925 klog = ivalue
926 else if (key .eq. 'LU ') then
927 if (key2.eq. 'FACTORIZATION')parmlu(1) = rvalue
928 if (key2.eq. 'UPDATE ') parmlu(2) = rvalue
929 if (key2.eq. 'DENSITY ') parmlu(8) = rvalue
930 if (key2.eq. 'SINGULARITY ') then
931 parmlu(4) = rvalue
932 parmlu(5) = rvalue
933 end if
934 if (key2.eq. 'SWAP ') dparm(8) = rvalue
935 if (loc2.eq. 0 ) go to 820
936 else
937 more = .true.
938 end if
939 end if
940
941 if (more) then
942 more = .false.
943 if (key .eq. 'MAJOR ') then
944 if (key2.eq. 'DAMPING ') dparm(4) = rvalue
945 if (key2.eq. 'ITERATIONS ') nmajor = ivalue
946 if (loc2.eq. 0 ) go to 820
947 else if (key .eq. 'MINOR ') then
948 if (key2.eq. 'DAMPING ') dparm(6) = rvalue
949 if (key2.eq. 'ITERATIONS ') nminor = ivalue
950 if (loc2.eq. 0 ) go to 820
951 else if (key .eq. 'MULTIPLE ') then
952 nmulpr = ivalue
953 else if (key .eq. 'OPTIMALITY ') then
954 toldj(3) = rvalue
955 else if (key .eq. 'PARTIAL ') then
956 nparpr = ivalue
957 else if (key .eq. 'PENALTY ') then
958 dparm(7) = rvalue
959 penpar = rvalue
960 else if (key .eq. 'PIVOT ') then
961 tolpiv = rvalue
962 else if (key .eq. 'PRINT ') then
963 if (key2.eq. 'FILE ') iprint = ivalue
964 if (key2.eq. 'FREQUENCY ') klog = ivalue
965 if (key2.eq. 'LEVEL ') then
966 lprint = ivalue
967 end if
968 if (loc2.eq. 0 ) go to 820
969 else
970 more = .true.
971 end if
972 end if
973
974 if (more) then
975 more = .false.
976 if (key .eq. 'RADIUS ') then
977 radius = rvalue
978 else if (key .eq. 'ROWS ') then
979 * GAMS and AMPL should recognize Row tolerance
980 * but not just Rows
981 if (key2.eq. 'TOLERANCE ') then
982 rowtol = rvalue
983 else
984 if ( .not. (GAMS .or. AMPL) ) mrows = ivalue
985 end if
986 else if (key .eq. 'RPARM ') then
987 * Allow things like Rparm 21 = 2 to set dparm(21) = 2.0
988 key2 = token(3)
989 if (ivalue .ge. 1 .and. ivalue .le. mxparm) then
990 read (key2, '(bn, e16.0)') dparm(ivalue)
991 else
992 go to 880
993 end if
994 else
995 more = .true.
996 end if
997 end if
998
999 if (more) then
1000 more = .false.
1001 if (key .eq. 'SCALE ') then
1002 if (key2.eq. 'OPTION ') then
1003 lscale = ivalue
1004 else
1005 if (rvalue .gt. zero ) scltol = rvalue
1006 if (key2.eq. 'PRINT ') iparm(4) = 1
1007 if (key2.eq. 'ALL ') lscale = 2
1008 if (key2.eq. 'NONLINEAR ') lscale = 2
1009 if (key2.eq. 'LINEAR ') lscale = 1
1010 if (key2.eq. 'NO ') lscale = 0
1011 if (key2.eq. 'YES ') lscale = -1
1012 if (key2.eq. ' ') lscale = -1
1013 if (key2.eq. ' ') loc2 = 1
1014 if (loc2.eq. 0 ) go to 820
1015 end if
1016 else
1017 more = .true.
1018 end if
1019 end if
1020
1021 if (more) then
1022 more = .false.
1023 if (key .eq. 'SOLUTION ') then
1024 if (key2.eq. 'YES ') msoln = 2
1025 if (key2.eq. 'NO ') msoln = 0
1026 if (key2.eq. 'FILE ') isoln = ivalue
1027 if (loc2.eq. 0 ) go to 820
1028 else if (key .eq. 'START ') then
1029 key2 = token(4)
1030 call oplook( maxtie, ties, sorted, key2, loc2 )
1031 if (key2.eq. 'SUPERBASIC ') iparm(5) = 2
1032 if (key2.eq. 'BASIC ') iparm(5) = 3
1033 if (key2.eq. 'NONBASIC ') iparm(5) = 4
1034 if (key2.eq. 'ELIGIBLE ') iparm(5) = 1
1035 if (key2.eq. 'OBJECTIVE ') jverif(1) = ivalue
1036 if (key2.eq. 'CONSTRAINTS ') jverif(3) = ivalue
1037 if (loc2.eq. 0 ) go to 840
1038 else
1039 more = .true.
1040 end if
1041 end if
1042
1043 if (more) then
1044 more = .false.
1045 if (key .eq. 'SUBSPACE ') then
1046 etarg = rvalue
1047 else if (key .eq. 'SUPERBASICS ') then
1048 maxs = ivalue
1049 else if (key .eq. 'SUMMARY ') then
1050 if (key2.eq. 'FILE ') isumm = ivalue
1051 if (key2.eq. 'FREQUENCY ') ksumm = ivalue
1052 if (key2.eq. 'LEVEL ') then
1053 summ0 = ivalue .eq. 0
1054 summ1 = ivalue .gt. 0
1055 end if
1056 if (loc2.eq. 0 ) go to 820
1057 else if (key .eq. 'TIMING ') then
1058 ltime = ivalue
1059 else if (key .eq. 'UNBOUNDED ') then
1060 if (key2.eq. 'OBJECTIVE ') dparm(1) = rvalue
1061 if (key2.eq. 'STEP ') dparm(2) = rvalue
1062 if (loc2.eq. 0 ) go to 820
1063 else if (key .eq. 'VERIFY ') then
1064 if (key2.eq. 'OBJECTIVE ') lverif(1) = 1
1065 if (key2.eq. 'CONSTRAINTS ') lverif(1) = 2
1066 if (key2.eq. 'GRADIENTS ') lverif(1) = 3
1067 if (key2.eq. 'YES ') lverif(1) = 3
1068 if (key2.eq. 'NO ') lverif(1) = 0
1069 if (key2.eq. 'LEVEL ') lverif(1) = ivalue
1070 if (key2.eq. ' ') lverif(1) = 3
1071 if (key2.eq. ' ') loc2 = 1
1072 if (loc2.eq. 0 ) go to 820
1073 else if (key .eq. 'WEIGHT ') then
1074 wtobj = rvalue
1075 else
1076 more = .true.
1077 end if
1078 end if
1079
1080 if (.not. more) go to 900
1081 if ( GAMS) go to 800
1082
1083 * ------------------------------------------------------------------
1084 * The following keywords are not recognized by GAMS.
1085 * ------------------------------------------------------------------
1086 call oplook( mxmkey, mkey, sorted, key , loc1 )
1087
1088 if (more) then
1089 more = .false.
1090 if (key .eq. 'AIJ ') then
1091 aijtol = rvalue
1092 else if (key .eq. 'BACKUP ') then
1093 iback = ivalue
1094 else if (key .eq. 'BOUNDS ') then
1095 call m3char( k2save(1:4), mbnd(1) )
1096 call m3char( k2save(5:8), mbnd(2) )
1097 else if (key .eq. 'CENTRAL ') then
1098 difint(2) = rvalue
1099 else if (key .eq. 'COEFFICIENTS') then
1100 melms = ivalue
1101 else if (key .eq. 'COLUMNS ') then
1102 mcols = ivalue
1103 else if (key .eq. 'CYCLE ') then
1104 if (key2.eq. 'LIMIT ') maxcy = ivalue
1105 if (key2.eq. 'PRINT ') nprint = ivalue
1106 if (key2.eq. 'TOLERANCE ') cnvtol = rvalue
1107 if (loc2.eq. 0 ) go to 820
1108 else if (key .eq. 'DERIVATIVE ') then
1109 lderiv = ivalue
1110 else
1111 more = .true.
1112 end if
1113 end if
1114
1115 if (more) then
1116 more = .false.
1117 if (key .eq. 'DIFFERENCE ') then
1118 difint(1) = rvalue
1119 else if (key .eq. 'DUMP ') then
1120 idump = ivalue
1121 else if (key .eq. 'ELEMENTS ') then
1122 melms = ivalue
1123 else if (key .eq. 'ERROR ') then
1124 mer = ivalue
1125 else if (key .eq. 'FUNCTION ') then
1126 dparm(3) = rvalue
1127 else if (key .eq. 'INSERT ') then
1128 insrt = ivalue
1129 else if (key .eq. 'JACOBIAN ') then
1130 if (key2.eq. 'DENSE ') nden = 1
1131 if (key2.eq. 'SPARSE ') nden = 2
1132 if (loc2.eq. 0 ) go to 820
1133 else if (key .eq. 'LIST ') then
1134 mlst = ivalue
1135 else if (key .eq. 'LOAD ') then
1136 iload = ivalue
1137 else if (key .eq. 'LOWER ') then
1138 bstruc(1) = rvalue
1139 else if (key .eq. 'MAXIMIZE ') then
1140 minimz = -1
1141 else if (key .eq. 'MINIMIZE ') then
1142 minimz = 1
1143 else if (key .eq. 'MPS ') then
1144 imps = ivalue
1145 else
1146 more = .true.
1147 end if
1148 end if
1149
1150 if (more) then
1151 more = .false.
1152 if (key .eq. 'NEW ') then
1153 inewb = ivalue
1154 else if (key .eq. 'NONLINEAR ') then
1155 if (key2.eq. 'CONSTRAINTS ') nncon = ivalue
1156 if (key2.eq. 'OBJECTIVE ') nnobj = ivalue
1157 if (key2.eq. 'JACOBIAN ') nnjac = ivalue
1158 if (key2.eq. 'VARIABLES ') then
1159 nnobj = ivalue
1160 nnjac = ivalue
1161 end if
1162 if (loc2.eq. 0 ) go to 820
1163 else if (key .eq. 'OBJECTIVE ') then
1164 call m3char( k2save(1:4), mobj(1) )
1165 call m3char( k2save(5:8), mobj(2) )
1166 else if (key .eq. 'OLD ') then
1167 ioldb = ivalue
1168 else if (key .eq. 'PHANTOM ') then
1169 if (key2.eq. 'COLUMNS ') nphant = ivalue
1170 if (key2.eq. 'ELEMENTS ') nephnt = ivalue
1171 if (loc2.eq. 0 ) go to 820
1172 else if (key .eq. 'PROBLEM ') then
1173 if (key2.eq. 'FILE ') ifile = ivalue
1174 if (key2.ne. 'FILE ') nprob = ivalue
1175 else if (key .eq. 'PUNCH ') then
1176 ipnch = ivalue
1177 else if (key .eq. 'RANGES ') then
1178 call m3char( k2save(1:4), mrng(1) )
1179 call m3char( k2save(5:8), mrng(2) )
1180 else if (key .eq. 'REPORT ') then
1181 ireprt = ivalue
1182 else if (key .eq. 'RHS ') then
1183 call m3char( k2save(1:4), mrhs(1) )
1184 call m3char( k2save(5:8), mrhs(2) )
1185 else
1186 more = .true.
1187 end if
1188 end if
1189
1190 if (more) then
1191 more = .false.
1192 if (key .eq. 'SAVE ') then
1193 ksav = ivalue
1194 else if (key .eq. 'STOP ') then
1195 if (key2.eq. 'OBJECTIVE ') jverif(2) = ivalue
1196 if (key2.eq. 'CONSTRAINTS ') jverif(4) = ivalue
1197 if (loc2.eq. 0 ) go to 820
1198 else if (key .eq. 'UPPER ') then
1199 bstruc(2) = rvalue
1200 else if (key .eq. 'WORKSPACE ') then
1201 if (key2.eq. '(USER) ') maxw = ivalue
1202 if (key2.eq. '(TOTAL) ') maxz = ivalue
1203 if (loc2.eq. 0 ) go to 820
1204 else
1205 more = .true.
1206 end if
1207 end if
1208
1209 if (.not. more) go to 900
1210
1211 * ------------------------------------------------------------------
1212 * Error messages.
1213 * ------------------------------------------------------------------
1214 800 inform = inform + 1
1215 if (lprnt .gt. 0) then
1216 write (lprnt, 2300) key
1217 end if
1218 if (lsumm .gt. 0) then
1219 write (lsumm, '(1x, a )') buffer
1220 write (lsumm, 2300) key
1221 end if
1222 return
1223
1224 820 inform = inform + 1
1225 if (lprnt .gt. 0) then
1226 write (lprnt, 2320) key2
1227 end if
1228 if (lsumm .gt. 0) then
1229 write (lsumm, '(1x, a )') buffer
1230 write (lsumm, 2320) key2
1231 end if
1232 return
1233
1234 840 inform = inform + 1
1235 if (lprnt .gt. 0) then
1236 write (lprnt, 2340) key2
1237 end if
1238 if (lsumm .gt. 0) then
1239 write (lsumm, '(1x, a )') buffer
1240 write (lsumm, 2340) key2
1241 end if
1242 return
1243
1244 880 inform = inform + 1
1245 if (lprnt .gt. 0) then
1246 write (lprnt, 2380) ivalue
1247 end if
1248 if (lsumm .gt. 0) then
1249 write (lsumm, '(1x, a )') buffer
1250 write (lsumm, 2380) ivalue
1251 end if
1252
1253 900 return
1254
1255 2300 format(' XXX Keyword not recognized: ', a)
1256 2320 format(' XXX Second keyword not recognized: ', a)
1257 *2330 format(' XXX Third keyword not recognized: ', a)
1258 2340 format(' XXX Fourth keyword not recognized: ', a)
1259 2380 format(' XXX The parm subscript is out of range:', i10)
1260
1261 * end of m3key
1262 end
1263
1264 *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1265
1266 subroutine opfile( ncalls, ioptns, opkey,
1267 $ title , iprint, isumm, inform )
1268
1269 integer ncalls, ioptns, iprint, isumm, inform
1270 character*(*) title
1271 external opkey
1272
1273 ************************************************************************
1274 * opfile reads the options file from unit ioptns and loads the
1275 * relevant options, using opkey to process each line.
1276 *
1277 * On exit, inform says how many errors were encountered.
1278 *
1279 * Systems Optimization Laboratory, Stanford University.
1280 * 18-Dec-1985: Original version.
1281 * 20-Mar-1988: First MINOS version -- title added, prnt deleted.
1282 * 10 Nov 1991: Provision made for no output to iprint and isumm.
1283 * 11 Nov 1991: opfile now calls m3dflt( 1 ) to initialize options
1284 * only after an Options file has been found.
1285 ************************************************************************
1286
1287 character*16 key , token(1)
1288 character*72 buffer
1289 character*30 dashes
1290 data dashes /'=============================='/
1291
1292 * lprnt and lsumm and local copies of iprint and isumm
1293 * (which might get changed by m3key).
1294
1295 lprnt = iprint
1296 lsumm = isumm
1297 inform = 0
1298
1299 * Return if the unit number is out of range.
1300
1301 if (ioptns .lt. 0 .or. ioptns .gt. 99) then
1302 inform = 1
1303 return
1304 end if
1305
1306 * ------------------------------------------------------------------
1307 * Look for Begin, Endrun or Skip.
1308 * ------------------------------------------------------------------
1309 nread = 0
1310 50 read (ioptns, '(a72)', end = 930) buffer
1311 nread = nread + 1
1312 nkey = 1
1313 call optokn( buffer, nkey, token )
1314 key = token(1)
1315 if (key .eq. 'ENDRUN') go to 940
1316 if (key .ne. 'BEGIN' ) then
1317 if (nread .eq. 1 .and. key .ne. 'SKIP') then
1318 inform = inform + 1
1319 if (lprnt .gt. 0) write (lprnt, 2000) ioptns, buffer
1320 if (lsumm .gt. 0) write (lsumm, 2000) ioptns, buffer
1321 end if
1322 go to 50
1323 end if
1324
1325 * ------------------------------------------------------------------
1326 * BEGIN found.
1327 * This is taken to be the first line of an OPTIONS file.
1328 * It is printed without the trailing blanks.
1329 * ------------------------------------------------------------------
1330 call m1page(1)
1331 do 10 j = 1, len(buffer)
1332 if (buffer(j:j) .ne. ' ') lenbuf = j
1333 10 continue
1334
1335 if (lprnt .gt. 0) then
1336 write (lprnt, '( 9x, a)') ' ', dashes, title, dashes
1337 write (lprnt, '(/ 6x, a)') buffer(1:lenbuf)
1338 end if
1339 if (lsumm .gt. 0) then
1340 write (lsumm, '( 1x, a)') ' ', dashes, title, dashes
1341 write (lsumm, '(/ 1x, a)') buffer(1:lenbuf)
1342 end if
1343
1344 * Set options to default values.
1345
1346 call m3dflt( 1 )
1347
1348 * ------------------------------------------------------------------
1349 * Read the rest of the file.
1350 * ------------------------------------------------------------------
1351 *+ while (key .ne. 'END') loop
1352 100 if (key .ne. 'END') then
1353 read (ioptns, '(a72)', end = 920) buffer
1354 call opkey ( buffer, key, lprnt, lsumm, inform )
1355 go to 100
1356 end if
1357 *+ end while
1358
1359 return
1360
1361 920 if (lprnt .gt. 0) write (lprnt, 2200) ioptns
1362 if (lsumm .gt. 0) write (lsumm, 2200) ioptns
1363 inform = 2
1364 return
1365
1366 930 if (ncalls .le. 1) then
1367 if (lprnt .gt. 0) write (lprnt, 2300) ioptns
1368 if (lsumm .gt. 0) write (lsumm, 2300) ioptns
1369 else
1370 if (lprnt .gt. 0) write (lprnt, '(a)') ' Endrun'
1371 if (lsumm .gt. 0) write (lsumm, '(a)') ' Endrun'
1372 end if
1373 inform = 3
1374 return
1375
1376 940 if (lprnt .gt. 0) write (lprnt, '(/ 6x, a)') buffer
1377 if (lsumm .gt. 0) write (lsumm, '(/ 1x, a)') buffer
1378 inform = 4
1379 return
1380
1381 2000 format(
1382 $ //' XXX Error while looking for an OPTIONS file on unit', I7
1383 $ / ' XXX The file should start with Begin, Skip or Endrun'
1384 $ / ' XXX but the first record found was the following:'
1385 $ //' ---->', a
1386 $ //' XXX Continuing to look for OPTIONS file...')
1387 2200 format(//' XXX End-of-file encountered while processing',
1388 $ ' an OPTIONS file on unit', I6)
1389 2300 format(//' XXX End-of-file encountered while looking for',
1390 $ ' an OPTIONS file on unit', I6)
1391
1392 * end of opfile
1393 end
1394
1395 *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1396 C
1397 SUBROUTINE OPLOOK (NDICT, DICTRY, ALPHA, KEY, ENTRY)
1398 C
1399 C
1400 C Description and usage:
1401 C
1402 C Performs dictionary lookups. A pointer is returned if a
1403 C match is found between the input key and the corresponding
1404 C initial characters of one of the elements of the dictionary.
1405 C If a "synonym" has been provided for an entry, the search is
1406 C continued until a match to a primary dictionary entry is found.
1407 C Cases of no match, or multiple matches, are also provided for.
1408 C
1409 C Dictionary entries must be left-justified, and may be alphabetized
1410 C for faster searches. Secondary entries, if any, are composed of
1411 C two words separated by one or more characters such as blank, tab,
1412 C comma, colon, or equal sign which are treated as non-significant
1413 C by OPSCAN. The first entry of each such pair serves as a synonym
1414 C for the second, more fundamental keyword.
1415 C
1416 C The ordered search stops after the section of the dictionary
1417 C having the same first letters as the key has been checked, or
1418 C after a specified number of entries have been examined. A special
1419 C dictionary entry, the vertical bar '|', will also terminate the
1420 C search. This will speed things up if an appropriate dictionary
1421 C length parameter cannot be determined. Both types of search are
1422 C sequential. See "Notes" below for some suggestions if efficiency
1423 C is an issue.
1424 C
1425 C
1426 C Parameters:
1427 C
1428 C Name Dimension Type I/O/S Description
1429 C NDICT I I Number of dictionary entries to be
1430 C examined.
1431 C DICTRY NDICT C I Array of dictionary entries,
1432 C left-justified in their fields.
1433 C May be alphabetized for efficiency,
1434 C in which case ALPHA should be
1435 C .TRUE. Entries with synonyms are
1436 C of the form
1437 C 'ENTRY : SYNONYM', where 'SYNONYM'
1438 C is a more fundamental entry in the
1439 C same dictionary. NOTE: Don't build
1440 C "circular" dictionaries!
1441 C ALPHA L I Indicates whether the dictionary
1442 C is in alphabetical order, in which
1443 C case the search can be terminated
1444 C sooner.
1445 C KEY C I/O String to be compared against the
1446 C dictionary. Abbreviations are OK
1447 C if they correspond to a unique
1448 C entry in the dictionary. KEY is
1449 C replaced on termination by its most
1450 C fundamental equivalent dictionary
1451 C entry (uppercase, left-justified)
1452 C if a match was found.
1453 C ENTRY I O Dictionary pointer. If > 0, it
1454 C indicates which entry matched KEY.
1455 C In case of trouble, a negative
1456 C value means that a UNIQUE match
1457 C was not found - the absolute value
1458 C of ENTRY points to the second
1459 C dictionary entry that matched KEY.
1460 C Zero means that NO match could be
1461 C found. ENTRY always refers to the
1462 C last search performed -
1463 C in searching a chain of synonyms,
1464 C a non-positive value will be
1465 C returned if there is any break,
1466 C even if the original input key
1467 C was found.
1468 C
1469 C
1470 C External references:
1471 C
1472 C Name Description
1473 C OPSCAN Finds first and last significant characters.
1474 C
1475 C
1476 C Environment: Digital VAX-11/780 VMS FORTRAN (FORTRAN 77).
1477 C Appears to satisfy the ANSI Fortran 77 standard.
1478 C
1479 C
1480 C Notes:
1481 C
1482 C (1) IMPLICIT NONE is non-standard. (Has been commented out.)
1483 C
1484 C (2) We have assumed that the dictionary is not too big. If
1485 C many searches are to be done or if the dictionary has more
1486 C than a dozen or so entries, it may be advantageous to build
1487 C an index array of pointers to the beginning of the section
1488 C of the dictionary containing each letter, then pass in the
1489 C portion of the dictionary beginning with DICTRY (INDEX).
1490 C (This won't generally work for dictionaries with synonyms.)
1491 C For very large problems, a completely different approach may
1492 C be advisable, e.g. a binary search for ordered dictionaries.
1493 C
1494 C (3) OPLOOK is case sensitive. In most applications it will be
1495 C necessary to use an uppercase dictionary, and to convert the
1496 C input key to uppercase before calling OPLOOK. Companion
1497 C routines OPTOKN and PAIRS, available from the author, already
1498 C take care of this.
1499 C
1500 C (4) The key need not be left-justified. Any leading (or
1501 C trailing) characters which are "non-significant" to OPSCAN
1502 C will be ignored. These include blanks, horizontal tabs,
1503 C commas, colons, and equal signs. See OPSCAN for details.
1504 C
1505 C (5) The ASCII collating sequence for character data is assumed.
1506 C (N.B. This means the numerals precede the alphabet, unlike
1507 C common practice!) This should not cause trouble on EBCDIC
1508 C machines if DICTRY just contains alphabetic keywords.
1509 C Otherwise it may be necessary to use the FORTRAN lexical
1510 C library routines to force use of the ASCII sequence.
1511 C
1512 C (6) Parameter NUMSIG sets a limit on the length of significant
1513 C dictionary entries. Special applications may require that
1514 C this be increased. (It is 16 in the present version.)
1515 C
1516 C (7) No protection against "circular" dictionaries is provided:
1517 C don't claim that A is B, and that B is A. All synonym chains
1518 C must terminate! Other potential errors not checked for
1519 C include duplicate or mis-ordered entries.
1520 C
1521 C (8) The handling of ambiguities introduces some ambiguity:
1522 C
1523 C ALPHA = .TRUE. A potential problem, when one entry
1524 C looks like an abbreviation for another
1525 C (eg. does 'A' match 'A' or 'AB'?) was
1526 C resolved by dropping out of the search
1527 C immediately when an "exact" match is found.
1528 C
1529 C ALPHA = .FALSE. The programmer must ensure that the above
1530 C situation does not arise: each dictionary
1531 C entry must be recognizable, at least when
1532 C specified to full length. Otherwise, the
1533 C result of a search will depend on the
1534 C order of entries.
1535 C
1536 C
1537 C Author: Robert Kennelly, Informatics General Corporation.
1538 C
1539 C
1540 C Development history:
1541 C
1542 C 24 Feb. 1984 RAK/DAS Initial design and coding.
1543 C 25 Feb. 1984 RAK Combined the two searches by suitable
1544 C choice of terminator FLAG.
1545 C 28 Feb. 1984 RAK Optional synonyms in dictionary, no
1546 C longer update KEY.
1547 C 29 Mar. 1984 RAK Put back replacement of KEY by its
1548 C corresponding entry.
1549 C 21 June 1984 RAK Corrected bug in error handling for cases
1550 C where no match was found.
1551 C 23 Apr. 1985 RAK Introduced test for exact matches, which
1552 C permits use of dictionary entries which
1553 C would appear to be ambiguous (for ordered
1554 C case). Return -I to point to the entry
1555 C which appeared ambiguous (had been -1).
1556 C Repaired loop termination - had to use
1557 C equal length strings or risk quitting too
1558 C soon when one entry is an abbreviation
1559 C for another. Eliminated HIT, reduced
1560 C NUMSIG to 16.
1561 C 15 Nov. 1985 MAS Loop 20 now tests .LT. FLAG, not .LE. FLAG.
1562 C If ALPHA is false, FLAG is now '|', not '{'.
1563 C 26 Jan. 1986 PEG Declaration of FLAG and TARGET modified to
1564 C conform to ANSI-77 standard.
1565 C-----------------------------------------------------------------------
1566
1567
1568 C Variable declarations.
1569 C ----------------------
1570
1571 * IMPLICIT NONE
1572
1573 C Parameters.
1574
1575 INTEGER
1576 $ NUMSIG
1577 CHARACTER
1578 $ BLANK, VBAR
1579 PARAMETER
1580 $ (BLANK = ' ', VBAR = '|', NUMSIG = 16)
1581
1582 C Variables.
1583
1584 LOGICAL
1585 $ ALPHA
1586 INTEGER
1587 $ ENTRY, FIRST, I, LAST, LENGTH, MARK, NDICT
1588 * CHARACTER
1589 * $ DICTRY (NDICT) * (*), FLAG * (NUMSIG),
1590 * $ KEY * (*), TARGET * (NUMSIG)
1591 CHARACTER
1592 $ DICTRY (NDICT) * (*), FLAG * 16,
1593 $ KEY * (*), TARGET * 16
1594
1595 C Procedures.
1596
1597 EXTERNAL
1598 $ OPSCAN
1599
1600
1601 C Executable statements.
1602 C ----------------------
1603
1604 ENTRY = 0
1605
1606 C Isolate the significant portion of the input key (if any).
1607
1608 FIRST = 1
1609 LAST = MIN( LEN(KEY), NUMSIG )
1610 CALL OPSCAN (KEY, FIRST, LAST, MARK)
1611
1612 IF (MARK .GT. 0) THEN
1613 TARGET = KEY (FIRST:MARK)
1614
1615 C Look up TARGET in the dictionary.
1616
1617 10 CONTINUE
1618 LENGTH = MARK - FIRST + 1
1619
1620 C Select search strategy by cunning choice of termination test
1621 C flag. The vertical bar is just about last in both the
1622 C ASCII and EBCDIC collating sequences.
1623
1624 IF (ALPHA) THEN
1625 FLAG = TARGET
1626 ELSE
1627 FLAG = VBAR
1628 END IF
1629
1630
1631 C Perform search.
1632 C ---------------
1633
1634 I = 0
1635 20 CONTINUE
1636 I = I + 1
1637 IF (TARGET (1:LENGTH) .EQ. DICTRY (I) (1:LENGTH)) THEN
1638 IF (ENTRY .EQ. 0) THEN
1639
1640 C First "hit" - must still guard against ambiguities
1641 C by searching until we've gone beyond the key
1642 C (ordered dictionary) or until the end-of-dictionary
1643 C mark is reached (exhaustive search).
1644
1645 ENTRY = I
1646
1647 C Special handling if match is exact - terminate
1648 C search. We thus avoid confusion if one dictionary
1649 C entry looks like an abbreviation of another.
1650 C This fix won't generally work for un-ordered
1651 C dictionaries!
1652
1653 FIRST = 1
1654 LAST = NUMSIG
1655 CALL OPSCAN (DICTRY (ENTRY), FIRST, LAST, MARK)
1656 IF (MARK .EQ. LENGTH) I = NDICT
1657 ELSE
1658
1659
1660 C Oops - two hits! Abnormal termination.
1661 C ---------------------------------------
1662
1663 ENTRY = -I
1664 RETURN
1665 END IF
1666 END IF
1667
1668 C Check whether we've gone past the appropriate section of the
1669 C dictionary. The test on the index provides insurance and an
1670 C optional means for limiting the extent of the search.
1671
1672 IF (DICTRY (I) (1:LENGTH) .LT. FLAG .AND. I .LT. NDICT)
1673 $ GO TO 20
1674
1675
1676 C Check for a synonym.
1677 C --------------------
1678
1679 IF (ENTRY .GT. 0) THEN
1680
1681 C Look for a second entry "behind" the first entry. FIRST
1682 C and MARK were determined above when the hit was detected.
1683
1684 FIRST = MARK + 2
1685 CALL OPSCAN (DICTRY (ENTRY), FIRST, LAST, MARK)
1686 IF (MARK .GT. 0) THEN
1687
1688 C Re-set target and dictionary pointer, then repeat the
1689 C search for the synonym instead of the original key.
1690
1691 TARGET = DICTRY (ENTRY) (FIRST:MARK)
1692 ENTRY = 0
1693 GO TO 10
1694
1695 END IF
1696 END IF
1697
1698 END IF
1699 IF (ENTRY .GT. 0) KEY = DICTRY (ENTRY)
1700
1701
1702 C Normal termination.
1703 C -------------------
1704
1705 RETURN
1706
1707 C End of OPLOOK
1708 END
1709 *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1710
1711 FUNCTION OPNUMB( STRING )
1712
1713 LOGICAL OPNUMB
1714 CHARACTER*(*) STRING
1715
1716 ************************************************************************
1717 * Description and usage:
1718 *
1719 * A simple(-minded) test for numeric data is implemented by
1720 * searching an input string for legitimate characters:
1721 * digits 0 to 9, D, E, -, + and .
1722 * Insurance is provided by requiring that a numeric string
1723 * have at least one digit, at most one D, E or .
1724 * and at most two -s or +s. Note that a few ambiguities remain:
1725 *
1726 * (a) A string might have the form of numeric data but be
1727 * intended as text. No general test can hope to detect
1728 * such cases.
1729 *
1730 * (b) There is no check for correctness of the data format.
1731 * For example a meaningless string such as 'E1.+2-'
1732 * will be accepted as numeric.
1733 *
1734 * Despite these weaknesses, the method should work in the
1735 * majority of cases.
1736 *
1737 *
1738 * Parameters:
1739 *
1740 * Name Dimension Type I/O/S Description
1741 * OPNUMB L O Set .TRUE. if STRING appears
1742 * to be numerical data.
1743 * STRING C I Input data to be tested.
1744 *
1745 *
1746 * Environment: ANSI FORTRAN 77.
1747 *
1748 *
1749 * Notes:
1750 *
1751 * (1) It is assumed that STRING is a token extracted by
1752 * OPTOKN, which will have converted any lower-case
1753 * characters to upper-case.
1754 *
1755 * (2) OPTOKN pads STRING with blanks, so that a genuine
1756 * number is of the form '1234 '.
1757 * Hence, the scan of STRING stops at the first blank.
1758 *
1759 * (3) COMPLEX data with parentheses will not look numeric.
1760 *
1761 *
1762 * Systems Optimization Laboratory, Stanford University.
1763 * 12 Nov 1985 Initial design and coding, starting from the
1764 * routine ALPHA from Informatics General, Inc.
1765 ************************************************************************
1766
1767 LOGICAL NUMBER
1768 INTEGER J, LENGTH, NDIGIT, NEXP, NMINUS, NPLUS, NPOINT
1769 CHARACTER*1 ATOM
1770
1771 NDIGIT = 0
1772 NEXP = 0
1773 NMINUS = 0
1774 NPLUS = 0
1775 NPOINT = 0
1776 NUMBER = .TRUE.
1777 LENGTH = LEN (STRING)
1778 J = 0
1779
1780 10 J = J + 1
1781 ATOM = STRING (J:J)
1782 IF (ATOM .GE. '0' .AND. ATOM .LE. '9') THEN
1783 NDIGIT = NDIGIT + 1
1784 ELSE IF (ATOM .EQ. 'D' .OR. ATOM .EQ. 'E') THEN
1785 NEXP = NEXP + 1
1786 ELSE IF (ATOM .EQ. '-') THEN
1787 NMINUS = NMINUS + 1
1788 ELSE IF (ATOM .EQ. '+') THEN
1789 NPLUS = NPLUS + 1
1790 ELSE IF (ATOM .EQ. '.') THEN
1791 NPOINT = NPOINT + 1
1792 ELSE IF (ATOM .EQ. ' ') THEN
1793 J = LENGTH
1794 ELSE
1795 NUMBER = .FALSE.
1796 END IF
1797
1798 IF (NUMBER .AND. J .LT. LENGTH) GO TO 10
1799
1800 OPNUMB = NUMBER
1801 $ .AND. NDIGIT .GE. 1
1802 $ .AND. NEXP .LE. 1
1803 $ .AND. NMINUS .LE. 2
1804 $ .AND. NPLUS .LE. 2
1805 $ .AND. NPOINT .LE. 1
1806
1807 RETURN
1808
1809 * End of OPNUMB
1810 END
1811 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1812 C
1813 SUBROUTINE OPSCAN (STRING, FIRST, LAST, MARK)
1814 C
1815 C
1816 C Description and usage:
1817 C
1818 C Looks for non-blank fields ("tokens") in a string, where the
1819 C fields are of arbitrary length, separated by blanks, tabs, commas,
1820 C colons, or equal signs. The position of the end of the 1st token
1821 C is also returned, so this routine may be conveniently used within
1822 C a loop to process an entire line of text.
1823 C
1824 C The procedure examines a substring, STRING (FIRST : LAST), which
1825 C may of course be the entire string (in which case just call OPSCAN
1826 C with FIRST <= 1 and LAST >= LEN (STRING) ). The indices returned
1827 C are relative to STRING itself, not the substring.
1828 C
1829 C
1830 C Parameters:
1831 C
1832 C Name Dimension Type I/O/S Description
1833 C STRING C I Text string containing data to be
1834 C scanned.
1835 C FIRST I I/O Index of beginning of substring.
1836 C If <= 1, the search begins with 1.
1837 C Output is index of beginning of
1838 C first non-blank field, or 0 if no
1839 C token was found.
1840 C LAST I I/O Index of end of substring.
1841 C If >= LEN (STRING), the search
1842 C begins with LEN (STRING). Output
1843 C is index of end of last non-blank
1844 C field, or 0 if no token was found.
1845 C MARK I O Points to end of first non-blank
1846 C field in the specified substring.
1847 C Set to 0 if no token was found.
1848 C
1849 C
1850 C Environment: Digital VAX-11/780 VMS FORTRAN (FORTRAN 77).
1851 C ANSI Fortran 77, except for the tab character HT.
1852 C
1853 C Notes:
1854 C
1855 C (1) IMPLICIT NONE is non-standard. Constant HT (Tab) is defined
1856 C in a non-standard way: the CHAR function is not permitted
1857 C in a PARAMETER declaration (OK on VAX, though). For Absoft
1858 C FORTRAN 77 on 68000 machines, use HT = 9. In other cases, it
1859 C may be best to declare HT as a variable and assign
1860 C HT = CHAR(9) on ASCII machines, or CHAR(5) for EBCDIC.
1861 C
1862 C (2) The pseudo-recursive structure was chosen for fun. It is
1863 C equivalent to three DO loops with embedded GO TOs in sequence.
1864 C
1865 C (3) The variety of separators recognized limits the usefulness of
1866 C this routine somewhat. The intent is to facilitate handling
1867 C such tokens as keywords or numerical values. In other
1868 C applications, it may be necessary for ALL printing characters
1869 C to be significant. A simple modification to statement
1870 C function SOLID will do the trick.
1871 C
1872 C
1873 C Author: Robert Kennelly, Informatics General Corporation.
1874 C
1875 C
1876 C Development history:
1877 C
1878 C 29 Dec. 1984 RAK Initial design and coding, (very) loosely
1879 C based on SCAN_STRING by Ralph Carmichael.
1880 C 25 Feb. 1984 RAK Added ':' and '=' to list of separators.
1881 C 16 Apr. 1985 RAK Defined SOLID in terms of variable DUMMY
1882 C (previous re-use of STRING was ambiguous).
1883 C
1884 C-----------------------------------------------------------------------
1885
1886
1887 C Variable declarations.
1888 C ----------------------
1889
1890 * IMPLICIT NONE
1891
1892 C Parameters.
1893
1894 CHARACTER
1895 $ BLANK, EQUAL, COLON, COMMA, HT
1896 PARAMETER
1897 $ (BLANK = ' ', EQUAL = '=', COLON = ':', COMMA = ',')
1898
1899 C Variables.
1900
1901 LOGICAL
1902 $ SOLID
1903 INTEGER
1904 $ BEGIN, END, FIRST, LAST, LENGTH, MARK
1905 CHARACTER
1906 $ DUMMY, STRING * (*)
1907
1908 C Statement functions.
1909
1910 SOLID (DUMMY) = (DUMMY .NE. BLANK) .AND.
1911 $ (DUMMY .NE. COLON) .AND.
1912 $ (DUMMY .NE. COMMA) .AND.
1913 $ (DUMMY .NE. EQUAL) .AND.
1914 $ (DUMMY .NE. HT)
1915
1916
1917 C Executable statements.
1918 C ----------------------
1919
1920 **** HT = CHAR(9) for ASCII machines, CHAR(5) for EBCDIC.
1921 HT = CHAR(9)
1922 MARK = 0
1923 LENGTH = LEN (STRING)
1924 BEGIN = MAX (FIRST, 1)
1925 END = MIN (LENGTH, LAST)
1926
1927 C Find the first significant character ...
1928
1929 DO 30 FIRST = BEGIN, END, +1
1930 IF (SOLID (STRING (FIRST : FIRST))) THEN
1931
1932 C ... then the end of the first token ...
1933
1934 DO 20 MARK = FIRST, END - 1, +1
1935 IF (.NOT.SOLID (STRING (MARK + 1 : MARK + 1))) THEN
1936
1937 C ... and finally the last significant character.
1938
1939 DO 10 LAST = END, MARK, -1
1940 IF (SOLID (STRING (LAST : LAST))) THEN
1941 RETURN
1942 END IF
1943 10 CONTINUE
1944
1945 C Everything past the first token was a separator.
1946
1947 LAST = LAST + 1
1948 RETURN
1949 END IF
1950 20 CONTINUE
1951
1952 C There was nothing past the first token.
1953
1954 LAST = MARK
1955 RETURN
1956 END IF
1957 30 CONTINUE
1958
1959 C Whoops - the entire substring STRING (BEGIN : END) was composed of
1960 C separators !
1961
1962 FIRST = 0
1963 MARK = 0
1964 LAST = 0
1965 RETURN
1966
1967 C End of OPSCAN
1968 END
1969 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1970 C
1971 SUBROUTINE OPTOKN (STRING, NUMBER, LIST)
1972 C
1973 C
1974 C Description and usage:
1975 C
1976 C An aid to parsing input data. The individual "tokens" in a
1977 C character string are isolated, converted to uppercase, and stored
1978 C in an array. Here, a token is a group of significant, contiguous
1979 C characters. The following are NON-significant, and hence may
1980 C serve as separators: blanks, horizontal tabs, commas, colons,
1981 C and equal signs. See OPSCAN for details. Processing continues
1982 C until the requested number of tokens have been found or the end
1983 C of the input string is reached.
1984 C
1985 C
1986 C Parameters:
1987 C
1988 C Name Dimension Type I/O/S Description
1989 C STRING C I Input string to be analyzed.
1990 C NUMBER I I/O Number of tokens requested (input)
1991 C and found (output).
1992 C LIST NUMBER C O Array of tokens, changed to upper
1993 C case.
1994 C
1995 C
1996 C External references:
1997 C
1998 C Name Description
1999 C OPSCAN Finds positions of first and last significant characters.
2000 C OPUPPR Converts a string to uppercase.
2001 C
2002 C
2003 C Environment: Digital VAX-11/780 VMS FORTRAN (FORTRAN 77).
2004 C Appears to satisfy the ANSI Fortran 77 standard.
2005 C
2006 C
2007 C Notes:
2008 C
2009 C (1) IMPLICIT NONE is non-standard. (Has been commented out.)
2010 C
2011 C
2012 C Author: Robert Kennelly, Informatics General Corporation.
2013 C
2014 C
2015 C Development history:
2016 C
2017 C 16 Jan. 1984 RAK Initial design and coding.
2018 C 16 Mar. 1984 RAK Revised header to reflect full list of
2019 C separators, repaired faulty WHILE clause
2020 C in "10" loop.
2021 C 18 Sep. 1984 RAK Change elements of LIST to uppercase one
2022 C at a time, leaving STRING unchanged.
2023 C
2024 C-----------------------------------------------------------------------
2025
2026
2027 C Variable declarations.
2028 C ----------------------
2029
2030 * IMPLICIT NONE
2031
2032 C Parameters.
2033
2034 CHARACTER
2035 $ BLANK
2036 PARAMETER
2037 $ (BLANK = ' ')
2038
2039 C Variables.
2040
2041 INTEGER
2042 $ COUNT, FIRST, I, LAST, MARK, NUMBER
2043 CHARACTER
2044 $ STRING * (*), LIST (NUMBER) * (*)
2045
2046 C Procedures.
2047
2048 EXTERNAL
2049 $ OPUPPR, OPSCAN
2050
2051
2052 C Executable statements.
2053 C ----------------------
2054
2055 C WHILE there are tokens to find, loop UNTIL enough have been found.
2056
2057 FIRST = 1
2058 LAST = LEN (STRING)
2059
2060 COUNT = 0
2061 10 CONTINUE
2062
2063 C Get delimiting indices of next token, if any.
2064
2065 CALL OPSCAN (STRING, FIRST, LAST, MARK)
2066 IF (LAST .GT. 0) THEN
2067 COUNT = COUNT + 1
2068
2069 C Pass token to output string array, then change case.
2070
2071 LIST (COUNT) = STRING (FIRST : MARK)
2072 CALL OPUPPR (LIST (COUNT))
2073 FIRST = MARK + 2
2074 IF (COUNT .LT. NUMBER) GO TO 10
2075
2076 END IF
2077
2078
2079 C Fill the rest of LIST with blanks and set NUMBER for output.
2080
2081 DO 20 I = COUNT + 1, NUMBER
2082 LIST (I) = BLANK
2083 20 CONTINUE
2084
2085 NUMBER = COUNT
2086
2087
2088 C Termination.
2089 C ------------
2090
2091 RETURN
2092
2093 C End of OPTOKN
2094 END
2095 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2096 C
2097 SUBROUTINE OPUPPR(STRING)
2098 C
2099 C ACRONYM: UPper CASE
2100 C
2101 C PURPOSE: This subroutine changes all lower case letters in the
2102 C character string to upper case.
2103 C
2104 C METHOD: Each character in STRING is treated in turn. The intrinsic
2105 C function INDEX effectively allows a table lookup, with
2106 C the local strings LOW and UPP acting as two tables.
2107 C This method avoids the use of CHAR and ICHAR, which appear
2108 C be different on ASCII and EBCDIC machines.
2109 C
2110 C ARGUMENTS
2111 C ARG DIM TYPE I/O/S DESCRIPTION
2112 C STRING * C I/O Character string possibly containing
2113 C some lower-case letters on input;
2114 C strictly upper-case letters on output
2115 C with no change to any non-alphabetic
2116 C characters.
2117 C
2118 C EXTERNAL REFERENCES:
2119 C LEN - Returns the declared length of a CHARACTER variable.
2120 C INDEX - Returns the position of second string within first.
2121 C
2122 C ENVIRONMENT: ANSI FORTRAN 77
2123 C
2124 C DEVELOPMENT HISTORY:
2125 C DATE INITIALS DESCRIPTION
2126 C 06/28/83 CLH Initial design.
2127 C 01/03/84 RAK Eliminated NCHAR input.
2128 C 06/14/84 RAK Used integer PARAMETERs in comparison.
2129 C 04/21/85 RAK Eliminated DO/END DO in favor of standard code.
2130 C 09/10/85 MAS Eliminated CHAR,ICHAR in favor of LOW, UPP, INDEX.
2131 C
2132 C AUTHOR: Charles Hooper, Informatics General, Palo Alto, CA.
2133 C
2134 C-----------------------------------------------------------------------
2135
2136 CHARACTER STRING * (*)
2137 INTEGER I, J
2138 character*1 C
2139 character*26 LOW, UPP
2140 data LOW /'abcdefghijklmnopqrstuvwxyz'/,
2141 $ UPP /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
2142
2143 DO 10 J = 1, LEN(STRING)
2144 C = STRING(J:J)
2145 IF (C .GE. 'a' .AND. C .LE. 'z') THEN
2146 I = INDEX( LOW, C )
2147 IF (I .GT. 0) STRING(J:J) = UPP(I:I)
2148 END IF
2149 10 CONTINUE
2150
2151 * End of OPUPPR
2152 END

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