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

Contents of /trunk/minos54/mi30spec.f.orig

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: 79295 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*(*) 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*(*) 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*(*) 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 print *, 'buffer: ', buffer
1312 nread = nread + 1
1313 nkey = 1
1314 call optokn( buffer, nkey, token )
1315 key = token(1)
1316 if (key .eq. 'ENDRUN') go to 940
1317 if (key .ne. 'BEGIN' ) then
1318 if (nread .eq. 1 .and. key .ne. 'SKIP') then
1319 inform = inform + 1
1320 if (lprnt .gt. 0) write (lprnt, 2000) ioptns, buffer
1321 if (lsumm .gt. 0) write (lsumm, 2000) ioptns, buffer
1322 end if
1323 go to 50
1324 end if
1325
1326 * ------------------------------------------------------------------
1327 * BEGIN found.
1328 * This is taken to be the first line of an OPTIONS file.
1329 * It is printed without the trailing blanks.
1330 * ------------------------------------------------------------------
1331 call m1page(1)
1332 do 10 j = 1, len(buffer)
1333 if (buffer(j:j) .ne. ' ') lenbuf = j
1334 10 continue
1335
1336 if (lprnt .gt. 0) then
1337 write (lprnt, '( 9x, a)') ' ', dashes, title, dashes
1338 write (lprnt, '(/ 6x, a)') buffer(1:lenbuf)
1339 end if
1340 if (lsumm .gt. 0) then
1341 write (lsumm, '( 1x, a)') ' ', dashes, title, dashes
1342 write (lsumm, '(/ 1x, a)') buffer(1:lenbuf)
1343 end if
1344
1345 * Set options to default values.
1346
1347 call m3dflt( 1 )
1348
1349 * ------------------------------------------------------------------
1350 * Read the rest of the file.
1351 * ------------------------------------------------------------------
1352 *+ while (key .ne. 'END') loop
1353 100 if (key .ne. 'END') then
1354 read (ioptns, '(a72)', end = 920) buffer
1355 call opkey ( buffer, key, lprnt, lsumm, inform )
1356 go to 100
1357 end if
1358 *+ end while
1359
1360 return
1361
1362 920 if (lprnt .gt. 0) write (lprnt, 2200) ioptns
1363 if (lsumm .gt. 0) write (lsumm, 2200) ioptns
1364 inform = 2
1365 return
1366
1367 930 if (ncalls .le. 1) then
1368 if (lprnt .gt. 0) write (lprnt, 2300) ioptns
1369 if (lsumm .gt. 0) write (lsumm, 2300) ioptns
1370 else
1371 if (lprnt .gt. 0) write (lprnt, '(a)') ' Endrun'
1372 if (lsumm .gt. 0) write (lsumm, '(a)') ' Endrun'
1373 end if
1374 inform = 3
1375 return
1376
1377 940 if (lprnt .gt. 0) write (lprnt, '(/ 6x, a)') buffer
1378 if (lsumm .gt. 0) write (lsumm, '(/ 1x, a)') buffer
1379 inform = 4
1380 return
1381
1382 2000 format(
1383 $ //' XXX Error while looking for an OPTIONS file on unit', I7
1384 $ / ' XXX The file should start with Begin, Skip or Endrun'
1385 $ / ' XXX but the first record found was the following:'
1386 $ //' ---->', a
1387 $ //' XXX Continuing to look for OPTIONS file...')
1388 2200 format(//' XXX End-of-file encountered while processing',
1389 $ ' an OPTIONS file on unit', I6)
1390 2300 format(//' XXX End-of-file encountered while looking for',
1391 $ ' an OPTIONS file on unit', I6)
1392
1393 * end of opfile
1394 end
1395
1396 *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1397 C
1398 SUBROUTINE OPLOOK (NDICT, DICTRY, ALPHA, KEY, ENTRY)
1399 C
1400 C
1401 C Description and usage:
1402 C
1403 C Performs dictionary lookups. A pointer is returned if a
1404 C match is found between the input key and the corresponding
1405 C initial characters of one of the elements of the dictionary.
1406 C If a "synonym" has been provided for an entry, the search is
1407 C continued until a match to a primary dictionary entry is found.
1408 C Cases of no match, or multiple matches, are also provided for.
1409 C
1410 C Dictionary entries must be left-justified, and may be alphabetized
1411 C for faster searches. Secondary entries, if any, are composed of
1412 C two words separated by one or more characters such as blank, tab,
1413 C comma, colon, or equal sign which are treated as non-significant
1414 C by OPSCAN. The first entry of each such pair serves as a synonym
1415 C for the second, more fundamental keyword.
1416 C
1417 C The ordered search stops after the section of the dictionary
1418 C having the same first letters as the key has been checked, or
1419 C after a specified number of entries have been examined. A special
1420 C dictionary entry, the vertical bar '|', will also terminate the
1421 C search. This will speed things up if an appropriate dictionary
1422 C length parameter cannot be determined. Both types of search are
1423 C sequential. See "Notes" below for some suggestions if efficiency
1424 C is an issue.
1425 C
1426 C
1427 C Parameters:
1428 C
1429 C Name Dimension Type I/O/S Description
1430 C NDICT I I Number of dictionary entries to be
1431 C examined.
1432 C DICTRY NDICT C I Array of dictionary entries,
1433 C left-justified in their fields.
1434 C May be alphabetized for efficiency,
1435 C in which case ALPHA should be
1436 C .TRUE. Entries with synonyms are
1437 C of the form
1438 C 'ENTRY : SYNONYM', where 'SYNONYM'
1439 C is a more fundamental entry in the
1440 C same dictionary. NOTE: Don't build
1441 C "circular" dictionaries!
1442 C ALPHA L I Indicates whether the dictionary
1443 C is in alphabetical order, in which
1444 C case the search can be terminated
1445 C sooner.
1446 C KEY C I/O String to be compared against the
1447 C dictionary. Abbreviations are OK
1448 C if they correspond to a unique
1449 C entry in the dictionary. KEY is
1450 C replaced on termination by its most
1451 C fundamental equivalent dictionary
1452 C entry (uppercase, left-justified)
1453 C if a match was found.
1454 C ENTRY I O Dictionary pointer. If > 0, it
1455 C indicates which entry matched KEY.
1456 C In case of trouble, a negative
1457 C value means that a UNIQUE match
1458 C was not found - the absolute value
1459 C of ENTRY points to the second
1460 C dictionary entry that matched KEY.
1461 C Zero means that NO match could be
1462 C found. ENTRY always refers to the
1463 C last search performed -
1464 C in searching a chain of synonyms,
1465 C a non-positive value will be
1466 C returned if there is any break,
1467 C even if the original input key
1468 C was found.
1469 C
1470 C
1471 C External references:
1472 C
1473 C Name Description
1474 C OPSCAN Finds first and last significant characters.
1475 C
1476 C
1477 C Environment: Digital VAX-11/780 VMS FORTRAN (FORTRAN 77).
1478 C Appears to satisfy the ANSI Fortran 77 standard.
1479 C
1480 C
1481 C Notes:
1482 C
1483 C (1) IMPLICIT NONE is non-standard. (Has been commented out.)
1484 C
1485 C (2) We have assumed that the dictionary is not too big. If
1486 C many searches are to be done or if the dictionary has more
1487 C than a dozen or so entries, it may be advantageous to build
1488 C an index array of pointers to the beginning of the section
1489 C of the dictionary containing each letter, then pass in the
1490 C portion of the dictionary beginning with DICTRY (INDEX).
1491 C (This won't generally work for dictionaries with synonyms.)
1492 C For very large problems, a completely different approach may
1493 C be advisable, e.g. a binary search for ordered dictionaries.
1494 C
1495 C (3) OPLOOK is case sensitive. In most applications it will be
1496 C necessary to use an uppercase dictionary, and to convert the
1497 C input key to uppercase before calling OPLOOK. Companion
1498 C routines OPTOKN and PAIRS, available from the author, already
1499 C take care of this.
1500 C
1501 C (4) The key need not be left-justified. Any leading (or
1502 C trailing) characters which are "non-significant" to OPSCAN
1503 C will be ignored. These include blanks, horizontal tabs,
1504 C commas, colons, and equal signs. See OPSCAN for details.
1505 C
1506 C (5) The ASCII collating sequence for character data is assumed.
1507 C (N.B. This means the numerals precede the alphabet, unlike
1508 C common practice!) This should not cause trouble on EBCDIC
1509 C machines if DICTRY just contains alphabetic keywords.
1510 C Otherwise it may be necessary to use the FORTRAN lexical
1511 C library routines to force use of the ASCII sequence.
1512 C
1513 C (6) Parameter NUMSIG sets a limit on the length of significant
1514 C dictionary entries. Special applications may require that
1515 C this be increased. (It is 16 in the present version.)
1516 C
1517 C (7) No protection against "circular" dictionaries is provided:
1518 C don't claim that A is B, and that B is A. All synonym chains
1519 C must terminate! Other potential errors not checked for
1520 C include duplicate or mis-ordered entries.
1521 C
1522 C (8) The handling of ambiguities introduces some ambiguity:
1523 C
1524 C ALPHA = .TRUE. A potential problem, when one entry
1525 C looks like an abbreviation for another
1526 C (eg. does 'A' match 'A' or 'AB'?) was
1527 C resolved by dropping out of the search
1528 C immediately when an "exact" match is found.
1529 C
1530 C ALPHA = .FALSE. The programmer must ensure that the above
1531 C situation does not arise: each dictionary
1532 C entry must be recognizable, at least when
1533 C specified to full length. Otherwise, the
1534 C result of a search will depend on the
1535 C order of entries.
1536 C
1537 C
1538 C Author: Robert Kennelly, Informatics General Corporation.
1539 C
1540 C
1541 C Development history:
1542 C
1543 C 24 Feb. 1984 RAK/DAS Initial design and coding.
1544 C 25 Feb. 1984 RAK Combined the two searches by suitable
1545 C choice of terminator FLAG.
1546 C 28 Feb. 1984 RAK Optional synonyms in dictionary, no
1547 C longer update KEY.
1548 C 29 Mar. 1984 RAK Put back replacement of KEY by its
1549 C corresponding entry.
1550 C 21 June 1984 RAK Corrected bug in error handling for cases
1551 C where no match was found.
1552 C 23 Apr. 1985 RAK Introduced test for exact matches, which
1553 C permits use of dictionary entries which
1554 C would appear to be ambiguous (for ordered
1555 C case). Return -I to point to the entry
1556 C which appeared ambiguous (had been -1).
1557 C Repaired loop termination - had to use
1558 C equal length strings or risk quitting too
1559 C soon when one entry is an abbreviation
1560 C for another. Eliminated HIT, reduced
1561 C NUMSIG to 16.
1562 C 15 Nov. 1985 MAS Loop 20 now tests .LT. FLAG, not .LE. FLAG.
1563 C If ALPHA is false, FLAG is now '|', not '{'.
1564 C 26 Jan. 1986 PEG Declaration of FLAG and TARGET modified to
1565 C conform to ANSI-77 standard.
1566 C-----------------------------------------------------------------------
1567
1568
1569 C Variable declarations.
1570 C ----------------------
1571
1572 * IMPLICIT NONE
1573
1574 C Parameters.
1575
1576 INTEGER
1577 $ NUMSIG
1578 CHARACTER
1579 $ BLANK, VBAR
1580 PARAMETER
1581 $ (BLANK = ' ', VBAR = '|', NUMSIG = 16)
1582
1583 C Variables.
1584
1585 LOGICAL
1586 $ ALPHA
1587 INTEGER
1588 $ ENTRY, FIRST, I, LAST, LENGTH, MARK, NDICT
1589 * CHARACTER
1590 * $ DICTRY (NDICT) * (*), FLAG * (NUMSIG),
1591 * $ KEY * (*), TARGET * (NUMSIG)
1592 CHARACTER
1593 $ DICTRY (NDICT) * (*), FLAG * 16,
1594 $ KEY * (*), TARGET * 16
1595
1596 C Procedures.
1597
1598 EXTERNAL
1599 $ OPSCAN
1600
1601
1602 C Executable statements.
1603 C ----------------------
1604
1605 ENTRY = 0
1606
1607 C Isolate the significant portion of the input key (if any).
1608
1609 FIRST = 1
1610 LAST = MIN( LEN(KEY), NUMSIG )
1611 CALL OPSCAN (KEY, FIRST, LAST, MARK)
1612
1613 IF (MARK .GT. 0) THEN
1614 TARGET = KEY (FIRST:MARK)
1615
1616 C Look up TARGET in the dictionary.
1617
1618 10 CONTINUE
1619 LENGTH = MARK - FIRST + 1
1620
1621 C Select search strategy by cunning choice of termination test
1622 C flag. The vertical bar is just about last in both the
1623 C ASCII and EBCDIC collating sequences.
1624
1625 IF (ALPHA) THEN
1626 FLAG = TARGET
1627 ELSE
1628 FLAG = VBAR
1629 END IF
1630
1631
1632 C Perform search.
1633 C ---------------
1634
1635 I = 0
1636 20 CONTINUE
1637 I = I + 1
1638 IF (TARGET (1:LENGTH) .EQ. DICTRY (I) (1:LENGTH)) THEN
1639 IF (ENTRY .EQ. 0) THEN
1640
1641 C First "hit" - must still guard against ambiguities
1642 C by searching until we've gone beyond the key
1643 C (ordered dictionary) or until the end-of-dictionary
1644 C mark is reached (exhaustive search).
1645
1646 ENTRY = I
1647
1648 C Special handling if match is exact - terminate
1649 C search. We thus avoid confusion if one dictionary
1650 C entry looks like an abbreviation of another.
1651 C This fix won't generally work for un-ordered
1652 C dictionaries!
1653
1654 FIRST = 1
1655 LAST = NUMSIG
1656 CALL OPSCAN (DICTRY (ENTRY), FIRST, LAST, MARK)
1657 IF (MARK .EQ. LENGTH) I = NDICT
1658 ELSE
1659
1660
1661 C Oops - two hits! Abnormal termination.
1662 C ---------------------------------------
1663
1664 ENTRY = -I
1665 RETURN
1666 END IF
1667 END IF
1668
1669 C Check whether we've gone past the appropriate section of the
1670 C dictionary. The test on the index provides insurance and an
1671 C optional means for limiting the extent of the search.
1672
1673 IF (DICTRY (I) (1:LENGTH) .LT. FLAG .AND. I .LT. NDICT)
1674 $ GO TO 20
1675
1676
1677 C Check for a synonym.
1678 C --------------------
1679
1680 IF (ENTRY .GT. 0) THEN
1681
1682 C Look for a second entry "behind" the first entry. FIRST
1683 C and MARK were determined above when the hit was detected.
1684
1685 FIRST = MARK + 2
1686 CALL OPSCAN (DICTRY (ENTRY), FIRST, LAST, MARK)
1687 IF (MARK .GT. 0) THEN
1688
1689 C Re-set target and dictionary pointer, then repeat the
1690 C search for the synonym instead of the original key.
1691
1692 TARGET = DICTRY (ENTRY) (FIRST:MARK)
1693 ENTRY = 0
1694 GO TO 10
1695
1696 END IF
1697 END IF
1698
1699 END IF
1700 IF (ENTRY .GT. 0) KEY = DICTRY (ENTRY)
1701
1702
1703 C Normal termination.
1704 C -------------------
1705
1706 RETURN
1707
1708 C End of OPLOOK
1709 END
1710 *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1711
1712 FUNCTION OPNUMB( STRING )
1713
1714 LOGICAL OPNUMB
1715 CHARACTER*(*) STRING
1716
1717 ************************************************************************
1718 * Description and usage:
1719 *
1720 * A simple(-minded) test for numeric data is implemented by
1721 * searching an input string for legitimate characters:
1722 * digits 0 to 9, D, E, -, + and .
1723 * Insurance is provided by requiring that a numeric string
1724 * have at least one digit, at most one D, E or .
1725 * and at most two -s or +s. Note that a few ambiguities remain:
1726 *
1727 * (a) A string might have the form of numeric data but be
1728 * intended as text. No general test can hope to detect
1729 * such cases.
1730 *
1731 * (b) There is no check for correctness of the data format.
1732 * For example a meaningless string such as 'E1.+2-'
1733 * will be accepted as numeric.
1734 *
1735 * Despite these weaknesses, the method should work in the
1736 * majority of cases.
1737 *
1738 *
1739 * Parameters:
1740 *
1741 * Name Dimension Type I/O/S Description
1742 * OPNUMB L O Set .TRUE. if STRING appears
1743 * to be numerical data.
1744 * STRING C I Input data to be tested.
1745 *
1746 *
1747 * Environment: ANSI FORTRAN 77.
1748 *
1749 *
1750 * Notes:
1751 *
1752 * (1) It is assumed that STRING is a token extracted by
1753 * OPTOKN, which will have converted any lower-case
1754 * characters to upper-case.
1755 *
1756 * (2) OPTOKN pads STRING with blanks, so that a genuine
1757 * number is of the form '1234 '.
1758 * Hence, the scan of STRING stops at the first blank.
1759 *
1760 * (3) COMPLEX data with parentheses will not look numeric.
1761 *
1762 *
1763 * Systems Optimization Laboratory, Stanford University.
1764 * 12 Nov 1985 Initial design and coding, starting from the
1765 * routine ALPHA from Informatics General, Inc.
1766 ************************************************************************
1767
1768 LOGICAL NUMBER
1769 INTEGER J, LENGTH, NDIGIT, NEXP, NMINUS, NPLUS, NPOINT
1770 CHARACTER*1 ATOM
1771
1772 NDIGIT = 0
1773 NEXP = 0
1774 NMINUS = 0
1775 NPLUS = 0
1776 NPOINT = 0
1777 NUMBER = .TRUE.
1778 LENGTH = LEN (STRING)
1779 J = 0
1780
1781 10 J = J + 1
1782 ATOM = STRING (J:J)
1783 IF (ATOM .GE. '0' .AND. ATOM .LE. '9') THEN
1784 NDIGIT = NDIGIT + 1
1785 ELSE IF (ATOM .EQ. 'D' .OR. ATOM .EQ. 'E') THEN
1786 NEXP = NEXP + 1
1787 ELSE IF (ATOM .EQ. '-') THEN
1788 NMINUS = NMINUS + 1
1789 ELSE IF (ATOM .EQ. '+') THEN
1790 NPLUS = NPLUS + 1
1791 ELSE IF (ATOM .EQ. '.') THEN
1792 NPOINT = NPOINT + 1
1793 ELSE IF (ATOM .EQ. ' ') THEN
1794 J = LENGTH
1795 ELSE
1796 NUMBER = .FALSE.
1797 END IF
1798
1799 IF (NUMBER .AND. J .LT. LENGTH) GO TO 10
1800
1801 OPNUMB = NUMBER
1802 $ .AND. NDIGIT .GE. 1
1803 $ .AND. NEXP .LE. 1
1804 $ .AND. NMINUS .LE. 2
1805 $ .AND. NPLUS .LE. 2
1806 $ .AND. NPOINT .LE. 1
1807
1808 RETURN
1809
1810 * End of OPNUMB
1811 END
1812 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1813 C
1814 SUBROUTINE OPSCAN (STRING, FIRST, LAST, MARK)
1815 C
1816 C
1817 C Description and usage:
1818 C
1819 C Looks for non-blank fields ("tokens") in a string, where the
1820 C fields are of arbitrary length, separated by blanks, tabs, commas,
1821 C colons, or equal signs. The position of the end of the 1st token
1822 C is also returned, so this routine may be conveniently used within
1823 C a loop to process an entire line of text.
1824 C
1825 C The procedure examines a substring, STRING (FIRST : LAST), which
1826 C may of course be the entire string (in which case just call OPSCAN
1827 C with FIRST <= 1 and LAST >= LEN (STRING) ). The indices returned
1828 C are relative to STRING itself, not the substring.
1829 C
1830 C
1831 C Parameters:
1832 C
1833 C Name Dimension Type I/O/S Description
1834 C STRING C I Text string containing data to be
1835 C scanned.
1836 C FIRST I I/O Index of beginning of substring.
1837 C If <= 1, the search begins with 1.
1838 C Output is index of beginning of
1839 C first non-blank field, or 0 if no
1840 C token was found.
1841 C LAST I I/O Index of end of substring.
1842 C If >= LEN (STRING), the search
1843 C begins with LEN (STRING). Output
1844 C is index of end of last non-blank
1845 C field, or 0 if no token was found.
1846 C MARK I O Points to end of first non-blank
1847 C field in the specified substring.
1848 C Set to 0 if no token was found.
1849 C
1850 C
1851 C Environment: Digital VAX-11/780 VMS FORTRAN (FORTRAN 77).
1852 C ANSI Fortran 77, except for the tab character HT.
1853 C
1854 C Notes:
1855 C
1856 C (1) IMPLICIT NONE is non-standard. Constant HT (Tab) is defined
1857 C in a non-standard way: the CHAR function is not permitted
1858 C in a PARAMETER declaration (OK on VAX, though). For Absoft
1859 C FORTRAN 77 on 68000 machines, use HT = 9. In other cases, it
1860 C may be best to declare HT as a variable and assign
1861 C HT = CHAR(9) on ASCII machines, or CHAR(5) for EBCDIC.
1862 C
1863 C (2) The pseudo-recursive structure was chosen for fun. It is
1864 C equivalent to three DO loops with embedded GO TOs in sequence.
1865 C
1866 C (3) The variety of separators recognized limits the usefulness of
1867 C this routine somewhat. The intent is to facilitate handling
1868 C such tokens as keywords or numerical values. In other
1869 C applications, it may be necessary for ALL printing characters
1870 C to be significant. A simple modification to statement
1871 C function SOLID will do the trick.
1872 C
1873 C
1874 C Author: Robert Kennelly, Informatics General Corporation.
1875 C
1876 C
1877 C Development history:
1878 C
1879 C 29 Dec. 1984 RAK Initial design and coding, (very) loosely
1880 C based on SCAN_STRING by Ralph Carmichael.
1881 C 25 Feb. 1984 RAK Added ':' and '=' to list of separators.
1882 C 16 Apr. 1985 RAK Defined SOLID in terms of variable DUMMY
1883 C (previous re-use of STRING was ambiguous).
1884 C
1885 C-----------------------------------------------------------------------
1886
1887
1888 C Variable declarations.
1889 C ----------------------
1890
1891 * IMPLICIT NONE
1892
1893 C Parameters.
1894
1895 CHARACTER
1896 $ BLANK, EQUAL, COLON, COMMA, HT
1897 PARAMETER
1898 $ (BLANK = ' ', EQUAL = '=', COLON = ':', COMMA = ',')
1899
1900 C Variables.
1901
1902 LOGICAL
1903 $ SOLID
1904 INTEGER
1905 $ BEGIN, END, FIRST, LAST, LENGTH, MARK
1906 CHARACTER
1907 $ DUMMY, STRING * (*)
1908
1909 C Statement functions.
1910
1911 SOLID (DUMMY) = (DUMMY .NE. BLANK) .AND.
1912 $ (DUMMY .NE. COLON) .AND.
1913 $ (DUMMY .NE. COMMA) .AND.
1914 $ (DUMMY .NE. EQUAL) .AND.
1915 $ (DUMMY .NE. HT)
1916
1917
1918 C Executable statements.
1919 C ----------------------
1920
1921 **** HT = CHAR(9) for ASCII machines, CHAR(5) for EBCDIC.
1922 HT = CHAR(9)
1923 MARK = 0
1924 LENGTH = LEN (STRING)
1925 BEGIN = MAX (FIRST, 1)
1926 END = MIN (LENGTH, LAST)
1927
1928 C Find the first significant character ...
1929
1930 DO 30 FIRST = BEGIN, END, +1
1931 IF (SOLID (STRING (FIRST : FIRST))) THEN
1932
1933 C ... then the end of the first token ...
1934
1935 DO 20 MARK = FIRST, END - 1, +1
1936 IF (.NOT.SOLID (STRING (MARK + 1 : MARK + 1))) THEN
1937
1938 C ... and finally the last significant character.
1939
1940 DO 10 LAST = END, MARK, -1
1941 IF (SOLID (STRING (LAST : LAST))) THEN
1942 RETURN
1943 END IF
1944 10 CONTINUE
1945
1946 C Everything past the first token was a separator.
1947
1948 LAST = LAST + 1
1949 RETURN
1950 END IF
1951 20 CONTINUE
1952
1953 C There was nothing past the first token.
1954
1955 LAST = MARK
1956 RETURN
1957 END IF
1958 30 CONTINUE
1959
1960 C Whoops - the entire substring STRING (BEGIN : END) was composed of
1961 C separators !
1962
1963 FIRST = 0
1964 MARK = 0
1965 LAST = 0
1966 RETURN
1967
1968 C End of OPSCAN
1969 END
1970 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1971 C
1972 SUBROUTINE OPTOKN (STRING, NUMBER, LIST)
1973 C
1974 C
1975 C Description and usage:
1976 C
1977 C An aid to parsing input data. The individual "tokens" in a
1978 C character string are isolated, converted to uppercase, and stored
1979 C in an array. Here, a token is a group of significant, contiguous
1980 C characters. The following are NON-significant, and hence may
1981 C serve as separators: blanks, horizontal tabs, commas, colons,
1982 C and equal signs. See OPSCAN for details. Processing continues
1983 C until the requested number of tokens have been found or the end
1984 C of the input string is reached.
1985 C
1986 C
1987 C Parameters:
1988 C
1989 C Name Dimension Type I/O/S Description
1990 C STRING C I Input string to be analyzed.
1991 C NUMBER I I/O Number of tokens requested (input)
1992 C and found (output).
1993 C LIST NUMBER C O Array of tokens, changed to upper
1994 C case.
1995 C
1996 C
1997 C External references:
1998 C
1999 C Name Description
2000 C OPSCAN Finds positions of first and last significant characters.
2001 C OPUPPR Converts a string to uppercase.
2002 C
2003 C
2004 C Environment: Digital VAX-11/780 VMS FORTRAN (FORTRAN 77).
2005 C Appears to satisfy the ANSI Fortran 77 standard.
2006 C
2007 C
2008 C Notes:
2009 C
2010 C (1) IMPLICIT NONE is non-standard. (Has been commented out.)
2011 C
2012 C
2013 C Author: Robert Kennelly, Informatics General Corporation.
2014 C
2015 C
2016 C Development history:
2017 C
2018 C 16 Jan. 1984 RAK Initial design and coding.
2019 C 16 Mar. 1984 RAK Revised header to reflect full list of
2020 C separators, repaired faulty WHILE clause
2021 C in "10" loop.
2022 C 18 Sep. 1984 RAK Change elements of LIST to uppercase one
2023 C at a time, leaving STRING unchanged.
2024 C
2025 C-----------------------------------------------------------------------
2026
2027
2028 C Variable declarations.
2029 C ----------------------
2030
2031 * IMPLICIT NONE
2032
2033 C Parameters.
2034
2035 CHARACTER
2036 $ BLANK
2037 PARAMETER
2038 $ (BLANK = ' ')
2039
2040 C Variables.
2041
2042 INTEGER
2043 $ COUNT, FIRST, I, LAST, MARK, NUMBER
2044 CHARACTER
2045 $ STRING * (*), LIST (NUMBER) * (*)
2046
2047 C Procedures.
2048
2049 EXTERNAL
2050 $ OPUPPR, OPSCAN
2051
2052
2053 C Executable statements.
2054 C ----------------------
2055
2056 C WHILE there are tokens to find, loop UNTIL enough have been found.
2057
2058 FIRST = 1
2059 LAST = LEN (STRING)
2060
2061 COUNT = 0
2062 10 CONTINUE
2063
2064 C Get delimiting indices of next token, if any.
2065
2066 CALL OPSCAN (STRING, FIRST, LAST, MARK)
2067 IF (LAST .GT. 0) THEN
2068 COUNT = COUNT + 1
2069
2070 C Pass token to output string array, then change case.
2071
2072 LIST (COUNT) = STRING (FIRST : MARK)
2073 CALL OPUPPR (LIST (COUNT))
2074 FIRST = MARK + 2
2075 IF (COUNT .LT. NUMBER) GO TO 10
2076
2077 END IF
2078
2079
2080 C Fill the rest of LIST with blanks and set NUMBER for output.
2081
2082 DO 20 I = COUNT + 1, NUMBER
2083 LIST (I) = BLANK
2084 20 CONTINUE
2085
2086 NUMBER = COUNT
2087
2088
2089 C Termination.
2090 C ------------
2091
2092 RETURN
2093
2094 C End of OPTOKN
2095 END
2096 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2097 C
2098 SUBROUTINE OPUPPR(STRING)
2099 C
2100 C ACRONYM: UPper CASE
2101 C
2102 C PURPOSE: This subroutine changes all lower case letters in the
2103 C character string to upper case.
2104 C
2105 C METHOD: Each character in STRING is treated in turn. The intrinsic
2106 C function INDEX effectively allows a table lookup, with
2107 C the local strings LOW and UPP acting as two tables.
2108 C This method avoids the use of CHAR and ICHAR, which appear
2109 C be different on ASCII and EBCDIC machines.
2110 C
2111 C ARGUMENTS
2112 C ARG DIM TYPE I/O/S DESCRIPTION
2113 C STRING * C I/O Character string possibly containing
2114 C some lower-case letters on input;
2115 C strictly upper-case letters on output
2116 C with no change to any non-alphabetic
2117 C characters.
2118 C
2119 C EXTERNAL REFERENCES:
2120 C LEN - Returns the declared length of a CHARACTER variable.
2121 C INDEX - Returns the position of second string within first.
2122 C
2123 C ENVIRONMENT: ANSI FORTRAN 77
2124 C
2125 C DEVELOPMENT HISTORY:
2126 C DATE INITIALS DESCRIPTION
2127 C 06/28/83 CLH Initial design.
2128 C 01/03/84 RAK Eliminated NCHAR input.
2129 C 06/14/84 RAK Used integer PARAMETERs in comparison.
2130 C 04/21/85 RAK Eliminated DO/END DO in favor of standard code.
2131 C 09/10/85 MAS Eliminated CHAR,ICHAR in favor of LOW, UPP, INDEX.
2132 C
2133 C AUTHOR: Charles Hooper, Informatics General, Palo Alto, CA.
2134 C
2135 C-----------------------------------------------------------------------
2136
2137 CHARACTER STRING * (*)
2138 INTEGER I, J
2139 character*1 C
2140 character*26 LOW, UPP
2141 data LOW /'abcdefghijklmnopqrstuvwxyz'/,
2142 $ UPP /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
2143
2144 DO 10 J = 1, LEN(STRING)
2145 C = STRING(J:J)
2146 IF (C .GE. 'a' .AND. C .LE. 'z') THEN
2147 I = INDEX( LOW, C )
2148 IF (I .GT. 0) STRING(J:J) = UPP(I:I)
2149 END IF
2150 10 CONTINUE
2151
2152 * End of OPUPPR
2153 END

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