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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (hide 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 aw0a 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