File: C:\NOAA\NEMS_11731\src\chem\gocart\src\Config\f90aib.F90
1 module faibidnt
2
3
4 character (len=*), parameter :: zsccs = &
5 "@(#)faibidnt.f90 1.3 00/12/15 Michel Olagnon"
6 character (len=*), parameter :: zvers = &
7 "@(#) faibidnt.f90 V-0.3 00/12/15 Michel Olagnon"
8 character (len=*), parameter :: zusg = &
9 "( usage: f90aib < file.f90 > file.f90 )"
10 character (len=*), parameter :: zhlp = '( &
11 &"Fortran 90 utility to process free source form code and"/&
12 &"automatically try to build interface blocks"/&
13 &"____________________________________________________________________"/&
14 &"Copyright (C) 1997-2000 M. Olagnon"/&
15 &"This program is free software; you can redistribute it and/or modify"/&
16 &"it under the terms of the GNU General Public License as published by"/&
17 &"the Free Software Foundation; either version 2 of the License, or"/&
18 &"(at your option) any later version."//&
19 &"This program is distributed in the hope that it will be useful,"/&
20 &"but WITHOUT ANY WARRANTY; without even the implied warranty of"/&
21 &"MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the"/&
22 &"GNU General Public License for more details."//&
23 &"You should have received a copy of the GNU General Public License"/&
24 &"along with this program; if not, write to the Free Software"/&
25 &"Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA."//&
26 &"Originally written by Michel Olagnon, from Ifremer, France,"/&
27 &"who would be pleased to receive your comments and corrections."/&
28 &" M. Olagnon (Michel.Olagnon@ifremer.fr)"/&
29 &"____________________________________________________________________"/&
30 &" version 0.3 of 15 Dec. 2000"/&
31 &"____________________________________________________________________"/&
32 &"Note: If you do not like code to start in column 7, remember that,"/&
33 &" had Diophantes left a 6 characters margin, then mathematicians"/&
34 &" might have spared much efforts on A**N = B**N + C**N ..."/&
35 &" My margin is wide to let you put your corrections there."/&
36 &"____________________________________________________________________")'
37
38 end module faibidnt
39 module flexprms
40
41
42 character (len=1), parameter :: ztab = achar(9)
43 character (len=1), parameter :: zbks = achar(92)
44
45
46
47 integer, parameter :: lnamm = 31
48 integer, parameter :: lfilm = 64
49 integer, parameter :: ncntm = 39
50 integer, parameter :: linem = 132
51 integer, parameter :: lsttm = (linem-1)*ncntm+linem
52
53
54
55
56 integer, parameter :: klunv = -1
57 integer, parameter :: klnrm = 0
58 integer, parameter :: kllst = 1
59 integer, parameter :: klctd = 2
60 integer, parameter :: klcmt = 3
61 integer, parameter :: klfcm = 4
62 integer, parameter :: kltcm = 5
63
64
65
66 integer, parameter :: kkndf = 0
67 integer, parameter :: kkcmt = 1
68 integer, parameter :: kkebc = 2
69 integer, parameter :: kkstr = 3
70 integer, parameter :: kkidf = 4
71 integer, parameter :: kknui = 5
72 integer, parameter :: kkknd = 6
73 integer, parameter :: kkdpt = 7
74 integer, parameter :: kkpvg = 8
75 integer, parameter :: kkpou = 9
76 integer, parameter :: kkpfr = 10
77 integer, parameter :: kkslh = 11
78 integer, parameter :: kkcou = 12
79 integer, parameter :: kkcfr = 13
80 integer, parameter :: kkcmd = 14
81 integer, parameter :: kkqst = 15
82 integer, parameter :: kkprc = 16
83 integer, parameter :: kkpms = 17
84 integer, parameter :: kkcct = 18
85 integer, parameter :: kkaff = 19
86 integer, parameter :: kkneq = 20
87 integer, parameter :: kkleq = 21
88 integer, parameter :: kkequ = 22
89 integer, parameter :: kkgeq = 23
90 integer, parameter :: kkpts = 24
91 integer, parameter :: kksup = 25
92 integer, parameter :: kkinf = 26
93 integer, parameter :: kksta = 27
94 integer, parameter :: kkpow = 28
95 integer, parameter :: kkdot = 29
96 integer, parameter :: kksep = 30
97 integer, parameter :: kklog = 31
98 integer, parameter :: kkeos = 32
99 integer, parameter :: kkamp = 33
100 integer, parameter :: kkfcm = 34
101 integer, parameter :: kkbnm = 35
102 integer, parameter :: kkdcl = 36
103 integer, parameter :: kklab = 37
104 integer, parameter :: kknuf = 38
105 integer, parameter :: kkpnb = 39
106 integer, parameter :: kkukn = 40
107
108
109 integer, parameter :: nargm = 128
110 integer, parameter :: kkar0 = 50
111 integer, parameter, dimension (0:nargm) :: kkargt = &
112 (/ (kkar0+i, i = 0, nargm) /)
113
114 end module flexprms
115 module flexvars
116
117 use flexprms
118
119 character (len=lsttm), save :: ztoki
120 character (len=linem), dimension (:), pointer, save ::&
121 zbufc
122 integer, dimension (1:lsttm), save :: kktokt
123 integer, dimension (1:lsttm), save :: inamwt
124 integer, dimension (1:lsttm), save :: itokdt
125 integer, dimension (1:lsttm), save :: itokft
126 integer, parameter :: nrepm = lsttm
127 integer, parameter :: nrepgm = 8*nrepm
128 character (len=nrepgm), save :: zrepg
129 integer, dimension (1:nrepm), save :: kkrept
130 integer, dimension (1:nrepm), save :: irepwt
131 integer, dimension (1:nrepm), save :: irepdt
132 integer, dimension (1:nrepm), save :: irepft
133 integer, dimension (1:nrepm), save :: irepnt
134 integer, save :: irepg = 0
135 integer, save :: irep = 0
136 contains
137 subroutine inizbu (nsiz)
138 integer, intent (in) :: nsiz
139
140 allocate (zbufc (nsiz))
141 return
142 end subroutine inizbu
143 subroutine xpdzbu (nsiz)
144 integer, intent (inout) :: nsiz
145 character (len=linem), dimension (:), allocatable :: zbufw
146
147 allocate (zbufw (nsiz))
148 zbufw (1:nsiz) = zbufc (1:nsiz)
149 deallocate (zbufc)
150 allocate (zbufc (2*nsiz))
151 zbufc (1:nsiz) = zbufw (1:nsiz)
152 deallocate (zbufw)
153 nsiz = 2 * nsiz
154 return
155 end subroutine xpdzbu
156 end module flexvars
157 module fprsprms
158
159 use flexprms
160
161
162
163
164 character (len=*), parameter :: zadol = "$"
165 character (len=*), parameter :: zadef = "$DEFINE"
166 character (len=*), parameter :: zaeli = "$ELIF"
167 character (len=*), parameter :: zaels = "$ELSE"
168 character (len=*), parameter :: zaend = "$ENDIF"
169 character (len=*), parameter :: zaevl = "$EVAL"
170 character (len=*), parameter :: zaifx = "$IF"
171 character (len=*), parameter :: zaifd = "$IFDEF"
172 character (len=*), parameter :: zaifn = "$IFNDEF"
173 character (len=*), parameter :: zainc = "$INCLUDE"
174 character (len=*), parameter :: zamcr = "$MACRO"
175 character (len=*), parameter :: zaund = "$UNDEF"
176
177
178
179 integer, parameter :: kcbeg = 0
180 integer, parameter :: kcbex = 1
181 integer, parameter :: kcblb = 2
182 integer, parameter :: kcbnb = 3
183 integer, parameter :: kccmd = 4
184 integer, parameter :: kcntf = 5
185 integer, parameter :: kcwtx = 6
186 integer, parameter :: kcwtf = 7
187 integer, parameter :: kcwti = 8
188 integer, parameter :: kcdcl = 9
189 integer, parameter :: kccas = 10
190 integer, parameter :: kcntt = 11
191 integer, parameter :: kcipl = 12
192 integer, parameter :: kcuse = 13
193 integer, parameter :: kcprc = 14
194 integer, parameter :: kcall = 15
195 integer, parameter :: kcife = 16
196 integer, parameter :: kcass = 17
197 integer, parameter :: kcbcl = 18
198 integer, parameter :: kcdcp = 19
199 integer, parameter :: kcukn = 39
200 integer, parameter :: kcany = 40
201
202
203
204
205 integer, parameter :: krukn = 0
206 integer, parameter :: krlst = 1
207 integer, parameter :: krstr = 2
208 integer, parameter :: krpou = 3
209 integer, parameter :: krany = 4
210
211
212
213 type namtyp
214 integer :: ihshf
215 integer :: irepc
216 integer :: kwnam
217 integer :: inamd
218 integer :: inamf
219 integer :: inamod
220 integer :: inamof
221 end type namtyp
222
223
224
225 integer, parameter :: nnamm = 8192
226 integer, parameter :: lnama = 6
227
228
229
230 integer, parameter :: kwnul = 0
231
232
233
234 integer, parameter :: kwcmd = 1
235 integer, parameter :: kwlop = 2
236 integer, parameter :: kwlct = 3
237 integer, parameter :: kwfmb = 4
238 integer, parameter :: kwiok = 5
239 integer, parameter :: kwatt = 6
240 integer, parameter :: kwaca = 7
241 integer, parameter :: kwgnn = 8
242 integer, parameter :: kwprc = 9
243 integer, parameter :: kwctn = 10
244 integer, parameter :: kwdef = 11
245 integer, parameter :: kwnta = 12
246 integer, parameter :: kwass = 13
247 integer, parameter :: kwac2 = 14
248 integer, parameter :: kwfmt = 15
249 integer, parameter :: kwsts = 16
250 integer, parameter :: kwtoa = 17
251 integer, parameter :: kwac3 = 18
252 integer, parameter :: kwac4 = 19
253 integer, parameter :: kwsel = 20
254 integer, parameter :: kwaio = 21
255 integer, parameter :: kwac5 = 22
256 integer, parameter :: kwacd = 23
257 integer, parameter :: kweli = 24
258 integer, parameter :: kwenp = 25
259 integer, parameter :: kwenf = 26
260 integer, parameter :: kwent = 27
261 integer, parameter :: kwfct = 28
262 integer, parameter :: kwhol = 29
263 integer, parameter :: kwifp = 30
264 integer, parameter :: kwipl = 31
265 integer, parameter :: kwntt = 32
266 integer, parameter :: kwntf = 33
267 integer, parameter :: kwnon = 34
268 integer, parameter :: kwac6 = 35
269 integer, parameter :: kwuse = 36
270 integer, parameter :: kwnly = 37
271 integer, parameter :: kwpps = 38
272 integer, parameter :: kwrsl = 39
273 integer, parameter :: kwstt = 40
274 integer, parameter :: kwthn = 41
275 integer, parameter :: kwbcl = 42
276 integer, parameter :: kwwhl = 43
277 integer, parameter :: kwels = 44
278 integer, parameter :: kweni = 45
279 integer, parameter :: kwend = 46
280 integer, parameter :: kwens = 47
281 integer, parameter :: kwenw = 48
282 integer, parameter :: kwwhe = 49
283 integer, parameter :: kwelw = 50
284 integer, parameter :: kwcas = 51
285 integer, parameter :: kwtyp = 52
286 integer, parameter :: kwfra = 53
287 integer, parameter :: kwena = 54
288 integer, parameter :: kwgto = 55
289 integer, parameter :: kwpat = 56
290 integer, parameter :: kwdta = 57
291 integer, parameter :: kwsys = 255
292
293
294
295 integer, parameter :: kwvar = 256
296 integer, parameter :: kwntr = 257
297 integer, parameter :: kwlab = 258
298 integer, parameter :: kwblk = 259
299 integer, parameter :: kwdfd = 260
300 integer, parameter :: kwext = 261
301 integer, parameter :: kwpdn = 262
302 integer, parameter :: kwpds = 263
303
304
305
306 integer, parameter :: kwmc0 = 280
307 integer, parameter, dimension (0:nargm) :: kwmcrt = &
308 (/ (kwmc0+i, i = 0, nargm) /)
309
310
311
312 integer, parameter :: ksukn = 0
313 integer, parameter :: ksprs = 1
314 integer, parameter :: ksprm = 2
315 integer, parameter :: kspre = 3
316 integer, parameter :: ksifs = 4
317 integer, parameter :: ksifm = 5
318 integer, parameter :: ksife = 6
319 integer, parameter :: kswhs = 7
320 integer, parameter :: kswhm = 8
321 integer, parameter :: kswhe = 9
322 integer, parameter :: ksdos = 10
323 integer, parameter :: ksdoe = 11
324 integer, parameter :: ksnts = 12
325 integer, parameter :: ksnte = 13
326 integer, parameter :: kssls = 14
327 integer, parameter :: ksslm = 15
328 integer, parameter :: kssle = 16
329 integer, parameter :: kstys = 17
330 integer, parameter :: kstye = 18
331 integer, parameter :: ksifp = 19
332 integer, parameter :: ksppr = 20
333 integer, parameter :: ksfrs = 21
334 integer, parameter :: ksfre = 22
335 integer, parameter :: ksuse = 23
336 integer, parameter :: ksexe = 24
337 integer, parameter :: ksdcl = 25
338 integer, parameter :: ksany = 26
339 integer, parameter :: ksipl = 27
340
341 end module fprsprms
342 module fprsvars
343
344 use fprsprms
345
346
347
348
349 integer, save :: iwdol
350 integer, save :: iwdef
351 integer, save :: iweli
352 integer, save :: iwels
353 integer, save :: iwend
354 integer, save :: iwevl
355 integer, save :: iwifx
356 integer, save :: iwifd
357 integer, save :: iwifn
358 integer, save :: iwinc
359 integer, save :: iwmcr
360 integer, save :: iwund
361
362
363
364 character (len=nnamm*lnama), save :: znamg
365 integer, save :: inamg = 0
366
367
368
369 character (len=nnamm*lnama*2), save :: znamo
370 integer, save :: inamo = 0
371
372
373
374 type (namtyp), dimension (1:nnamm), save :: tnamt = &
375 (/ (namtyp (0, 0, 0, 0, 0, 0, 0), i = 1, nnamm) /)
376 integer, save :: ialt = nnamm + 1
377
378 end module fprsvars
379 module fxprprms
380
381 use flexprms
382
383 type opropd
384 double precision dval
385 integer koprd
386 integer iprv
387 integer inxt
388 end type opropd
389
390
391
392 character (len=*), parameter :: zoand = ".AND."
393 integer, save :: iwand
394 character (len=*), parameter :: zoequ = ".EQ."
395 integer, save :: iwequ
396 character (len=*), parameter :: zogeq = ".GE."
397 integer, save :: iwgeq
398 character (len=*), parameter :: zogth = ".GT."
399 integer, save :: iwgth
400 character (len=*), parameter :: zoleq = ".LE."
401 integer, save :: iwleq
402 character (len=*), parameter :: zolth = ".LT."
403 integer, save :: iwlth
404 character (len=*), parameter :: zoneq = ".NE."
405 integer, save :: iwneq
406 character (len=*), parameter :: zonot = ".NOT."
407 integer, save :: iwnot
408 character (len=*), parameter :: zoori = ".OR."
409 integer, save :: iwori
410
411 character (len=*), parameter :: zotru = ".TRUE."
412 integer, save :: iwtru
413 character (len=*), parameter :: zofls = ".FALSE."
414 integer, save :: iwfls
415
416 character (len=*), parameter :: zoint = "INT"
417 integer, save :: iwint
418 character (len=*), parameter :: zonin = "NINT"
419 integer, save :: iwnin
420 character (len=*), parameter :: zosin = "SIN"
421 integer, save :: iwsin
422 character (len=*), parameter :: zocos = "COS"
423 integer, save :: iwcos
424 character (len=*), parameter :: zotan = "TAN"
425 integer, save :: iwtan
426 character (len=*), parameter :: zoatn = "ATAN"
427 integer, save :: iwatn
428 character (len=*), parameter :: zolog = "LOG"
429 integer, save :: iwlog
430 character (len=*), parameter :: zoexp = "EXP"
431 integer, save :: iwexp
432 character (len=*), parameter :: zol10 = "LOG10"
433 integer, save :: iwl10
434 character (len=*), parameter :: zosqr = "SQRT"
435 integer, save :: iwsqr
436 character (len=*), parameter :: zomod = "MOD"
437 integer, save :: iwmod
438 character (len=*), parameter :: zomax = "MAX"
439 integer, save :: iwmax
440 character (len=*), parameter :: zomin = "MIN"
441 integer, save :: iwmin
442 character (len=*), parameter :: zoat2 = "ATAN2"
443 integer, save :: iwat2
444 character (len=*), parameter :: zoasn = "ASIN"
445 integer, save :: iwasn
446 character (len=*), parameter :: zoacs = "ACOS"
447 integer, save :: iwacs
448 character (len=*), parameter :: zosnh = "SINH"
449 integer, save :: iwsnh
450 character (len=*), parameter :: zocsh = "COSH"
451 integer, save :: iwcsh
452 character (len=*), parameter :: zotnh = "TANH"
453 integer, save :: iwtnh
454 character (len=*), parameter :: zoabs = "ABS"
455 integer, save :: iwabs
456 character (len=*), parameter :: zoknd = "KIND"
457 integer, save :: iwknd
458 character (len=*), parameter :: zosik = "SELECTED_INT_KIND"
459 integer, save :: iwsik
460 character (len=*), parameter :: zosrk = "SELECTED_REAL_KIND"
461 integer, save :: iwsrk
462
463
464
465 character (len=*), parameter :: zofcm = "FPPR_FALSE_CMT"
466 integer, save :: iwfcm
467 character (len=*), parameter :: zocsk = "FPPR_KWD_CASE"
468 integer, save :: iwcsk
469 character (len=*), parameter :: zocsu = "FPPR_USR_CASE"
470 integer, save :: iwcsu
471 character (len=*), parameter :: zofxi = "FPPR_FXD_IN"
472 integer, save :: iwfxi
473 character (len=*), parameter :: zofxo = "FPPR_FXD_OUT"
474 integer, save :: iwfxo
475 character (len=*), parameter :: zosed = "FPPR_USE_SHARP"
476 integer, save :: iwsed
477 character (len=*), parameter :: zomll = "FPPR_MAX_LINE"
478 integer, save :: iwmll
479 character (len=*), parameter :: zoids = "FPPR_STP_INDENT"
480 integer, save :: iwids
481 character (len=*), parameter :: zolnb = "FPPR_NMBR_LINES"
482 integer, save :: iwlnb
483
484 character (len=*), parameter :: zalve = "FPPR_LEAVE"
485 integer, save :: iwlve
486 character (len=*), parameter :: zalwr = "FPPR_LOWER"
487 integer, save :: iwlwr
488 character (len=*), parameter :: zaupr = "FPPR_UPPER"
489 integer, save :: iwupr
490
491
492
493
494 integer, parameter :: kondf = 0
495 integer, parameter :: konul = 13
496 integer, parameter :: konui = 19
497 integer, parameter :: konuf = 25
498 integer, parameter :: konot = 33
499 integer, parameter :: koori = 34
500 integer, parameter :: koand = 35
501 integer, parameter :: kogth = 36
502 integer, parameter :: kogeq = 37
503 integer, parameter :: koequ = 38
504 integer, parameter :: kolth = 39
505 integer, parameter :: koleq = 40
506 integer, parameter :: koneq = 41
507 integer, parameter :: komns = 42
508 integer, parameter :: kopls = 43
509 integer, parameter :: komlt = 44
510 integer, parameter :: kodiv = 45
511 integer, parameter :: kopow = 46
512 integer, parameter :: koint = 47
513 integer, parameter :: konin = 48
514 integer, parameter :: kosin = 49
515 integer, parameter :: kocos = 50
516 integer, parameter :: kotan = 51
517 integer, parameter :: koatn = 52
518 integer, parameter :: kolog = 53
519 integer, parameter :: koexp = 54
520 integer, parameter :: kol10 = 55
521 integer, parameter :: kosqr = 56
522 integer, parameter :: komod = 57
523 integer, parameter :: komax = 58
524 integer, parameter :: komin = 59
525 integer, parameter :: koat2 = 60
526 integer, parameter :: koasn = 61
527 integer, parameter :: koacs = 62
528 integer, parameter :: kosnh = 63
529 integer, parameter :: kocsh = 64
530 integer, parameter :: kotnh = 65
531 integer, parameter :: koabs = 66
532 integer, parameter :: koknd = 67
533 integer, parameter :: kosik = 68
534 integer, parameter :: kosrk = 69
535 integer, parameter :: kouds = 90
536 integer, parameter :: kosep = 91
537 integer, parameter :: kopou = 92
538 integer, parameter :: kopfr = 93
539 integer, parameter :: komodi = 94
540 integer, parameter :: komaxi = 95
541 integer, parameter :: komini = 96
542 integer, parameter :: koat2i = 97
543 integer, parameter :: kosrki = 98
544 integer, parameter :: koukn = 99
545
546 end module fxprprms
547 module fxprvars
548
549 use flexprms
550 use fxprprms
551
552
553 integer, parameter :: nxptm = lsttm
554 integer, parameter :: nxptgm = 8*nxptm
555 type (opropd), dimension (1:nxptm), save :: oxptt
556 integer, save :: ixpt = 0
557
558 end module fxprvars
559 module fpprprms
560
561
562
563
564
565 integer, parameter :: kclwr = -1
566 integer, parameter :: kcupr = 1
567 integer, parameter :: kclve = 0
568 character (len=26), parameter :: zlwr="abcdefghijklmnopqrstuvwxyz"
569 character (len=26), parameter :: zupr="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
570
571
572
573 integer, parameter :: luerr = 0
574 integer, parameter :: lufil = 6
575 integer, parameter :: lustdi = 5
576 integer, parameter :: lufic0 = 7
577
578
579
580 integer, parameter :: ncmtim = 16
581 integer, parameter :: lcmtim = 8
582
583
584
585 integer, parameter :: nnstdm = 64
586
587
588
589 integer, parameter :: nnsttm = 64
590
591
592
593 integer, parameter :: nnstim = 16
594 integer, parameter :: lzficm = 96
595
596
597
598 integer, parameter :: nlabdm = 16
599 integer, parameter :: llabdm = 5
600
601 end module fpprprms
602 module fpprcurs
603 use fpprprms
604 use flexprms
605
606
607 character (len=1) :: zblk = '!'
608 character (len=2*linem+1), save :: zlinb
609 character (len=2*linem+1), dimension (nnstim), save :: zlinbh
610
611 integer, save :: nhav = 0
612 integer, dimension (nnstim), save :: nhavh
613 integer, save :: klrea = klunv
614 integer, save :: klnxt = klunv
615 integer, dimension (nnstim), save :: klnxth
616 integer, save :: ifskp = 0
617 integer, dimension (0:nnstim), save :: nlinit = &
618 (/ (0, i = 0, nnstim) /)
619 integer, save :: linel = 72
620 integer, save :: nndt = 0
621 integer, save :: nndtp = 3
622 integer, save :: lprc = 0
623 integer, save :: luinp = lustdi
624 integer, save :: lufic = lufic0
625 integer, save :: iclev = 0
626 character (len=lzficm), dimension (0:nnstim), save :: zficit = &
627 (/ "standard input", &
628 (" ", i = 1, nnstim) /)
629
630
631
632
633 integer, save :: iffxd = 0
634 integer, save :: iffxf = 0
635 integer, save :: iflnb = 0
636
637
638
639 integer, save :: ifsed = 0
640
641
642
643 integer, save :: kccask = kclve
644 integer, save :: kccasu = kclve
645
646
647
648 integer, save :: ncmti = 0
649 character (len=lcmtim), dimension (ncmtim), save :: zcmtit
650
651
652
653
654 integer, save :: nlabd = 0
655 integer, save :: ndoe = 0
656 character (len=llabdm), dimension (nlabdm), save :: zlabdt
657
658 end module fpprcurs
659 module faibprms
660
661
662
663 character (len=*), parameter :: zsub = "Subroutine"
664 character (len=*), parameter :: zfun = "Function"
665 character (len=*), parameter :: zitf = "Interface"
666 character (len=*), parameter :: zeif = "End Interface"
667 character (len=*), parameter :: zend = "End"
668 character (len=*), parameter :: zdim = "Dimension"
669 character (len=*), parameter :: zlen = "Len"
670 character (len=*), parameter :: zxtn = "External"
671 integer, parameter :: nattm = 64
672
673 end module faibprms
674 module faibvars
675
676 use faibprms
677 use flexprms
678 character (len=lnamm), save :: zprci
679 character (len=2*nattm*lnamm*nargm), save :: zargi
680 integer, dimension (1:nargm), save :: nattt
681 integer, dimension (1:nargm), save :: kargit
682 integer, dimension (1:2*nattm,1:nargm), save :: kkattt
683 integer, dimension (1:2*nattm,1:nargm), save :: iattdt
684 integer, dimension (1:2*nattm,1:nargm), save :: iattft
685 integer, dimension (1:2*nattm,1:nargm), save :: iattnt
686 integer, save :: nargi
687 integer, save :: iargi
688
689 end module faibvars
690 module faibcurs
691 use faibprms
692 use fpprcurs
693
694
695 integer, save :: ifexe = 0
696 integer, save :: lctn = -1
697 integer, save :: kfct = 0
698
699 end module faibcurs
700 program f90aib
701
702
703
704 use faibidnt
705 use fpprcurs
706 use fxprprms
707 interface
708 subroutine aibtok (ztok, ltok, kktok)
709
710 use flexvars
711 use faibcurs
712 integer, intent (in) :: ltok, kktok
713 character (len=ltok), intent (in) :: ztok
714 end subroutine aibtok
715 end interface
716
717
718
719
720
721
722
723 call ininam
724 call inicmd
725 call inixpr
726
727
728
729 = 1
730 = 0
731 do
732 if (iffxd == 0) then
733 call lexlin (aibtok, ifstp, ksta)
734 else
735 call lexfxd (aibtok, ifstp, ksta)
736 endif
737 if (ksta /= 0) exit
738 enddo
739
740 end program f90aib
741 subroutine lexlin (trttok, ifstp, ksta)
742
743
744 use flexprms
745 use fpprcurs
746 interface
747 subroutine trttok (ztok, ltok, kktok)
748
749 use flexvars
750 use fpprcurs
751 integer, intent (in) :: ltok, kktok
752 character (len=ltok), intent (in) :: ztok
753 end subroutine trttok
754 end interface
755 integer, intent (in) :: ifstp
756 integer, intent (out) :: ksta
757
758 character (len=2*linem) :: zlin
759 character (len=lsttm) :: ztok
760 character (len=1) :: zdlm, zchr
761
762 = 0
763 ifcnt = 0
764 ifchc = 0
765 ntok = 0
766 kktok = kkndf
767
768 body: do
769 do
770 if (klrea == kllst .or. klrea == kltcm) then
771 if (ifcnt /= 0) then
772 ksta = 2
773 call fpperr ("Unexpected end of input")
774 exit body
775 else
776 if (iclev > 0) then
777 zlinb = zlinbh (iclev)
778 nhav = nhavh (iclev)
779 klnxt = klnxth (iclev)
780 iclev = iclev - 1
781 close (lufic)
782 lufic = lufic - 1
783 if (iclev == 0) then
784 luinp = lustdi
785 else
786 luinp = lufic
787 endif
788 else
789 ksta = -1
790 exit body
791 endif
792 endif
793 endif
794
795
796
797 call realin (luinp, zlin, klrea)
798 if (klrea == klunv .and. iclev /= 0) then
799 klrea = kllst
800 cycle
801 endif
802 exit
803 enddo
804
805 select case (klrea)
806 case (klunv)
807 ksta = 1
808 call fpperr ("Problem reading input")
809 exit body
810 case default
811 ksta = 0
812 end select
813
814
815
816 = len_trim (zlin)
817 if (llin == 0) then
818 call trttok ("!", 1, kkcmt)
819 if (ifcnt == 0) then
820 exit body
821 else
822 cycle body
823 endif
824 endif
825 ilin = verify (zlin (1:llin), ztab // " ")
826 cmtl: do
827 if (ilin /= 0) then
828 if (zlin (ilin:ilin) /= "!") then
829 exit cmtl
830 endif
831
832
833
834 do icmti = 1, ncmti
835 lcmti = len_trim (zcmtit (icmti))
836 ilini = ilin + lcmti - 1
837 if (llin > ilini .and. &
838 zlin (ilin:ilini) == zcmtit (icmti)(1:lcmti)) then
839 call trttok (zlin (ilin:ilini), lcmti, kkfcm)
840 ilin = ilini + 1
841 exit cmtl
842 endif
843 enddo
844 endif
845 if (ifcnt == 0) then
846 call trttok (zlin, llin, kkcmt)
847 exit body
848 else
849 call trttok (zlin, llin, kkebc)
850 cycle body
851 endif
852 enddo cmtl
853
854
855
856 if (ifcnt /= 0) then
857 if (zlin (ilin:ilin) == "&") then
858 ilin = ilin + 1
859 else
860 if (ifchc /= 0) then
861 ksta = 3
862 call fpperr ("Illegal continuation for string")
863 exit body
864 else
865 if (kktok /= kkndf) then
866 call trttok (ztok, ltok, kktok)
867 endif
868 kktok = kkndf
869 endif
870 endif
871 endif
872
873 ifcnt = 0
874 ichr = ilin - 1
875
876
877
878 do
879 do
880 if (ichr >= llin) then
881 if (ifcnt == 0) then
882 if (kktok /= kkndf) then
883 call trttok (ztok, ltok, kktok)
884 endif
885 exit body
886 else
887 cycle body
888 endif
889 endif
890 ichr = ichr + 1
891 zchr = zlin (ichr:ichr)
892 if (ifchc == 0) then
893 select case (zchr)
894
895
896
897 case (ztab,' ')
898 if (kktok /= kkndf) then
899 call trttok (ztok, ltok, kktok)
900 endif
901 kktok = kkndf
902
903
904
905 case ('A':'Z','a':'z')
906 if (kktok == kkidf .or. kktok == kkcmd) then
907 ltok = ltok + 1
908 ztok (ltok:ltok) = zchr
909 else
910 if (kktok /= kkndf) then
911 call trttok (ztok, ltok, kktok)
912 endif
913 ntok = ntok + 1
914 ltok = 1
915 ztok (ltok:ltok) = zchr
916 kktok = kkidf
917 endif
918
919
920
921 case ('0':'9')
922 if (kktok == kkidf .or. kktok == kknui) then
923 ltok = ltok + 1
924 ztok (ltok:ltok) = zchr
925 else
926 if (kktok /= kkndf) then
927 call trttok (ztok, ltok, kktok)
928 endif
929 ntok = ntok + 1
930 ltok = 1
931 ztok (ltok:ltok) = zchr
932 kktok = kknui
933 endif
934
935
936
937 case ('_')
938 select case (kktok)
939 case (kkidf)
940 ltok = ltok + 1
941 ztok (ltok:ltok) = zchr
942 case (kknui, kkstr)
943 call trttok (ztok, ltok, kktok)
944 ntok = ntok + 1
945 call trttok (zchr, 1, kkknd)
946 kktok = kkndf
947 case default
948 if (kktok /= kkndf) then
949 call trttok (ztok, ltok, kktok)
950 endif
951 ntok = ntok + 1
952 ltok = 1
953 ztok (ltok:ltok) = zchr
954 kktok = kkidf
955 end select
956
957
958
959 case (':')
960 if (kktok /= kkndf) then
961 call trttok (ztok, ltok, kktok)
962 endif
963 ntok = ntok + 1
964 call trttok (zchr, 1, kkdpt)
965 kktok = kkndf
966
967
968
969 case (';')
970 if (kktok /= kkndf) then
971 call trttok (ztok, ltok, kktok)
972 endif
973 ntok = ntok + 1
974 call trttok (zchr, 1, kkpvg)
975 kktok = kkndf
976
977
978
979 case ('(')
980 if (kktok /= kkndf) then
981 call trttok (ztok, ltok, kktok)
982 endif
983 ntok = ntok + 1
984 ltok = 1
985 ztok (ltok:ltok) = zchr
986 kktok = kkpou
987
988
989
990 case (')')
991 if (kktok == kkslh) then
992 ltok = ltok + 1
993 ztok (ltok:ltok) = zchr
994 call trttok (ztok, ltok, kkcfr)
995 kktok = kkndf
996 else
997 if (kktok /= kkndf) then
998 call trttok (ztok, ltok, kktok)
999 endif
1000 ntok = ntok + 1
1001 call trttok (zchr, 1, kkpfr)
1002 kktok = kkndf
1003 endif
1004
1005
1006
1007 case ('!')
1008 if (kktok /= kkndf .and. ifcnt == 0) then
1009 call trttok (ztok, ltok, kktok)
1010 endif
1011 if (ifcnt == 0) then
1012 ntok = ntok + 1
1013 call trttok (zlin (ichr:llin), (llin-ichr+1),&
1014 kkcmt)
1015 exit body
1016 else
1017 if (ifstp == 0) &
1018 call wrtstt (zlin, 0, zlin, 0, &
1019 zlin (ichr:llin), &
1020 llin - ichr + 1, ichr-1)
1021 cycle body
1022 endif
1023
1024
1025
1026 case ('$')
1027 if (kktok /= kkndf) then
1028 call trttok (ztok, ltok, kktok)
1029 endif
1030 ntok = ntok + 1
1031 ltok = 1
1032 ztok (ltok:ltok) = '$'
1033 kktok = kkcmd
1034
1035
1036
1037 case ('#')
1038 if (ifsed /= 0) then
1039 if (kktok /= kkndf) then
1040 call trttok (ztok, ltok, kktok)
1041 endif
1042 ntok = ntok + 1
1043 ltok = 1
1044 ztok (ltok:ltok) = '$'
1045 kktok = kkcmd
1046 else
1047 if (kktok /= kkndf .and. ifcnt == 0) then
1048 call trttok (ztok, ltok, kktok)
1049 endif
1050 if (ifcnt == 0) then
1051 ntok = ntok + 1
1052 call trttok (zlin (ichr:llin),&
1053 (llin-ichr+1), kkcmt)
1054 exit body
1055 else
1056 if (ifstp == 0) &
1057 call wrtstt (zlin, 0, zlin, 0, &
1058 zlin (ichr:llin), &
1059 llin - ichr + 1, ichr-1)
1060 cycle body
1061 endif
1062 endif
1063
1064
1065
1066 case ('?')
1067 if (kktok /= kkndf) then
1068 call trttok (ztok, ltok, kktok)
1069 endif
1070 ntok = ntok + 1
1071 call trttok (zchr, 1, kkqst)
1072 kktok = kkndf
1073
1074
1075
1076 case ('&')
1077 ifcnt = 1
1078 if (ichr < llin) then
1079 inxt = verify (zlin (ichr+1:llin), &
1080 ztab // " ")
1081 if (inxt /= 0) then
1082 if (zlin (ichr+inxt:ichr+inxt) /= "!") then
1083 if (kktok /= kkndf) then
1084 call trttok (ztok, ltok, kktok)
1085 endif
1086 ntok = ntok + 1
1087 call trttok (zchr, 1, kkamp)
1088 kktok = kkndf
1089 ifcnt = 0
1090 endif
1091 endif
1092 endif
1093
1094
1095
1096 case ('%')
1097 if (kktok /= kkndf) then
1098 call trttok (ztok, ltok, kktok)
1099 endif
1100 ntok = ntok + 1
1101 call trttok (zchr, 1, kkprc)
1102 kktok = kkndf
1103
1104
1105
1106 case ('+','-')
1107 if (kktok /= kkndf) then
1108 call trttok (ztok, ltok, kktok)
1109 endif
1110 ntok = ntok + 1
1111 call trttok (zchr, 1, kkpms)
1112 kktok = kkndf
1113
1114
1115
1116 case ('/')
1117 select case (kktok)
1118 case (kkslh)
1119 ltok = ltok + 1
1120 ztok (ltok:ltok) = zchr
1121 call trttok (ztok, ltok, kkcct)
1122 kktok = kkndf
1123 case (kkpou)
1124 ltok = ltok + 1
1125 ztok (ltok:ltok) = zchr
1126 call trttok (ztok, ltok, kkcou)
1127 kktok = kkndf
1128 case default
1129 if (kktok /= kkndf) then
1130 call trttok (ztok, ltok, kktok)
1131 endif
1132 ntok = ntok + 1
1133 ltok = 1
1134 ztok (ltok:ltok) = zchr
1135 kktok = kkslh
1136 end select
1137
1138
1139
1140 case ('*')
1141 if (kktok == kksta) then
1142 ltok = ltok + 1
1143 ztok (ltok:ltok) = zchr
1144 call trttok (ztok, ltok, kkpow)
1145 kktok = kkndf
1146 else
1147 if (kktok /= kkndf) then
1148 call trttok (ztok, ltok, kktok)
1149 endif
1150 ntok = ntok + 1
1151 ltok = 1
1152 ztok (ltok:ltok) = zchr
1153 kktok = kksta
1154 endif
1155
1156
1157
1158 case ('>')
1159 if (kktok == kkaff) then
1160 ltok = ltok + 1
1161 ztok (ltok:ltok) = zchr
1162 call trttok (ztok, ltok, kkpts)
1163 kktok = kkndf
1164 else
1165 if (kktok /= kkndf) then
1166 call trttok (ztok, ltok, kktok)
1167 endif
1168 ntok = ntok + 1
1169 ltok = 1
1170 ztok (ltok:ltok) = zchr
1171 kktok = kksup
1172 endif
1173
1174
1175
1176 case ('<')
1177 if (kktok /= kkndf) then
1178 call trttok (ztok, ltok, kktok)
1179 endif
1180 ntok = ntok + 1
1181 ltok = 1
1182 ztok (ltok:ltok) = zchr
1183 kktok = kkinf
1184
1185
1186
1187 case ('=')
1188 select case (kktok)
1189 case (kkslh)
1190 ltok = ltok + 1
1191 ztok (ltok:ltok) = zchr
1192 call trttok (ztok, ltok, kkneq)
1193 kktok = kkndf
1194 case (kkinf)
1195 ltok = ltok + 1
1196 ztok (ltok:ltok) = zchr
1197 call trttok (ztok, ltok, kkleq)
1198 kktok = kkndf
1199 case (kkaff)
1200 ltok = ltok + 1
1201 ztok (ltok:ltok) = zchr
1202 call trttok (ztok, ltok, kkequ)
1203 kktok = kkndf
1204 case (kksup)
1205 ltok = ltok + 1
1206 ztok (ltok:ltok) = zchr
1207 call trttok (ztok, ltok, kkgeq)
1208 kktok = kkndf
1209 case default
1210 if (kktok /= kkndf) then
1211 call trttok (ztok, ltok, kktok)
1212 endif
1213 ntok = ntok + 1
1214 ltok = 1
1215 ztok (ltok:ltok) = zchr
1216 kktok = kkaff
1217 end select
1218
1219
1220
1221 case ('.')
1222 if (kktok /= kkndf) then
1223 call trttok (ztok, ltok, kktok)
1224 endif
1225 ntok = ntok + 1
1226 call trttok (zchr, 1, kkdot)
1227 kktok = kkndf
1228
1229
1230
1231 case (',')
1232 if (kktok /= kkndf) then
1233 call trttok (ztok, ltok, kktok)
1234 endif
1235 ntok = ntok + 1
1236 call trttok (zchr, 1, kksep)
1237 kktok = kkndf
1238
1239
1240
1241 case ('"',"'")
1242 if (kktok == kkstr) then
1243 if (zchr == zdlm) then
1244 ltok = ltok + 1
1245 ztok (ltok:ltok) = zchr
1246 else
1247 zdlm = zchr
1248 ltok = 1
1249 ztok (ltok:ltok) = zchr
1250 ntok = ntok + 1
1251 endif
1252 ifchc = 1
1253 else
1254 if (kktok /= kkndf) then
1255 call trttok (ztok, ltok, kktok)
1256 endif
1257 if (ichr == llin) then
1258 call fpperr ("Unmatched " // zchr)
1259 else
1260 zdlm = zchr
1261 ltok = 1
1262 ztok (ltok:ltok) = zchr
1263 ntok = ntok + 1
1264 kktok = kkstr
1265 ifchc = 1
1266 endif
1267 endif
1268
1269
1270
1271 case default
1272 if (kktok /= kkndf) then
1273 call trttok (ztok, ltok, kktok)
1274 endif
1275 ntok = ntok + 1
1276 call trttok (zchr, 1, kkukn)
1277 kktok = kkndf
1278 end select
1279
1280
1281
1282 else
1283
1284
1285
1286 if (zchr == zdlm) then
1287 ltok = ltok + 1
1288 ztok (ltok:ltok) = zchr
1289 ifchc = 0
1290 else
1291
1292
1293
1294 if (ichr == llin) then
1295 if (zchr == '&') then
1296 ifcnt = 1
1297 cycle body
1298 else
1299 call fpperr ("Unmatched " // zdlm)
1300 endif
1301 else
1302 ltok = ltok + 1
1303 ztok (ltok:ltok) = zchr
1304 endif
1305 endif
1306 endif
1307 enddo
1308 enddo
1309 enddo body
1310 call trttok (ztok, 0, kkeos)
1311 return
1312 end subroutine lexlin
1313 subroutine aibtok (ztok, ltok, kktok)
1314
1315 use flexvars
1316 use fpprcurs
1317 character (len=ltok), intent (in) :: ztok
1318 integer, intent (in) :: ltok, kktok
1319
1320 integer, save :: ntok = 0
1321 integer, save :: itokf = 0
1322 integer, save :: itokd
1323
1324
1325
1326 if (kktok == kkebc) then
1327 return
1328 endif
1329
1330
1331
1332 if (ltok > 0) then
1333 ntok = ntok + 1
1334 itokd = itokf + 1
1335 itokf = itokf + ltok
1336 kktokt (ntok) = kktok
1337 ztoki (itokd:itokf) = ztok (1:ltok)
1338 itokdt (ntok) = itokd
1339 itokft (ntok) = itokf
1340 endif
1341
1342
1343
1344 if (kktok == kkpvg) then
1345 ntok = ntok - 1
1346 endif
1347 if ((kktok == kkpvg .or. kktok == kkeos) .and. &
1348 (ntok > 0) ) then
1349 call trtstt (ntok, ksstt)
1350 ntok = 0
1351 itokf = 0
1352 endif
1353 return
1354 end subroutine aibtok
1355 subroutine rdcstt (ntok)
1356
1357 use flexvars
1358 use fprsvars
1359 use fpprprms
1360 integer, intent (inout) :: ntok
1361
1362
1363 character (len=1) :: zchr
1364 interface
1365 logical function ifsame (zstr1, zstr2)
1366
1367 character (len=*), intent (in) :: zstr1, zstr2
1368 end function ifsame
1369 end interface
1370
1371
1372
1373
1374
1375
1376
1377
1378 if (index (ztoki (1:itokft(ntok)), '.') /= 0) then
1379 itok = 3
1380 do
1381 itok = itok + 1
1382 if (itok > ntok) exit
1383 if (kktokt (itok) == kkdot) then
1384 if (kktokt (itok-2) == kkdot .and. &
1385 kktokt (itok-1) == kkidf .and. &
1386 verify (ztoki (itokdt(itok-1):itokft(itok-1)), &
1387 zlwr//zupr) == 0) then
1388 kktokt (itok-2) = kkidf
1389 itokft (itok-2) = itokft (itok)
1390 itok2 = itok - 2
1391 do itok1 = itok + 1, ntok
1392 itok2 = itok2 + 1
1393 kktokt (itok2) = kktokt (itok1)
1394 itokdt (itok2) = itokdt (itok1)
1395 itokft (itok2) = itokft (itok1)
1396 enddo
1397 ntok = itok2
1398 endif
1399 endif
1400 enddo
1401
1402
1403
1404 = 3
1405 do
1406 itok = itok + 1
1407 if (itok > ntok) exit
1408 if (kktokt (itok) == kknui) then
1409 if (kktokt (itok-2) == kknui .and. &
1410 kktokt (itok-1) == kkdot) then
1411 itokft (itok-2) = itokft (itok)
1412 itok2 = itok - 2
1413 kktokt (itok2) = kknuf
1414 do itok1 = itok + 1, ntok
1415 itok2 = itok2 + 1
1416 kktokt (itok2) = kktokt (itok1)
1417 itokdt (itok2) = itokdt (itok1)
1418 itokft (itok2) = itokft (itok1)
1419 enddo
1420 ntok = itok2
1421 endif
1422 endif
1423 enddo
1424
1425
1426
1427 = 2
1428 do
1429 itok = itok + 1
1430 if (itok > ntok) exit
1431 if (kktokt (itok) == kkdot) then
1432 if (kktokt (itok-1) == kknui) then
1433 itokft (itok-1) = itokft (itok)
1434 itok2 = itok - 1
1435 kktokt (itok2) = kknuf
1436 do itok1 = itok + 1, ntok
1437 itok2 = itok2 + 1
1438 kktokt (itok2) = kktokt (itok1)
1439 itokdt (itok2) = itokdt (itok1)
1440 itokft (itok2) = itokft (itok1)
1441 enddo
1442 ntok = itok2
1443 endif
1444 endif
1445 enddo
1446
1447
1448
1449 = 2
1450 do
1451 itok = itok + 1
1452 if (itok > ntok) exit
1453 if (kktokt (itok) == kknui) then
1454 if (kktokt (itok-1) == kkdot) then
1455 itokft (itok-1) = itokft (itok)
1456 kktokt (itok-1) = kknuf
1457 itok2 = itok - 1
1458 do itok1 = itok + 1, ntok
1459 itok2 = itok2 + 1
1460 kktokt (itok2) = kktokt (itok1)
1461 itokdt (itok2) = itokdt (itok1)
1462 itokft (itok2) = itokft (itok1)
1463 enddo
1464 ntok = itok2
1465 endif
1466 endif
1467 enddo
1468 endif
1469
1470
1471
1472 = 2
1473 do
1474 itok = itok + 1
1475 if (itok > ntok) exit
1476 if (kktokt (itok) == kkidf .and. &
1477 (kktokt (itok-1) == kknui) .or. &
1478 (kktokt (itok-1) == kknuf) ) then
1479
1480
1481
1482
1483
1484
1485 = ztoki (itokdt(itok):itokdt(itok))
1486 if (index ("EeDd", zchr) /= 0) then
1487 itok1 = itok + 1
1488 if (itok1 < ntok) then
1489 if ( itokdt(itok) == itokft(itok) .and. &
1490 kktokt (itok1) == kkpms ) then
1491 itok1 = itok1 + 1
1492 if (kktokt (itok1) == kknui) then
1493
1494 (itok-1) = itokft (itok1)
1495 kktokt (itok-1) = kknuf
1496 itok2 = itok-1
1497 do itok1 = itok1 + 1, ntok
1498 itok2 = itok2 + 1
1499 kktokt (itok2) = kktokt (itok1)
1500 itokdt (itok2) = itokdt (itok1)
1501 itokft (itok2) = itokft (itok1)
1502 enddo
1503 ntok = itok2
1504 cycle
1505 endif
1506 endif
1507 endif
1508 if (itok1 <= ntok) then
1509 if (itokdt (itok) == itokft (itok) .and. &
1510 kktokt (itok1) == kknui ) then
1511
1512 (itok-1) = itokft (itok1)
1513 kktokt (itok-1) = kknuf
1514 itok2 = itok-1
1515 do itok1 = itok1 + 1, ntok
1516 itok2 = itok2 + 1
1517 kktokt (itok2) = kktokt (itok1)
1518 itokdt (itok2) = itokdt (itok1)
1519 itokft (itok2) = itokft (itok1)
1520 enddo
1521 ntok = itok2
1522 cycle
1523 endif
1524 endif
1525 if (itokdt (itok) < itokft (itok)) then
1526 inumf = verify (ztoki(itokdt(itok)+1:itokft(itok)),&
1527 "0123456789")
1528 if (inumf == 0) then
1529
1530 (itok-1) = itokft (itok)
1531 kktokt (itok-1) = kknuf
1532 itok2 = itok-1
1533 do itok1 = itok + 1, ntok
1534 itok2 = itok2 + 1
1535 kktokt (itok2) = kktokt (itok1)
1536 itokdt (itok2) = itokdt (itok1)
1537 itokft (itok2) = itokft (itok1)
1538 enddo
1539 ntok = itok2
1540 else
1541 inumf1 = itokdt(itok) + inumf
1542 if (inumf1 > itokdt(itok) + 1 .and. &
1543 ztoki (inumf1:inumf1) == '_' .and. &
1544 inumf1 < itokft(itok) ) then
1545
1546 (itok-1) = inumf1 - 1
1547 kktokt (itok-1) = kknuf
1548 itok2 = ntok + 2
1549 do itok1 = ntok, itok, -1
1550 itok2 = itok2 - 1
1551 kktokt (itok2) = kktokt (itok1)
1552 itokdt (itok2) = itokdt (itok1)
1553 itokft (itok2) = itokft (itok1)
1554 enddo
1555 itokdt (itok) = inumf1
1556 itokft (itok) = inumf1
1557 kktokt (itok) = kkknd
1558 itok = itok + 1
1559 itokdt (itok) = inumf1 + 1
1560 inumf2 = verify ( &
1561 ztoki (itokdt(itok):itokft(itok)), &
1562 "0123456789")
1563 if (inumf2 == 0) then
1564 kktokt (itok) = kknui
1565 else
1566 kktokt (itok) = kkidf
1567 endif
1568 ntok = ntok + 1
1569 itok = itok + 1
1570 endif
1571 endif
1572 endif
1573 elseif (zchr == '_' .and. &
1574 itokdt (itok) < itokft (itok)) then
1575
1576 = ntok + 2
1577 do itok1 = ntok, itok, -1
1578 itok2 = itok2 - 1
1579 kktokt (itok2) = kktokt (itok1)
1580 itokdt (itok2) = itokdt (itok1)
1581 itokft (itok2) = itokft (itok1)
1582 enddo
1583 itokft (itok) = itokdt (itok)
1584 kktokt (itok) = kkknd
1585 itokdt (itok+1) = itokft (itok) + 1
1586 itok = itok + 1
1587 inumf2 = verify (ztoki (itokdt(itok):itokft(itok)), &
1588 "0123456789")
1589 if (inumf2 == 0) then
1590 kktokt (itok) = kknui
1591 else
1592 kktokt (itok) = kkidf
1593 endif
1594 ntok = ntok + 1
1595 itok = itok + 1
1596 endif
1597 endif
1598 enddo
1599
1600
1601
1602 = 2
1603 itok1 = 2
1604 do
1605 itok = itok + 1
1606 if (itok > ntok) exit
1607 if ((kktokt (itok) == kknui .and. kktokt (itok1) == kknui) .or.&
1608 (kktokt (itok) == kknuf .and. kktokt (itok1) == kknui) .or.&
1609 (kktokt (itok) == kknui .and. kktokt (itok1) == kknuf)) then
1610 itokft (itok1) = itokft (itok)
1611 else
1612 itok1 = itok1 + 1
1613 if (itok1 < itok) then
1614 kktokt (itok1) = kktokt (itok)
1615 itokdt (itok1) = itokdt (itok)
1616 itokft (itok1) = itokft (itok)
1617 endif
1618 endif
1619 enddo
1620 if (itok1 < ntok) ntok = itok1
1621
1622
1623
1624 = 2
1625 nparl = 0
1626 do
1627 itok = itok + 1
1628 if (itok > ntok) exit
1629 if (kktokt (itok) == kkpou) then
1630 nparl = nparl + 1
1631 cycle
1632 elseif (kktokt (itok) == kkpfr) then
1633 nparl = nparl - 1
1634 cycle
1635 elseif (nparl > 0) then
1636 cycle
1637 endif
1638 if (kktokt (itok) == kkdpt .and. &
1639 kktokt (itok-1) == kkdpt) then
1640 itokft (itok-1) = itokft (itok)
1641 kktokt (itok-1) = kkdcl
1642 do itok1 = itok + 1, ntok
1643 kktokt (itok1-1) = kktokt (itok1)
1644 itokdt (itok1-1) = itokdt (itok1)
1645 itokft (itok1-1) = itokft (itok1)
1646 enddo
1647 ntok = ntok - 1
1648 exit
1649 endif
1650 enddo
1651
1652
1653
1654
1655 = 1
1656 itok1 = 1
1657 expl: do
1658 itok = itok + 1
1659 if (itok > ntok) exit expl
1660 if (kktokt (itok) == kkidf .and. &
1661 kktokt (itok1) == kkidf) then
1662 itokd = itokdt (itok1)
1663 itokf = itokft (itok)
1664 ihsh = khshstr (ztoki (itokd:itokf))
1665 if (tnamt(ihsh)%kwnam /= 0 .and. &
1666 tnamt(ihsh)%kwnam <= kwsys) then
1667 do
1668 inamd = tnamt(ihsh)%inamd
1669 inamf = tnamt(ihsh)%inamf
1670 if (ifsame (ztoki (itokd:itokf), &
1671 znamg (inamd:inamf))) then
1672 itokft (itok1) = itokft (itok)
1673 do itok2 = itok+1, ntok
1674 kktokt (itok2-1) = kktokt (itok2)
1675 itokdt (itok2-1) = itokdt (itok2)
1676 itokft (itok2-1) = itokft (itok2)
1677 enddo
1678 itok = itok - 1
1679 ntok = ntok - 1
1680 cycle expl
1681 endif
1682 if (tnamt(ihsh)%ihshf /= 0) then
1683 ihsh = tnamt(ihsh)%ihshf
1684 else
1685 exit
1686 endif
1687 enddo
1688 endif
1689 endif
1690 itok1 = itok1 + 1
1691 enddo expl
1692
1693
1694
1695 = 4
1696 do
1697 itok = itok + 1
1698 if (itok > ntok) exit
1699 if (kktokt (itok) == kkprc) then
1700 if (kktokt (itok-1) == kkpfr) then
1701 npar = 1
1702 do itok1 = itok - 3, 2, -1
1703 if (kktokt (itok1) == kkpfr) npar = npar + 1
1704 if (kktokt (itok1) == kkpou .or. &
1705 kktokt (itok1) == kkpnb) then
1706 npar = npar - 1
1707 if (npar == 0) then
1708 kktokt (itok1) = kkpnb
1709 exit
1710 endif
1711 endif
1712 enddo
1713 endif
1714 if ((itok+2) < ntok) then
1715 if (kktokt (itok+2) == kkpou) kktokt (itok+2) = kkpnb
1716 endif
1717 itok = itok + 1
1718 endif
1719 enddo
1720 return
1721 end subroutine rdcstt
1722 subroutine trtstt (ntok, ksstt)
1723
1724 use flexvars
1725 use fprsvars
1726 use faibcurs
1727 use faibvars
1728 integer, intent (inout) :: ntok
1729 integer, intent (out) :: ksstt
1730
1731
1732 integer, save :: kctxc = kcbeg
1733
1734 = 1
1735 kctok = kctxc
1736 ksstt = ksukn
1737
1738
1739
1740 if (kktokt (itoks) == kkcmd) then
1741 itokd = itokdt (itoks)
1742 itokf = itokft (itoks)
1743 call tstidf (ztoki (itokd:itokf), kcbeg, krukn, kwidf, &
1744 inamwt (itoks))
1745 call trtcmd (inamwt (itoks), ntok)
1746 return
1747 endif
1748
1749
1750
1751 if (ntok == 0) then
1752 return
1753 elseif (ntok == 1 .and. kktokt (1) == kkcmt) then
1754 return
1755 elseif (ntok == 1 .and. kktokt (1) == kkebc) then
1756 return
1757 elseif (ntok == 1 .and. kktokt (1) == kkfcm) then
1758 return
1759 endif
1760
1761
1762
1763 if (ifexe > 0) then
1764 kwnam = kwnul
1765 if (kktokt (itoks) == kkidf) then
1766 itokd = itokdt (itoks)
1767 itokf = itokft (itoks)
1768 call tstidf (ztoki (itokd:itokf), kcany, krany, kwnam, &
1769 inamwt (itoks))
1770 if (kwnam /= kwenp .and. &
1771 kwnam /= kwctn .and. &
1772 kwnam /= kwenf .and. &
1773 kwnam /= kwntf) return
1774 else
1775 return
1776 endif
1777
1778
1779
1780 if (ntok > itoks) call rdcstt (ntok)
1781 if (kktokt (itoks) == kkidf) then
1782 itokd = itokdt (itoks)
1783 itokf = itokft (itoks)
1784 ihsh = khshstr (ztoki (itokd:itokf))
1785 kwnam = tnamt(ihsh)%kwnam
1786 if (kwnam /= kwenp .and. &
1787 kwnam /= kwctn .and. &
1788 kwnam /= kwenf .and. &
1789 kwnam /= kwntf) return
1790
1791
1792
1793 if (kwnam == kwenp) then
1794 if (lctn == 0) call outitf
1795 if (lctn >= 0 ) lctn = lctn - 1
1796 if (lctn < -1 ) lctn = lctn + 1
1797 ifexe = 0
1798 elseif (kwnam == kwctn) then
1799 ifexe = 0
1800 endif
1801 endif
1802
1803
1804
1805 elseif (ifexe == 0) then
1806
1807
1808
1809 call rghprs (kswrk)
1810
1811
1812
1813 select case (lctn)
1814 case (:-2)
1815
1816 select case (kswrk)
1817 case (ksprs, kstys, ksnts)
1818 lctn = lctn - 1
1819 case (kspre, kstye, ksnte)
1820 lctn = lctn + 1
1821 case (ksprm)
1822 ifexe = 0
1823 case default
1824 continue
1825 end select
1826
1827 case (-1)
1828
1829 select case (kswrk)
1830 case (ksprs)
1831
1832
1833
1834 call subfct (ifnew)
1835 if (ifnew == 0) then
1836 lctn = lctn - 1
1837 else
1838 lctn = 0
1839 kfct = ifnew
1840 call newitf
1841 endif
1842 case (kstys, ksnts)
1843 lctn = lctn - 1
1844 case (kspre, kstye, ksnte)
1845 lctn = lctn + 1
1846 case (ksprm)
1847 ifexe = 0
1848 case (ksexe)
1849 ifexe = 1
1850 case default
1851 continue
1852 end select
1853
1854 case (0)
1855
1856 select case (kswrk)
1857 case (ksprs)
1858 lctn = 1
1859 case (kstys)
1860
1861
1862
1863
1864 = 1
1865 case (ksnts)
1866
1867
1868
1869
1870 if (nargi > 0) then
1871 ifexe = -1
1872 call chkitf (ifarg)
1873 if (ifarg /= 0) then
1874 call bdyitf (ksnts)
1875 lctn = -1
1876 endif
1877 else
1878 lctn = 1
1879 endif
1880 case (kstye, ksnte)
1881 lctn = -1
1882 case (kspre)
1883 call outitf
1884 lctn = -1
1885 case (ksprm)
1886 ifexe = 0
1887 case (ksexe)
1888 ifexe = 1
1889
1890
1891
1892 case (ksipl)
1893 if (nargi > 0) call bdyitf (kswrk)
1894 case (ksuse)
1895 if (nargi > 0) then
1896 call chkuse (ifarg)
1897 if (ifarg /= 0) call bdyitf (kswrk)
1898 endif
1899 case default
1900 if (nargi > 0) call chkdcl
1901 end select
1902
1903
1904 case (1:)
1905
1906
1907
1908 select case (kswrk)
1909 case (ksprs, kstys, ksnts)
1910 lctn = lctn + 1
1911 case (kspre, kstye, ksnte)
1912 lctn = lctn - 1
1913 case (ksprm)
1914 ifexe = 0
1915
1916
1917 case default
1918 continue
1919 end select
1920 end select
1921 else
1922
1923
1924
1925 call rghprs (kswrk)
1926
1927
1928
1929 select case (lctn)
1930 case (:-1)
1931
1932 call bdyitf (kswrk)
1933 select case (kswrk)
1934 case (ksprs, ksnts)
1935 lctn = lctn - 1
1936 case (kspre)
1937 lctn = lctn + 1
1938 if (lctn == 0) call enditf
1939 case (ksnte)
1940 lctn = lctn + 1
1941 if (lctn == 0) ifexe = 0
1942 case default
1943 continue
1944 end select
1945
1946 case (0)
1947
1948 select case (kswrk)
1949 case (ksprs)
1950 call itfprc (ifarg)
1951 if (ifarg > 0) then
1952 call heaitf
1953 call bdyitf (ksprs)
1954 lctn = -1
1955 else
1956 lctn = +1
1957 endif
1958 case (ksnte)
1959 ifexe = 0
1960 case default
1961 continue
1962 end select
1963
1964 case (1:)
1965
1966 select case (kswrk)
1967 case (ksprs)
1968 lctn = lctn + 1
1969 case (kspre)
1970 lctn = lctn - 1
1971 case default
1972 continue
1973 end select
1974 end select
1975
1976 endif
1977
1978 return
1979 contains
1980 subroutine rghprs (kode)
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994 = 1
1995 if (ntok > itok) call rdcstt (ntok)
1996
1997
1998
1999 if (kktokt (itok) == kknui) then
2000 kctok = kcblb
2001 itok = itok + 1
2002 endif
2003
2004
2005
2006 if (itok + 1 < ntok) then
2007 if (kktokt (itok+1) == kkdpt .and. &
2008 kktokt (itok) == kkidf) then
2009 kode = ksexe
2010 return
2011 endif
2012 endif
2013
2014
2015
2016 = ksukn
2017 if (kktokt (itok) == kkidf) then
2018 itokd = itokdt (itok)
2019 itokf = itokft (itok)
2020 krtok = krukn
2021 if (itok == ntok) then
2022 krtok = krlst
2023 else
2024 if (kktokt (itok+1) == kkpou .or. &
2025 kktokt (itok+1) == kkpnb) then
2026 krtok = krpou
2027 endif
2028 endif
2029 call tstidf (ztoki (itokd:itokf), kctok, krtok, kwidf, &
2030 inamwt (itok))
2031 select case (kwidf)
2032 case (kwpat, kwprc, kwfct)
2033 kode = ksprs
2034 return
2035 case (kwenp)
2036 kode = kspre
2037 return
2038 case (kwuse)
2039 kode = ksuse
2040 return
2041 case (kwipl)
2042 kode = ksipl
2043 return
2044 case (kwatt)
2045 kctok = kcdcl
2046 case (kwntf)
2047 kode = ksnts
2048 return
2049 case (kwenf)
2050 kode = ksnte
2051 return
2052 case (kwtyp)
2053 if (kktokt (itok+1) == kkpou .or. &
2054 kktokt (itok+1) == kkpnb) then
2055 kctok = kcdcl
2056 else
2057 kode = kstys
2058 return
2059 endif
2060 case (kwent)
2061 kode = kstye
2062 return
2063 case (kwctn)
2064 kode = ksprm
2065 return
2066 case (kwfmt, kwdta, kwpps, kwac5)
2067 kode = ksany
2068 return
2069 case default
2070 kode = ksexe
2071 return
2072 end select
2073 else
2074 kode = ksexe
2075 return
2076 endif
2077
2078
2079 = 0
2080 do itok = itok+1, ntok
2081 if (kktokt (itok) == kkidf .and. lpar == 0) then
2082 itokd = itokdt (itok)
2083 itokf = itokft (itok)
2084 krtok = krukn
2085 if (itok == ntok) then
2086 krtok = krlst
2087 else
2088 if (kktokt (itok+1) == kkpou .or. &
2089 kktokt (itok+1) == kkpnb) then
2090 krtok = krpou
2091 endif
2092 endif
2093 call tstidf (ztoki (itokd:itokf), kctok, krtok, kwidf, &
2094 inamwt (itok))
2095 select case (kwidf)
2096 case (kwatt)
2097 kctok = kcdcl
2098 case (kwpat)
2099 kctok = kcdcp
2100 case (kwprc, kwfct)
2101 kode = ksprs
2102 return
2103 case default
2104 kode = ksdcl
2105 return
2106 end select
2107 elseif (kktokt (itok) == kkpou .or. &
2108 kktokt (itok) == kkpnb) then
2109 lpar = lpar + 1
2110 elseif (kktokt (itok) == kkpfr) then
2111 lpar = lpar - 1
2112 elseif (kktokt (itok) == kkdcl) then
2113 kode = ksdcl
2114 return
2115 elseif (kktokt (itok) == kksep .and. lpar == 0) then
2116 kode = ksdcl
2117 return
2118 endif
2119 enddo
2120 end subroutine rghprs
2121 subroutine subfct (ifprc)
2122 integer, intent (out) :: ifprc
2123
2124
2125
2126 interface ifsame
2127 logical function ifsame (zstr1, zstr2)
2128
2129 character (len=*), intent (in) :: zstr1, zstr2
2130 end function ifsame
2131 end interface
2132 itok = 1
2133 ifprc = 0
2134 kctok = kctxc
2135 find: do
2136 if (itok >= ntok) exit
2137 if (kktokt (itok) == kkidf) then
2138 itokd = itokdt (itok)
2139 itokf = itokft (itok)
2140 ihsh = khshstr (ztoki (itokd:itokf))
2141 if (tnamt(ihsh)%kwnam == 0) then
2142 ifprc = 0
2143 exit find
2144 else
2145 do
2146 inamd = tnamt(ihsh)%inamd
2147 inamf = tnamt(ihsh)%inamf
2148 if (ifsame (ztoki (itokd:itokf), znamg (inamd:inamf)))&
2149 exit
2150 if (tnamt(ihsh)%ihshf == 0) then
2151 ifprc = 0
2152 exit find
2153 else
2154 ihsh = tnamt(ihsh)%ihshf
2155 endif
2156 enddo
2157 if (tnamt(ihsh)%kwnam == kwprc) then
2158 if (ifsame (ztoki (itokd:itokf), zsub)) then
2159 ifprc = 2
2160 else
2161 ifprc = 0
2162 endif
2163 exit find
2164 elseif (tnamt(ihsh)%kwnam == kwfct) then
2165 ifprc = 1
2166 exit find
2167 else
2168 itok = itok + 1
2169 if (tnamt(ihsh)%kwnam == kwtyp &
2170 .or. tnamt(ihsh)%kwnam == kwatt) then
2171 if (kktokt (itok) == kksta) then
2172 itok = itok + 1
2173 if (itok >= ntok) then
2174 ifprc = 0
2175 exit find
2176 endif
2177 if (kktokt (itok) == kknui) then
2178 itok = itok + 1
2179 cycle find
2180 endif
2181 endif
2182 lpar = 0
2183 do
2184 if (kktokt (itok) == kkpou) then
2185 lpar = lpar + 1
2186 elseif (kktokt (itok) == kkpfr) then
2187 lpar = lpar - 1
2188 else
2189 if (lpar == 0) cycle find
2190 endif
2191 itok = itok + 1
2192 if (lpar == 0) cycle find
2193 if (itok >= ntok) then
2194 ifprc = 0
2195 exit find
2196 endif
2197 enddo
2198 endif
2199 cycle find
2200 endif
2201 endif
2202 else
2203 ifprc = 0
2204 exit find
2205 endif
2206 enddo find
2207
2208 if (ifprc /= 1 .and. ifprc /= 2) return
2209 call tstidf (ztoki (itokd:itokf), kcany, krany, kwwrk, inamwt (itok))
2210 itok = itok + 1
2211 if (itok > ntok) then
2212 ifprc = 0
2213 return
2214 endif
2215 if (kktokt (itok) /= kkidf) then
2216 ifprc = 0
2217 return
2218 endif
2219 itokd = itokdt (itok)
2220 itokf = itokft (itok)
2221 zprci = ztoki (itokd:itokf)
2222 call tstidf (zprci, kcany, krany, kwwrk, inamwt (itok))
2223 if (ifprc == 1) then
2224 nargi = 1
2225 call iniarg (nargi, itok)
2226 else
2227 nargi = 0
2228 endif
2229
2230
2231
2232 = itok + 1
2233 if (itok > ntok) return
2234 if (kktokt (itok) /= kkpou) then
2235 ifprc = 0
2236 return
2237 endif
2238 do
2239 itok = itok + 1
2240 if (itok > ntok) then
2241 ifprc = 0
2242 return
2243 endif
2244 if (kktokt (itok) == kkpfr) exit
2245 if (kktokt (itok) == kkidf) then
2246 itokd = itokdt (itok)
2247 itokf = itokft (itok)
2248 nargi = nargi + 1
2249 if (nargi > nargm) then
2250 call fpperr ("Too many arguments")
2251 call fpperr ("raise nargm and try again")
2252 endif
2253 call tstidf (ztoki (itokd:itokf), kcany, krany, kwwrk, &
2254 inamwt (itok))
2255 call iniarg (nargi, itok)
2256 elseif (kktokt (itok) /= kksta) then
2257 = 0
2258 return
2259 endif
2260 itok = itok + 1
2261 if (itok > ntok) then
2262 ifprc = 0
2263 return
2264 endif
2265 if (kktokt (itok) == kkpfr) exit
2266 if (kktokt (itok) /= kksep) then
2267 ifprc = 0
2268 return
2269 endif
2270 enddo
2271 if (ifprc == 1 .and. itok < ntok) then
2272 itok = itok + 1
2273 if (kktokt (itok) == kkidf) then
2274 = itokdt (itok)
2275 itokf = itokft (itok)
2276 call tstidf (ztoki (itokd:itokf), kcany, krany, kwwrk, &
2277 inamwt (itok))
2278 else
2279 ifprc = 0
2280 return
2281 endif
2282 itok = itok + 1
2283 if (itok > ntok) then
2284 ifprc = 0
2285 return
2286 endif
2287 if (kktokt (itok) /= kkpou) then
2288 ifprc = 0
2289 return
2290 endif
2291 itok = itok + 1
2292 if (kktokt (itok) == kkidf) then
2293 = itokdt (itok)
2294 itokf = itokft (itok)
2295 call tstidf (ztoki (itokd:itokf), kcany, krany, kwwrk, &
2296 inamwt (itok))
2297 nargi = nargi + 1
2298 if (nargi > nargm) then
2299 call fpperr ("Too many arguments")
2300 call fpperr ("raise nargm and try again")
2301 endif
2302 call iniarg (nargi, itok)
2303 else
2304 ifprc = 0
2305 return
2306 endif
2307 itok = itok + 1
2308 if (itok > ntok) then
2309 ifprc = 0
2310 return
2311 endif
2312 if (kktokt (itok) /= kkpfr) then
2313 ifprc = 0
2314 return
2315 endif
2316 endif
2317
2318 end subroutine subfct
2319 subroutine chkitf (ifarg)
2320 integer, intent (out) :: ifarg
2321
2322
2323
2324 = 0
2325
2326 = 2
2327 if (itok > ntok) return
2328 if (kktokt (itok) == kkidf) then
2329 itokd = itokdt (itok)
2330 itokf = itokft (itok)
2331 ihsh = indhsh (ztoki (itokd:itokf))
2332 do iarg = 1, nargi
2333 if (ihsh == kargit (iarg)) then
2334 ifarg = iarg
2335 exit
2336 endif
2337 enddo
2338 endif
2339
2340 return
2341
2342 end subroutine chkitf
2343 subroutine chkuse (ifarg)
2344 integer, intent (out) :: ifarg
2345
2346
2347
2348
2349
2350
2351
2352 = 1
2353 return
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373 end subroutine chkuse
2374 subroutine itfprc (ifarg)
2375 integer, intent (out) :: ifarg
2376
2377
2378
2379 interface
2380 logical function ifsame (zstr1, zstr2)
2381
2382 character (len=*), intent (in) :: zstr1, zstr2
2383 end function ifsame
2384 end interface
2385
2386 = 0
2387
2388 = 1
2389 ifprc = 0
2390 kctok = kctxc
2391 find: do
2392 if (itok >= ntok) exit
2393 if (kktokt (itok) == kkidf) then
2394 itokd = itokdt (itok)
2395 itokf = itokft (itok)
2396 ihsh = khshstr (ztoki (itokd:itokf))
2397 if (tnamt(ihsh)%kwnam == 0) then
2398 ifprc = 0
2399 exit find
2400 else
2401 do
2402 inamd = tnamt(ihsh)%inamd
2403 inamf = tnamt(ihsh)%inamf
2404 if (ifsame (ztoki (itokd:itokf), znamg (inamd:inamf)))&
2405 exit
2406 if (tnamt(ihsh)%ihshf == 0) then
2407 ifprc = 0
2408 exit find
2409 else
2410 ihsh = tnamt(ihsh)%ihshf
2411 endif
2412 enddo
2413 if (tnamt(ihsh)%kwnam == kwprc) then
2414 if (ifsame (ztoki (itokd:itokf), zsub)) then
2415 ifprc = 2
2416 else
2417 ifprc = 0
2418 endif
2419 exit find
2420 elseif (tnamt(ihsh)%kwnam == kwfct) then
2421 ifprc = 1
2422 exit find
2423 else
2424 itok = itok + 1
2425 if (tnamt(ihsh)%kwnam == kwtyp) then
2426 lpar = 0
2427 do
2428 if (kktokt (itok) == kkpou) then
2429 lpar = lpar + 1
2430 elseif (kktokt (itok) == kkpfr) then
2431 lpar = lpar - 1
2432 endif
2433 itok = itok + 1
2434 if (lpar == 0) cycle find
2435 if (itok >= ntok) then
2436 ifprc = 0
2437 exit find
2438 endif
2439 enddo
2440 endif
2441 cycle find
2442 endif
2443 endif
2444 else
2445 ifprc = 0
2446 exit find
2447 endif
2448 enddo find
2449
2450 if (ifprc /= 1 .and. ifprc /= 2) return
2451 itok = itok + 1
2452 if (itok > ntok) then
2453 ifprc = 0
2454 return
2455 endif
2456 if (kktokt (itok) /= kkidf) then
2457 ifprc = 0
2458 return
2459 endif
2460 itokd = itokdt (itok)
2461 itokf = itokft (itok)
2462 ihsh = indhsh (ztoki (itokd:itokf))
2463 do iarg = 1, nargi
2464 if (ihsh == kargit (iarg)) then
2465 ifarg = iarg
2466 exit
2467 endif
2468 enddo
2469
2470 end subroutine itfprc
2471 subroutine iniarg (iarg, itok)
2472
2473
2474
2475 integer, intent (in) :: iarg, itok
2476
2477 (iarg) = 0
2478 kargit (iarg) = inamwt (itok)
2479 iattnt (:,iarg) = 0
2480 end subroutine iniarg
2481 subroutine newitf
2482
2483
2484
2485 call heaitf
2486 call outstt (ntok, ksprs)
2487
2488 = 0
2489
2490 end subroutine newitf
2491 subroutine heaitf
2492
2493
2494
2495 character (len=len(zitf)) :: zwrk
2496
2497 = zitf
2498 if (kccask /= kclve) then
2499 call chgcas (zwrk, kccask)
2500 endif
2501
2502 call wrtstt (zwrk, 0, zwrk, len_trim (zwrk), zwrk, 0, nndt)
2503 lprc = lprc + 1
2504 nndt = nndt + nndtp
2505
2506 end subroutine heaitf
2507 subroutine enditf
2508
2509
2510
2511 character (len=len(zeif)) :: zwrk
2512
2513 = zeif
2514 if (kccask /= kclve) then
2515 call chgcas (zwrk, kccask)
2516 endif
2517
2518 = nndt - nndtp
2519 call wrtstt (zwrk, 0, zwrk, len_trim (zwrk), zwrk, 0, nndt)
2520 lprc = lprc - 1
2521
2522 end subroutine enditf
2523 subroutine outitf
2524
2525
2526
2527 integer, dimension (1:nargm) :: iargit
2528 interface
2529 subroutine outtks (kktknt, itkndt, itknft, itknnt, ztkni, ksstt)
2530
2531 use flexvars
2532 use fprsvars
2533 use fpprcurs
2534 character (len=*), intent (in) :: ztkni
2535 integer, intent (in), dimension (:) :: kktknt, itkndt, itknft, itknnt
2536 integer, intent (in) :: ksstt
2537 end subroutine outtks
2538 end interface
2539 interface ifsame
2540 logical function ifsame (zstr1, zstr2)
2541
2542 character (len=*), intent (in) :: zstr1, zstr2
2543 end function ifsame
2544 end interface
2545
2546
2547
2548 (1:nargi) = (/ (i, i=1,nargi) /)
2549 iargw = 1
2550 iswp = 0
2551 args: do
2552 if (iargw > nargi) exit
2553 iarg = iargit (iargw)
2554 natt = nattt (iarg)
2555 do iatt = 1, natt
2556 if (kkattt (iatt, iarg) == kkidf) then
2557 iattn = iattnt (iatt, iarg)
2558 kwnam = tnamt(iattn)%kwnam
2559
2560 do iarg1 = iargw + 1, nargi
2561 if (iattn == kargit (iargit (iarg1)) .and. &
2562 iswp /= iarg1) then
2563 iargit (iargw) = iargit (iarg1)
2564 iargit (iarg1) = iarg
2565 iswp = iarg1
2566 cycle args
2567 endif
2568 enddo
2569
2570 endif
2571 enddo
2572 iargw = iargw + 1
2573 iswp = 0
2574 enddo args
2575
2576
2577
2578 do iargw = 1, nargi
2579 iarg = iargit (iargw)
2580 natt = nattt (iarg)
2581 if (natt > 0) then
2582
2583
2584
2585 if (natt /= 1 .or. &
2586 (.not.ifsame (zargi (iattdt(1,iarg):iattft(1,iarg)), zxtn))) then
2587 if (zargi(iargi:iargi) /= ',') then
2588 natt = natt + 1
2589 iargi = iargi + 1
2590 iattdt (natt, iarg) = iargi
2591 endif
2592 iargf = iargi + 1
2593 iattft (natt, iarg) = iargf
2594 kkattt (natt, iarg) = kkdcl
2595 zargi (iargi:iargf) = "::"
2596 iargi = iargf
2597 endif
2598 natt = natt + 1
2599 inamd = tnamt(kargit(iarg))%inamod
2600 inamf = tnamt(kargit(iarg))%inamof
2601 iargi = iargi + 1
2602 iattdt (natt, iarg) = iargi
2603 iargf = iargi + inamf - inamd
2604 iattft (natt, iarg) = iargf
2605 kkattt (natt, iarg) = kkidf
2606 zargi (iargi:iargf) = znamo (inamd:inamf)
2607 iattnt (natt, iarg) = kargit(iarg)
2608 iargi = iargf
2609 call outtks (kkattt (1:natt, iarg), iattdt (1:natt, iarg), &
2610 iattft (1:natt, iarg), iattnt (1:natt, iarg), &
2611 zargi, ksdcl)
2612 endif
2613 enddo
2614
2615
2616
2617 do itok = 1, ntok
2618 itokd = itokdt (itok)
2619 itokf = itokft (itok)
2620 call tstidf (ztoki (itokd:itokf), kcany, krany, kwwrk, &
2621 inamwt (itok))
2622 enddo
2623 if (kwwrk > kwsys) then
2624 ifnmd = 1
2625 else
2626 ifnmd = 0
2627 endif
2628 if (ntok == 1 .and. &
2629 (itokft(1)-itokdt(1)) == (len_trim (zend) - 1)) then
2630 itokd = itokdt (ntok)
2631 itokf = itokd + len_trim (zend) - 1
2632 itokft (ntok) = itokf
2633 ztoki (itokd:itokf) = zend
2634 kktokt (ntok) = kkidf
2635 call tstidf (zend, kcany, krany, kwwrk, inamwt (ntok))
2636 ntok = 2
2637 itokd = itokf + 1
2638 itokdt (ntok) = itokd
2639 kktokt (ntok) = kkidf
2640 if (kfct == 1) then
2641 itokf = itokd + len_trim (zfun) - 1
2642 itokft (ntok) = itokf
2643 ztoki (itokd:itokf) = zfun
2644 call tstidf (zfun, kcany, krany, kwwrk, inamwt (ntok))
2645 else
2646 = itokd + len_trim (zsub) - 1
2647 itokft (ntok) = itokf
2648 ztoki (itokd:itokf) = zsub
2649 call tstidf (zsub, kcany, krany, kwwrk, inamwt (ntok))
2650 endif
2651 endif
2652
2653
2654
2655 if (ifnmd == 0) then
2656 ntok = ntok + 1
2657 itokd = itokf + 1
2658 itokf = itokd + len_trim (zprci) - 1
2659 itokdt (ntok) = itokd
2660 itokft (ntok) = itokf
2661 kktokt (ntok) = kkidf
2662 ztoki (itokd:itokf) = zprci
2663 call tstidf (zprci, kcany, krany, kwwrk, inamwt (ntok))
2664 endif
2665 call outstt (ntok, kspre)
2666 call enditf
2667 end subroutine outitf
2668 subroutine bdyitf (ksstti)
2669
2670
2671
2672 integer, intent (in) :: ksstti
2673
2674 do itok = 1, ntok
2675 if (kktokt (itok) == kkidf) then
2676 itokd = itokdt (itok)
2677 itokf = itokft (itok)
2678 call tstidf (ztoki (itokd:itokf), kcany, krany, kwwrk, &
2679 inamwt (itok))
2680 endif
2681 enddo
2682 call outstt (ntok, ksstti)
2683 end subroutine bdyitf
2684 subroutine chkdcl
2685
2686
2687
2688
2689 integer, dimension (1:2*nattm) :: jwrk1, jwrk2
2690 = 0
2691 ifidf = 0
2692 ntoka = 0
2693 itok = 0
2694 do
2695 itok = itok + 1
2696 if (itok > ntok) exit
2697
2698
2699
2700 if (kktokt (itok) == kkidf) then
2701 itokd = itokdt (itok)
2702 itokf = itokft (itok)
2703 inamw = indhsh (ztoki (itokd:itokf))
2704 if (inamw == 0) then
2705 if (natt > 0) then
2706 ifidf = 1
2707 cycle
2708 else
2709 return
2710 endif
2711 endif
2712 kwwrk = tnamt(inamw)%kwnam
2713 select case (kwwrk)
2714 case (kwatt, kwntt, kwtyp)
2715 natt = natt + 1
2716 ntoka = itok
2717 cycle
2718 case default
2719
2720 = 1
2721 do iarg = 1, nargi
2722 if (inamw == kargit (iarg)) then
2723 natt = nattt (iarg)
2724 iargi0 = iargi
2725 natt0 = natt
2726 if (natt /= 0) then
2727 natt = natt + 1
2728 iargi = iargi + 1
2729 iattdt (natt, iarg) = iargi
2730 iattft (natt, iarg) = iargi
2731 kkattt (natt, iarg) = kksep
2732 zargi (iargi:iargi) = ","
2733 endif
2734 do iatt = 1, ntoka
2735 natt = natt + 1
2736 iargi = iargi + 1
2737 iattdt (natt, iarg) = iargi
2738 if (kktokt (iatt) /= kkidf) then
2739 itokd = itokdt (iatt)
2740 itokf = itokft (iatt)
2741 iargf = iargi + itokf - itokd
2742 iattft (natt, iarg) = iargf
2743 kkattt (natt, iarg) = kktokt (iatt)
2744 zargi (iargi:iargf) = ztoki (itokd:itokf)
2745 iargi = iargf
2746 else
2747 itokd = itokdt (iatt)
2748 itokf = itokft (iatt)
2749 call tstidf (ztoki (itokd:itokf), kcany, krany, &
2750 kwwrk, inamw)
2751 if (inamw == indhsh (zdim) .and. ntoka == 1) then
2752 iargi = iargi0
2753 natt = natt0
2754 elseif (inamw > 0) then
2755 if (tnamt(inamw)%kwnam <= kwsys) then
2756 inamd = tnamt(inamw)%inamod
2757 inamf = tnamt(inamw)%inamof
2758 iargf = iargi + inamf - inamd
2759 iattft (natt, iarg) = iargf
2760 kkattt (natt, iarg) = kktokt (iatt)
2761 zargi (iargi:iargf) = znamo (inamd:inamf)
2762 else
2763 iargf = iargi + itokf - itokd
2764 iattft (natt, iarg) = iargf
2765 kkattt (natt, iarg) = kktokt (iatt)
2766 zargi (iargi:iargf) = ztoki (itokd:itokf)
2767 endif
2768 iargi = iargf
2769 else
2770 iargf = iargi + itokf - itokd
2771 iattft (natt, iarg) = iargf
2772 kkattt (natt, iarg) = kktokt (iatt)
2773 zargi (iargi:iargf) = ztoki (itokd:itokf)
2774 iargi = iargf
2775 endif
2776 iattnt (natt, iarg) = inamw
2777 endif
2778 enddo
2779 if (itok < ntok - 2) then
2780 if (kktokt (itok+1) == kkpou) then
2781
2782
2783
2784 = natt + 1
2785 iargi = iargi + 1
2786 iattdt (natt, iarg) = iargi
2787 iattft (natt, iarg) = iargi
2788 kkattt (natt, iarg) = kksep
2789 zargi (iargi:iargi) = ","
2790 natt = natt + 1
2791 iargi = iargi + 1
2792 iattdt (natt, iarg) = iargi
2793 iargf = iargi + len_trim (zdim) - 1
2794 iattft (natt, iarg) = iargf
2795 kkattt (natt, iarg) = kkidf
2796 zargi (iargi:iargf) = zdim
2797 iattnt (natt, iarg) = indhsh (zdim)
2798 iargi = iargf
2799 lpar = 0
2800 do itok = itok+1, ntok
2801 natt = natt + 1
2802 iargi = iargi + 1
2803 iattdt (natt, iarg) = iargi
2804 itokd = itokdt (itok)
2805 itokf = itokft (itok)
2806 iargf = iargi + itokf - itokd
2807 iattft (natt, iarg) = iargf
2808 kkattt (natt, iarg) = kktokt (itok)
2809 zargi (iargi:iargf) = ztoki (itokd:itokf)
2810 iargi = iargf
2811 if (kktokt (itok) == kkidf) then
2812 call tstidf (ztoki (itokd:itokf), &
2813 kcany, krany, kwwrk, &
2814 iattnt (natt, iarg))
2815 elseif (kktokt (itok) == kkpou) then
2816 lpar = lpar + 1
2817 elseif (kktokt (itok) == kkpfr) then
2818 lpar = lpar - 1
2819 if (lpar == 0) exit
2820 endif
2821 enddo
2822 elseif (kktokt (itok+1) == kksta) then
2823
2824
2825
2826 = natt + 1
2827 nattw = natt
2828 iargi = iargi + 1
2829 iattdt (natt, iarg) = iargi
2830 iattft (natt, iarg) = iargi
2831 if (nattw > 2 .and. &
2832 kkattt (2, iarg) == kkpou) then
2833 kkattt (nattw, iarg) = kksep
2834 zargi (iargi:iargi) = ","
2835 ifchq = 1
2836 else
2837 kkattt (natt, iarg) = kkpou
2838 zargi (iargi:iargi) = "("
2839 ifchq = 0
2840 endif
2841 natt = natt + 1
2842 iargi = iargi + 1
2843 iattdt (natt, iarg) = iargi
2844 iargf = iargi + len_trim (zlen) - 1
2845 iattft (natt, iarg) = iargf
2846 kkattt (natt, iarg) = kkidf
2847 zargi (iargi:iargf) = zlen
2848 iattnt (natt, iarg) = indhsh (zlen)
2849 natt = natt + 1
2850 iargi = iargf + 1
2851 iattdt (natt, iarg) = iargi
2852 iattft (natt, iarg) = iargi
2853 kkattt (natt, iarg) = kkaff
2854 zargi (iargi:iargi) = "="
2855 ifudl = 0
2856 if (ntok > itok+3) then
2857 if (kktokt (itok+2) == kkpou .and. &
2858 kktokt (itok+3) == kksta .and. &
2859 kktokt (itok+4) == kkpfr) ifudl = 1
2860 endif
2861 if (ifudl == 0) then
2862 lpar = 0
2863 do itok = itok+2, ntok
2864 natt = natt + 1
2865 iargi = iargi + 1
2866 iattdt (natt, iarg) = iargi
2867 itokd = itokdt (itok)
2868 itokf = itokft (itok)
2869 iargf = iargi + itokf - itokd
2870 iattft (natt, iarg) = iargf
2871 kkattt (natt, iarg) = kktokt (itok)
2872 zargi (iargi:iargf) = ztoki (itokd:itokf)
2873 iattnt (natt, iarg) = indhsh (ztoki (itokd:itokf))
2874 iargi = iargf
2875 if (kktokt (itok) == kkpou) then
2876 lpar = lpar + 1
2877 elseif (kktokt (itok) == kkpfr) then
2878 lpar = lpar - 1
2879 endif
2880 if (lpar == 0) exit
2881 enddo
2882 else
2883
2884
2885
2886 = natt + 1
2887 iargi = iargi + 1
2888 iattdt (natt, iarg) = iargi
2889 iattft (natt, iarg) = iargi
2890 kkattt (natt, iarg) = kksta
2891 zargi (iargi:iargi) = "*"
2892 endif
2893 if (ifchq == 0) then
2894 natt = natt + 1
2895 iargi = iargi + 1
2896 iattdt (natt, iarg) = iargi
2897 iattft (natt, iarg) = iargi
2898 kkattt (natt, iarg) = kkpfr
2899 zargi (iargi:iargi) = ")"
2900 endif
2901
2902
2903
2904 if (nattw > 2) then
2905 if (ifchq == 0) then
2906 iattw = 2
2907 else
2908 lpar = 0
2909 do iattw = 2, nattw
2910 if (kkattt (iattw, iarg) == kkpou) then
2911 lpar = lpar + 1
2912 elseif (kkattt (iattw, iarg) == kkpfr) then
2913 lpar = lpar - 1
2914 endif
2915 if (lpar == 0) exit
2916 enddo
2917 endif
2918 natts = natt-nattw
2919 jwrk1 (1:natts+1) = kkattt (nattw:natt, iarg)
2920 jwrk2 (1:nattw-iattw) = kkattt (iattw:nattw-1, iarg)
2921 kkattt (iattw+natts+1:natt, iarg) = jwrk2 (1:nattw-iattw)
2922 kkattt (iattw:iattw+natts, iarg) = jwrk1 (1:natts+1)
2923 jwrk1 (1:natts+1) = iattdt (nattw:natt, iarg)
2924 jwrk2 (1:nattw-iattw) = iattdt (iattw:nattw-1, iarg)
2925 iattdt (iattw+natts+1:natt, iarg) = jwrk2 (1:nattw-iattw)
2926 iattdt (iattw:iattw+natts, iarg) = jwrk1 (1:natts+1)
2927 jwrk1 (1:natts+1) = iattft (nattw:natt, iarg)
2928 jwrk2 (1:nattw-iattw) = iattft (iattw:nattw-1, iarg)
2929 iattft (iattw+natts+1:natt, iarg) = jwrk2 (1:nattw-iattw)
2930 iattft (iattw:iattw+natts, iarg) = jwrk1 (1:natts+1)
2931 jwrk1 (1:natts+1) = iattnt (nattw:natt, iarg)
2932 jwrk2 (1:nattw-iattw) = iattnt (iattw:nattw-1, iarg)
2933 iattnt (iattw+natts+1:natt, iarg) = jwrk2 (1:nattw-iattw)
2934 iattnt (iattw:iattw+natts, iarg) = jwrk1 (1:natts+1)
2935 endif
2936 endif
2937 endif
2938 nattt (iarg) = natt
2939 exit
2940 endif
2941 enddo
2942 end select
2943 elseif (kktokt (itok) == kkpou) then
2944
2945
2946
2947 = 0
2948 do itok = itok, ntok
2949 if (kktokt (itok) == kkpou) then
2950 lpar = lpar + 1
2951 elseif (kktokt (itok) == kkpfr) then
2952 lpar = lpar - 1
2953 if (lpar == 0) then
2954 if (ifidf == 0) ntoka = itok
2955 exit
2956 endif
2957 endif
2958 enddo
2959 elseif (kktokt (itok) == kkdcl) then
2960 ifidf = 1
2961 endif
2962 enddo
2963 end subroutine chkdcl
2964 end subroutine trtstt
2965 integer function khshstr (zstr)
2966
2967 character (len=*), intent (in) :: zstr
2968
2969 character (len=26), parameter :: zlwc="abcdefghijklmnopqrstuvwxyz"
2970 character (len=26), parameter :: zupc="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
2971
2972 = 0
2973 do istr = 1, len (zstr)
2974 irnk = index (zlwc, zstr (istr:istr))
2975 if (irnk > 0) then
2976 ichr = iachar (zupc (irnk:irnk))
2977 else
2978 ichr = iachar (zstr (istr:istr))
2979 endif
2980 jhsh = jhsh*17 + ichr - 45
2981 jhsh = modulo (jhsh, 4091)
2982 enddo
2983 khshstr = jhsh + 1
2984 return
2985 end function khshstr
2986 subroutine ininam
2987
2988 use fprsvars
2989
2990
2991 ( 1: 1230) = "&
2992 &$$DEFINE$ELIF$ELSE$ENDIF$EVAL$IF$IFDEF$IFNDEF$INCLUDE$MACRO$UNDEF.AND..EQ..EQV..FALSE..GE..GT..LE..LT..NE..NEQV..NOT..OR..TRUE.ABS&
2993 &ACOSASINATANATAN2ACCESSACTIONADVANCEALLOCATABLEALLOCATEASSIGNASSIGNMENTBACKSPACEBLANKBLOCKDATACALLCASECHARACTERCLOSECOMMONCOMPLEXC&
2994 &ONTAINSCONTINUECOSCOSHCYCLEDATADEALLOCATEDEFAULTDELIMDIMENSIONDIRECTDODOUBLEPRECISIONELEMENTALELSEELSEIFELSEWHEREENDENDBLOCKDATAEN&
2995 &DDOENDFILEENDFORALLENDFUNCTIONENDIFENDINTERFACEENDMODULEENDPROGRAMENDSELECTENDSUBROUTINEENDTYPEENDWHEREENTRYEOREQUIVALENCEERREXIST&
2996 &EXITEXPEXTERNALFILEFMTFORALLFORMFORMATFORMATTEDFUNCTIONGOTOHIFIMPLICITININCLUDEINOUTINQUIREINTINTEGERINTENTINTERFACEINTRINSICIOLEN&
2997 >HIOSTATKINDLENLOGLOG10LOGICALMAXMINMODMODULEMODULEPROCEDURENAMENAMEDNAMELISTNEXTRECNINTNMLNONENULLIFYNUMBEROONLYOPENOPENEDOPERAT&
2998 &OROPTIONALOUTPADPARAMETERPAUSEPOINTERPOSITIONPRINTPRIVATEPROCEDUREPROGRAMPUBLICPUREREADREADWRITEREALRECRECLRECURSIVERESULTRETURNRE&
2999 &WINDSAVESINSINHSELECTCASESELECTED_INT_KINDSELECTED_REAL_KINDSEQUENCESEQUENTIALSIZESQRTSTATSTATUSSTOPSUBROUTINETANTANHTARGETTHENTOT&
3000 &YPETYPEUNFORMATTEDUNITUSEWHEREWHILEWRITEFPPR_LEAVEFPPR_LOWERFPPR_UPPERFPPR_FALSE_CMTFPPR_KWD_CASEFPPR_USR_CASEFPPR_FXD_INFPPR_FXD_&
3001 &OUTFPPR_USE_SHARPFPPR_MAX_LINEFPPR_STP_INDENTFPPR_NMBR_LINES"
3002 inamg = 1230
3003
3004 ( 1: 1249) = "&
3005 &$$Define$ElIf$Else$EndIf$Eval$If$IfDef$IfnDef$Include$Macro$UnDef.And..Eq..Eqv..False..Ge..Gt..Le..Lt..Ne..Neqv..Not..Or..True.Abs&
3006 &AcosAsinAtanAtan2AccessActionAdvanceAllocatableAllocateAssignAssignmentBackspaceBlankBlock DataCallCaseCharacterCloseCommonComplex&
3007 &ContainsContinueCosCoshCycleDataDeallocateDefaultDelimDimensionDirectDoDouble PrecisionElementalElseElse IfElsewhereEndEnd Block D&
3008 &ataEnd DoEndfileEnd ForallEnd FunctionEnd IfEnd InterfaceEnd ModuleEnd ProgramEnd SelectEnd SubroutineEnd TypeEnd WhereEntryEorEqu&
3009 &ivalenceErrExistExitExpExternalFileFmtForallFormFormatFormattedFunctionGo ToHIfImplicitInIncludeInoutInquireIntIntegerIntentInterf&
3010 &aceIntrinsicIoLengthIoStatKindLenLogLog10LogicalMaxMinModModuleModule ProcedureNameNamedNamelistNextRecNintNmlNoneNullifyNumberOOn&
3011 &lyOpenOpenedOperatorOptionalOutPadParameterPausePointerPositionPrintPrivateProcedureProgramPublicPureReadReadWriteRealRecReclRecur&
3012 &siveResultReturnRewindSaveSinSinhSelect CaseSelected_Int_KindSelected_Real_KindSequenceSequentialSizeSqrtStatStatusStopSubroutineT&
3013 &anTanhTargetThenToTypeTypeUnformattedUnitUseWhereWhileWriteFPPR_leaveFPPR_lowerFPPR_upperFPPR_false_cmtFPPR_kwd_caseFPPR_usr_caseF&
3014 &PPR_fxd_inFPPR_fxd_outFPPR_use_sharpFPPR_max_lineFPPR_stp_indentFPPR_nmbr_lines"
3015 inamo = 1249
3016
3017 ( 5) = namtyp ( 0, 0, 42, 1071, 1075, 1090, 1094)
3018 tnamt ( 28) = namtyp ( 0, 0, 29, 580, 580, 597, 597)
3019 tnamt ( 35) = namtyp ( 0, 0, 16, 760, 760, 778, 778)
3020 tnamt ( 48) = namtyp ( 0, 0, 6, 637, 645, 654, 662)
3021 tnamt ( 74) = namtyp ( 0, 0, 56, 860, 863, 878, 881)
3022 tnamt ( 92) = namtyp ( 0, 0, 50, 365, 373, 368, 376)
3023 tnamt ( 164) = namtyp ( 0, 0, 263, 1162, 1173, 1181, 1192)
3024 tnamt ( 179) = namtyp ( 0, 0, 21, 1076, 1080, 1095, 1099)
3025 tnamt ( 190) = namtyp ( 0, 0, 2, 71, 74, 71, 74)
3026 tnamt ( 228) = namtyp ( 0, 0, 14, 202, 210, 202, 210)
3027 tnamt ( 274) = namtyp ( 0, 0, 5, 818, 825, 836, 843)
3028 tnamt ( 276) = namtyp ( 0, 0, 1, 25, 29, 25, 29)
3029 tnamt ( 292) = namtyp ( 0, 0, 14, 909, 914, 927, 932)
3030 tnamt ( 325) = namtyp ( 0, 0, 20, 926, 935, 944, 954)
3031 tnamt ( 393) = namtyp ( 8191, 0, 52, 1040, 1043, 1059, 1062)
3032 tnamt ( 426) = namtyp ( 0, 0, 42, 329, 330, 330, 331)
3033 tnamt ( 433) = namtyp ( 0, 0, 5, 716, 720, 734, 738)
3034 tnamt ( 454) = namtyp ( 0, 0, 39, 897, 902, 915, 920)
3035 tnamt ( 458) = namtyp ( 0, 0, 22, 826, 830, 844, 848)
3036 tnamt ( 467) = namtyp ( 0, 0, 6, 797, 805, 815, 823)
3037 tnamt ( 495) = namtyp ( 0, 0, 1, 46, 53, 46, 53)
3038 tnamt ( 502) = namtyp ( 0, 0, 30, 581, 582, 598, 599)
3039 tnamt ( 510) = namtyp ( 0, 0, 12, 591, 592, 608, 609)
3040 tnamt ( 511) = namtyp ( 0, 0, 257, 612, 614, 629, 631)
3041 tnamt ( 557) = namtyp ( 0, 0, 5, 536, 539, 552, 555)
3042 tnamt ( 561) = namtyp ( 0, 0, 5, 646, 653, 663, 670)
3043 tnamt ( 564) = namtyp ( 0, 0, 2, 87, 90, 87, 90)
3044 tnamt ( 568) = namtyp ( 0, 0, 5, 769, 774, 787, 792)
3045 tnamt ( 577) = namtyp ( 0, 0, 22, 593, 599, 610, 616)
3046 tnamt ( 597) = namtyp ( 0, 0, 5, 979, 988, 998, 1007)
3047 tnamt ( 609) = namtyp ( 0, 0, 6, 660, 663, 677, 680)
3048 tnamt ( 651) = namtyp ( 0, 0, 263, 1216, 1230, 1235, 1249)
3049 tnamt ( 698) = namtyp ( 0, 0, 17, 1038, 1039, 1057, 1058)
3050 tnamt ( 719) = namtyp ( 0, 0, 34, 743, 746, 761, 764)
3051 tnamt ( 721) = namtyp ( 0, 0, 44, 355, 358, 357, 360)
3052 tnamt ( 743) = namtyp ( 0, 0, 6, 314, 322, 315, 323)
3053 tnamt ( 747) = namtyp ( 0, 0, 5, 712, 715, 730, 733)
3054 tnamt ( 751) = namtyp ( 0, 0, 25, 466, 478, 479, 492)
3055 tnamt ( 758) = namtyp ( 0, 0, 6, 233, 241, 234, 242)
3056 tnamt ( 767) = namtyp ( 0, 0, 6, 811, 817, 829, 835)
3057 tnamt ( 797) = namtyp ( 0, 0, 8, 775, 782, 793, 800)
3058 tnamt ( 819) = namtyp ( 0, 0, 2, 91, 94, 91, 94)
3059 tnamt ( 822) = namtyp ( 0, 0, 1, 39, 45, 39, 45)
3060 tnamt ( 824) = namtyp ( 0, 0, 57, 288, 291, 289, 292)
3061 tnamt ( 834) = namtyp ( 0, 0, 3, 80, 86, 80, 86)
3062 tnamt ( 852) = namtyp ( 0, 0, 262, 1091, 1100, 1110, 1119)
3063 tnamt ( 895) = namtyp ( 0, 0, 21, 864, 867, 882, 885)
3064 tnamt ( 903) = namtyp ( 0, 0, 6, 877, 880, 895, 898)
3065 tnamt ( 919) = namtyp ( 0, 0, 38, 915, 918, 933, 936)
3066 tnamt ( 924) = namtyp ( 0, 0, 1, 2, 8, 2, 8)
3067 tnamt ( 937) = namtyp ( 0, 0, 5, 884, 887, 902, 905)
3068 tnamt ( 948) = namtyp ( 0, 0, 5, 868, 876, 886, 894)
3069 tnamt ( 966) = namtyp ( 0, 0, 25, 410, 420, 417, 428)
3070 tnamt ( 1050) = namtyp ( 0, 0, 6, 528, 535, 544, 551)
3071 tnamt ( 1128) = namtyp ( 8190, 0, 5, 559, 567, 575, 583)
3072 tnamt ( 1219) = namtyp ( 0, 0, 6, 664, 666, 681, 683)
3073 tnamt ( 1238) = namtyp ( 0, 0, 37, 761, 764, 779, 782)
3074 tnamt ( 1240) = namtyp ( 0, 0, 8, 192, 201, 192, 201)
3075 tnamt ( 1293) = namtyp ( 0, 0, 32, 622, 627, 639, 644)
3076 tnamt ( 1317) = namtyp ( 0, 0, 9, 847, 853, 865, 871)
3077 tnamt ( 1326) = namtyp ( 0, 0, 19, 268, 275, 269, 276)
3078 tnamt ( 1333) = namtyp ( 0, 0, 2, 107, 112, 107, 112)
3079 tnamt ( 1372) = namtyp ( 0, 0, 22, 903, 908, 921, 926)
3080 tnamt ( 1382) = namtyp ( 8192, 0, 10, 260, 267, 261, 268)
3081 tnamt ( 1385) = namtyp ( 0, 0, 46, 389, 393, 394, 399)
3082 tnamt ( 1389) = namtyp ( 0, 0, 5, 160, 166, 160, 166)
3083 tnamt ( 1399) = namtyp ( 0, 0, 257, 993, 996, 1012, 1015)
3084 tnamt ( 1413) = namtyp ( 0, 0, 35, 747, 753, 765, 771)
3085 tnamt ( 1426) = namtyp ( 0, 0, 47, 457, 465, 469, 478)
3086 tnamt ( 1450) = namtyp ( 0, 0, 257, 682, 684, 699, 701)
3087 tnamt ( 1461) = namtyp ( 0, 0, 45, 421, 425, 429, 434)
3088 tnamt ( 1496) = namtyp ( 0, 0, 6, 1028, 1033, 1047, 1052)
3089 tnamt ( 1543) = namtyp ( 0, 0, 1, 60, 65, 60, 65)
3090 tnamt ( 1566) = namtyp ( 0, 0, 9, 216, 224, 216, 225)
3091 tnamt ( 1576) = namtyp ( 0, 0, 257, 685, 687, 702, 704)
3092 tnamt ( 1607) = namtyp ( 0, 0, 1, 9, 13, 9, 13)
3093 tnamt ( 1608) = namtyp ( 0, 0, 257, 1024, 1027, 1043, 1046)
3094 tnamt ( 1667) = namtyp ( 0, 0, 25, 377, 388, 380, 393)
3095 tnamt ( 1668) = namtyp ( 0, 0, 257, 688, 690, 705, 707)
3096 tnamt ( 1682) = namtyp ( 0, 0, 28, 568, 575, 584, 591)
3097 tnamt ( 1686) = namtyp ( 0, 0, 21, 765, 768, 783, 786)
3098 tnamt ( 1736) = namtyp ( 0, 0, 1, 54, 59, 54, 59)
3099 tnamt ( 1750) = namtyp ( 0, 0, 6, 697, 711, 714, 729)
3100 tnamt ( 1776) = namtyp ( 0, 0, 1, 14, 18, 14, 18)
3101 tnamt ( 1777) = namtyp ( 0, 0, 48, 486, 493, 501, 509)
3102 tnamt ( 1830) = namtyp ( 0, 0, 5, 323, 328, 324, 329)
3103 tnamt ( 1931) = namtyp ( 0, 0, 5, 740, 742, 758, 760)
3104 tnamt ( 1937) = namtyp ( 0, 0, 5, 729, 735, 747, 753)
3105 tnamt ( 1956) = namtyp ( 0, 0, 6, 675, 681, 692, 698)
3106 tnamt ( 1964) = namtyp ( 0, 0, 5, 154, 159, 154, 159)
3107 tnamt ( 1974) = namtyp ( 0, 0, 23, 247, 252, 248, 253)
3108 tnamt ( 1977) = namtyp ( 0, 0, 40, 997, 1000, 1016, 1019)
3109 tnamt ( 1992) = namtyp ( 0, 0, 1, 30, 32, 30, 32)
3110 tnamt ( 2009) = namtyp ( 0, 0, 2, 95, 98, 95, 98)
3111 tnamt ( 2023) = namtyp ( 0, 0, 5, 1059, 1062, 1078, 1081)
3112 tnamt ( 2031) = namtyp ( 0, 0, 6, 331, 345, 332, 347)
3113 tnamt ( 2085) = namtyp ( 0, 0, 257, 128, 130, 128, 130)
3114 tnamt ( 2119) = namtyp ( 0, 0, 5, 211, 215, 211, 215)
3115 tnamt ( 2166) = namtyp ( 0, 0, 18, 494, 498, 510, 514)
3116 tnamt ( 2195) = namtyp ( 0, 0, 5, 654, 659, 671, 676)
3117 tnamt ( 2211) = namtyp ( 0, 0, 22, 1007, 1010, 1026, 1029)
3118 tnamt ( 2254) = namtyp ( 0, 0, 263, 1174, 1187, 1193, 1206)
3119 tnamt ( 2264) = namtyp ( 0, 0, 2, 99, 102, 99, 102)
3120 tnamt ( 2268) = namtyp ( 0, 0, 23, 721, 728, 739, 746)
3121 tnamt ( 2285) = namtyp ( 0, 0, 38, 854, 859, 872, 877)
3122 tnamt ( 2287) = namtyp ( 0, 0, 257, 936, 952, 955, 971)
3123 tnamt ( 2295) = namtyp ( 0, 0, 22, 806, 810, 824, 828)
3124 tnamt ( 2297) = namtyp ( 0, 0, 5, 794, 796, 812, 814)
3125 tnamt ( 2303) = namtyp ( 0, 0, 6, 253, 259, 254, 260)
3126 tnamt ( 2311) = namtyp ( 0, 0, 23, 502, 512, 518, 528)
3127 tnamt ( 2353) = namtyp ( 0, 0, 54, 401, 409, 407, 416)
3128 tnamt ( 2354) = namtyp ( 0, 0, 257, 670, 674, 687, 691)
3129 tnamt ( 2364) = namtyp ( 0, 0, 12, 791, 793, 809, 811)
3130 tnamt ( 2401) = namtyp ( 0, 0, 5, 549, 552, 565, 568)
3131 tnamt ( 2421) = namtyp ( 0, 0, 263, 1125, 1137, 1144, 1156)
3132 tnamt ( 2499) = namtyp ( 0, 0, 2, 113, 117, 113, 117)
3133 tnamt ( 2515) = namtyp ( 0, 0, 8, 838, 846, 856, 864)
3134 tnamt ( 2587) = namtyp ( 0, 0, 2, 103, 106, 103, 106)
3135 tnamt ( 2601) = namtyp ( 0, 0, 15, 553, 558, 569, 574)
3136 tnamt ( 2637) = namtyp ( 0, 0, 3, 122, 127, 122, 127)
3137 tnamt ( 2669) = namtyp ( 0, 0, 25, 438, 446, 448, 457)
3138 tnamt ( 2687) = namtyp ( 0, 0, 262, 1101, 1110, 1120, 1129)
3139 tnamt ( 2718) = namtyp ( 0, 0, 31, 583, 590, 600, 607)
3140 tnamt ( 2771) = namtyp ( 0, 0, 22, 283, 287, 284, 288)
3141 tnamt ( 2847) = namtyp ( 0, 0, 263, 1138, 1150, 1157, 1169)
3142 tnamt ( 2863) = namtyp ( 0, 0, 5, 309, 313, 310, 314)
3143 tnamt ( 2878) = namtyp ( 0, 0, 257, 143, 147, 143, 147)
3144 tnamt ( 2884) = namtyp ( 0, 0, 257, 276, 278, 277, 279)
3145 tnamt ( 2914) = namtyp ( 0, 0, 262, 1081, 1090, 1100, 1109)
3146 tnamt ( 2934) = namtyp ( 0, 0, 38, 831, 837, 849, 855)
3147 tnamt ( 2942) = namtyp ( 0, 0, 5, 881, 883, 899, 901)
3148 tnamt ( 2960) = namtyp ( 0, 0, 257, 131, 134, 131, 134)
3149 tnamt ( 3032) = namtyp ( 0, 0, 1, 19, 24, 19, 24)
3150 tnamt ( 3040) = namtyp ( 0, 0, 5, 1048, 1058, 1067, 1077)
3151 tnamt ( 3042) = namtyp ( 0, 0, 49, 1066, 1070, 1085, 1089)
3152 tnamt ( 3053) = namtyp ( 0, 0, 6, 167, 177, 167, 177)
3153 tnamt ( 3091) = namtyp ( 0, 0, 257, 736, 739, 754, 757)
3154 tnamt ( 3097) = namtyp ( 0, 0, 2, 118, 121, 118, 121)
3155 tnamt ( 3098) = namtyp ( 0, 0, 257, 922, 925, 940, 943)
3156 tnamt ( 3125) = namtyp ( 0, 0, 9, 1011, 1020, 1030, 1039)
3157 tnamt ( 3128) = namtyp ( 0, 0, 5, 516, 520, 532, 536)
3158 tnamt ( 3134) = namtyp ( 0, 0, 5, 1001, 1006, 1020, 1025)
3159 tnamt ( 3192) = namtyp ( 0, 0, 1, 33, 38, 33, 38)
3160 tnamt ( 3197) = namtyp ( 0, 0, 11, 302, 308, 303, 309)
3161 tnamt ( 3259) = namtyp ( 0, 0, 55, 576, 579, 592, 596)
3162 tnamt ( 3271) = namtyp ( 0, 0, 5, 148, 153, 148, 153)
3163 tnamt ( 3299) = namtyp ( 0, 0, 5, 989, 992, 1008, 1011)
3164 tnamt ( 3309) = namtyp ( 0, 0, 6, 783, 790, 801, 808)
3165 tnamt ( 3310) = namtyp ( 0, 0, 257, 919, 921, 937, 939)
3166 tnamt ( 3360) = namtyp ( 0, 0, 6, 615, 621, 632, 638)
3167 tnamt ( 3373) = namtyp ( 0, 0, 257, 953, 970, 972, 989)
3168 tnamt ( 3386) = namtyp ( 0, 0, 257, 135, 138, 135, 138)
3169 tnamt ( 3403) = namtyp ( 0, 0, 53, 543, 548, 559, 564)
3170 tnamt ( 3430) = namtyp ( 0, 0, 25, 374, 376, 377, 379)
3171 tnamt ( 3447) = namtyp ( 0, 0, 27, 479, 485, 493, 500)
3172 tnamt ( 3461) = namtyp ( 0, 0, 5, 499, 501, 515, 517)
3173 tnamt ( 3463) = namtyp ( 0, 0, 257, 1021, 1023, 1040, 1042)
3174 tnamt ( 3480) = namtyp ( 0, 0, 12, 600, 604, 617, 621)
3175 tnamt ( 3484) = namtyp ( 0, 0, 41, 1034, 1037, 1053, 1056)
3176 tnamt ( 3488) = namtyp ( 0, 0, 56, 888, 896, 906, 914)
3177 tnamt ( 3497) = namtyp ( 0, 0, 263, 1111, 1124, 1130, 1143)
3178 tnamt ( 3501) = namtyp ( 0, 0, 263, 1201, 1215, 1220, 1234)
3179 tnamt ( 3509) = namtyp ( 0, 0, 263, 1151, 1161, 1170, 1180)
3180 tnamt ( 3512) = namtyp ( 0, 0, 5, 513, 515, 529, 531)
3181 tnamt ( 3525) = namtyp ( 0, 0, 2, 66, 70, 66, 70)
3182 tnamt ( 3535) = namtyp ( 0, 0, 7, 292, 301, 293, 302)
3183 tnamt ( 3539) = namtyp ( 0, 0, 257, 139, 142, 139, 142)
3184 tnamt ( 3611) = namtyp ( 0, 0, 14, 394, 400, 400, 406)
3185 tnamt ( 3612) = namtyp ( 0, 0, 257, 525, 527, 541, 543)
3186 tnamt ( 3676) = namtyp ( 0, 0, 13, 186, 191, 186, 191)
3187 tnamt ( 3718) = namtyp ( 0, 0, 5, 540, 542, 556, 558)
3188 tnamt ( 3719) = namtyp ( 0, 0, 9, 691, 696, 708, 713)
3189 tnamt ( 3729) = namtyp ( 0, 0, 38, 971, 978, 990, 997)
3190 tnamt ( 3733) = namtyp ( 0, 0, 5, 754, 759, 772, 777)
3191 tnamt ( 3803) = namtyp ( 0, 0, 7, 178, 185, 178, 185)
3192 tnamt ( 3854) = namtyp ( 0, 0, 21, 242, 246, 243, 247)
3193 tnamt ( 3895) = namtyp ( 0, 0, 2, 75, 79, 75, 79)
3194 tnamt ( 3922) = namtyp ( 0, 0, 25, 447, 456, 458, 468)
3195 tnamt ( 3930) = namtyp ( 0, 0, 33, 628, 636, 645, 653)
3196 tnamt ( 3968) = namtyp ( 0, 0, 18, 225, 228, 226, 229)
3197 tnamt ( 4013) = namtyp ( 0, 0, 21, 605, 611, 622, 628)
3198 tnamt ( 4031) = namtyp ( 0, 0, 26, 426, 437, 435, 447)
3199 tnamt ( 4032) = namtyp ( 0, 0, 24, 359, 364, 361, 367)
3200 tnamt ( 4034) = namtyp ( 0, 0, 22, 521, 524, 537, 540)
3201 tnamt ( 4038) = namtyp ( 0, 0, 257, 279, 282, 280, 283)
3202 tnamt ( 4049) = namtyp ( 0, 0, 36, 1063, 1065, 1082, 1084)
3203 tnamt ( 4061) = namtyp ( 0, 0, 56, 346, 354, 348, 356)
3204 tnamt ( 4080) = namtyp ( 0, 0, 51, 229, 232, 230, 233)
3205 tnamt ( 4083) = namtyp ( 0, 0, 16, 1, 1, 1, 1)
3206 tnamt ( 8190) = namtyp ( 0, 1128, 263, 1188, 1200, 1207, 1219)
3207 tnamt ( 8191) = namtyp ( 0, 393, 6, 1044, 1047, 1063, 1066)
3208 tnamt ( 8192) = namtyp ( 0, 1382, 257, 667, 669, 684, 686)
3209 ialt = 8190
3210
3211
3212 end subroutine ininam
3213 subroutine tstidf (znam, kctok, krtok, kwnam, inam)
3214
3215 use fprsvars
3216 use flexprms
3217 use fpprcurs
3218 character (len=*), intent (in) :: znam
3219 integer, intent (in) :: kctok, krtok
3220 integer, intent (out) :: kwnam, inam
3221
3222
3223 interface
3224 logical function ifsame (zstr1, zstr2)
3225
3226 character (len=*), intent (in) :: zstr1, zstr2
3227 end function ifsame
3228
3229 logical function ifposs (kwnam, kctxt, krctx)
3230
3231 use flexvars
3232 use fprsvars
3233 integer, intent (in) :: kwnam, kctxt, krctx
3234 end function ifposs
3235 end interface
3236
3237 = len_trim (znam)
3238 ihsh = khshstr (znam (1:lnam))
3239 ifput = 0
3240 inam = 0
3241 if (tnamt(ihsh)%kwnam == 0) then
3242 kwnam = kwvar
3243 ifput = 1
3244 inam = ihsh
3245 ibck = 0
3246 else
3247 do
3248 inamd = tnamt(ihsh)%inamd
3249 inamf = tnamt(ihsh)%inamf
3250 if (ifsame (znam (1:lnam), znamg (inamd:inamf))) then
3251 kwnam = tnamt(ihsh)%kwnam
3252 if (ifposs (kwnam, kctok, krtok)) then
3253 inam = ihsh
3254 exit
3255 endif
3256 endif
3257 if (tnamt(ihsh)%ihshf == 0) then
3258 ialt = ialt - 1
3259 if (tnamt(ialt)%kwnam /= 0) then
3260 call fpperr ("insufficient name space, " // &
3261 "raise max # of names and try again")
3262 stop
3263 endif
3264 kwnam = kwvar
3265 ifput = 1
3266 inam = ialt
3267 ibck = ihsh
3268 tnamt(ihsh)%ihshf = inam
3269 exit
3270 else
3271 ihsh = tnamt(ihsh)%ihshf
3272 endif
3273 enddo
3274 endif
3275
3276 if (ifput /= 0) then
3277 inamd = inamg + 1
3278 inamg = inamg + lnam
3279 if (inamg > nnamm*lnama) then
3280 call fpperr ("insufficient name space (identifiers), " // &
3281 "raise length of global chain and try again")
3282 stop
3283 endif
3284 inams = inamo + 1
3285 inamo = inamo + lnam
3286 if (inamo > nnamm*lnama*2) then
3287 call fpperr ("insufficient name space (out. idf. names), "//&
3288 "raise length of global chain and try again")
3289 stop
3290 endif
3291 tnamt (inam) = namtyp (0, ibck, kwnam, inamd, inamg, &
3292 inams, inamo)
3293 znamg (inamd:inamg) = znam (1:lnam)
3294 znamo (inams:inamo) = znam (1:lnam)
3295 endif
3296 return
3297 end subroutine tstidf
3298 logical function ifsame (zstr1, zstr2)
3299
3300 use fpprprms
3301 character (len=*), intent (in) :: zstr1, zstr2
3302
3303 character (len=1) :: zchr1, zchr2
3304
3305 = len_trim (zstr1)
3306 lstr2 = len_trim (zstr2)
3307 if (lstr1 == lstr2) then
3308 ifsame = .true.
3309 do istr = 1, lstr1
3310 zchr1 = zstr1 (istr:istr)
3311 irnk = index (zlwr, zchr1)
3312 if (irnk > 0) zchr1 = zupr (irnk:irnk)
3313 zchr2 = zstr2 (istr:istr)
3314 irnk = index (zlwr, zchr2)
3315 if (irnk > 0) zchr2 = zupr (irnk:irnk)
3316 ifsame = (zchr1 == zchr2)
3317 if (.not. ifsame) exit
3318 enddo
3319 else
3320 ifsame = .false.
3321 endif
3322 end function ifsame
3323 logical function ifposs (kwnam, kctxt, krctx)
3324
3325 use fprsvars
3326 integer, intent (in) :: kwnam, kctxt, krctx
3327
3328
3329 if (kctxt == kcany .and. krctx == krany) then
3330 ifposs = .true.
3331 return
3332 endif
3333 select case (kwnam)
3334 case default
3335 ifposs = .true.
3336 case (kwcmd)
3337 select case (kctxt)
3338 case default
3339 ifposs = .false.
3340 case (kcbeg, kccmd)
3341 ifposs = .true.
3342 end select
3343 case (kwlop, kwlct)
3344 select case (kctxt)
3345 case default
3346 ifposs = .true.
3347 case (kcukn, kcbeg, kcbex, kcblb, kcbnb)
3348 ifposs = .false.
3349 end select
3350 case (kwfmb)
3351 select case (kctxt)
3352 case default
3353 ifposs = .false.
3354 case (kcwtf)
3355 ifposs = .true.
3356 end select
3357 case (kwiok)
3358 select case (kctxt)
3359 case default
3360 ifposs = .false.
3361 case (kcwti)
3362 ifposs = .true.
3363 end select
3364 case (kwatt)
3365 select case (kctxt)
3366 case default
3367 ifposs = .false.
3368 case (kcbeg, kcdcl, kcany)
3369 ifposs = .true.
3370 end select
3371 case (kwpat)
3372 select case (kctxt)
3373 case default
3374 ifposs = .false.
3375 case (kcbeg, kcdcl, kcany)
3376 ifposs = .true.
3377 end select
3378 case (kwaca, kwaio, kwac6)
3379 select case (kctxt)
3380 case default
3381 ifposs = .false.
3382 case (kcbeg, kcbex, kcblb, kcany)
3383 ifposs = (krctx == krpou)
3384 end select
3385 case (kwgnn)
3386 select case (kctxt)
3387 case default
3388 ifposs = .false.
3389 case (kcntf, kcany)
3390 ifposs = .true.
3391 end select
3392 case (kwprc)
3393 select case (kctxt)
3394 case default
3395 ifposs = .false.
3396 case (kcbeg, kcdcp, kcany)
3397 ifposs = .true.
3398 end select
3399 case (kwctn)
3400 select case (kctxt)
3401 case default
3402 ifposs = .false.
3403 case (kcbeg, kcbex, kcany)
3404 ifposs = (krctx == krlst)
3405 end select
3406 case (kwdef)
3407 select case (kctxt)
3408 case default
3409 ifposs = .false.
3410 case (kccas, kcany)
3411 ifposs = .true.
3412 end select
3413 case (kwnta)
3414 select case (kctxt)
3415 case default
3416 ifposs = .false.
3417 case (kcntt, kcany)
3418 ifposs = .true.
3419 end select
3420 case (kwsts)
3421 select case (krctx)
3422 case default
3423 ifposs = .false.
3424 case (krstr)
3425 ifposs = .true.
3426 end select
3427 case (kwtoa)
3428 select case (kctxt)
3429 case default
3430 ifposs = .false.
3431 case (kcass)
3432 ifposs = .true.
3433 end select
3434 case (kwass)
3435 select case (kctxt)
3436 case default
3437 ifposs = .false.
3438 case (kcbeg, kcbex, kcblb, kcany)
3439 ifposs = .true.
3440 end select
3441 case (kwac2, kwac3, kwcas, kwgto)
3442 select case (kctxt)
3443 case default
3444 ifposs = .false.
3445 case (kcbeg, kcbex, kcblb, kcife)
3446 ifposs = (krctx /= krlst)
3447 case (kcany)
3448 ifposs = .true.
3449 end select
3450 case (kwac4, kwelw)
3451 select case (kctxt)
3452 case default
3453 ifposs = .false.
3454 case (kcbeg, kcbex, kcblb, kcife)
3455 ifposs = (krctx == krlst)
3456 case (kcany)
3457 ifposs = .true.
3458 end select
3459 case (kwfmt)
3460 select case (kctxt)
3461 case default
3462 ifposs = .false.
3463 case (kcblb, kcany)
3464 ifposs = .true.
3465 end select
3466 case (kwsel, kwwhe)
3467 select case (kctxt)
3468 case default
3469 ifposs = .false.
3470 case (kcbeg, kcbex, kcblb, kcbnb, kcany)
3471 ifposs = .true.
3472 end select
3473 case (kwfra)
3474 select case (kctxt)
3475 case default
3476 ifposs = .false.
3477 case (kcbeg, kcbex, kcblb, kcany)
3478 ifposs = .true.
3479 end select
3480 case (kwac5)
3481 select case (kctxt)
3482 case default
3483 ifposs = .false.
3484 case (kcbeg, kcbex, kcblb, kcife, kcany)
3485 ifposs = .true.
3486 end select
3487 case (kwacd)
3488 select case (kctxt)
3489 case default
3490 ifposs = .false.
3491 case (kcbeg)
3492 ifposs = (krctx /= krlst)
3493 case (kcany)
3494 ifposs = .true.
3495 end select
3496 case (kwdta)
3497 select case (kctxt)
3498 case default
3499 ifposs = .false.
3500 case (kcbeg)
3501 ifposs = (krctx /= krlst)
3502 case (kcany)
3503 ifposs = .true.
3504 end select
3505 case (kweli)
3506 select case (kctxt)
3507 case default
3508 ifposs = .false.
3509 case (kcbeg)
3510 ifposs = (krctx == krpou)
3511 case (kcany)
3512 ifposs = .true.
3513 end select
3514 case (kwenp)
3515 select case (kctxt)
3516 case default
3517 ifposs = .false.
3518 case (kcbeg, kcbex, kcblb, kcany)
3519 ifposs = .true.
3520 end select
3521 case (kwent)
3522 select case (kctxt)
3523 case default
3524 ifposs = .false.
3525 case (kcbeg, kcany)
3526 ifposs = .true.
3527 end select
3528 case (kwfct)
3529 select case (kctxt)
3530 case default
3531 ifposs = (krctx == krpou)
3532 case (kcbeg, kcdcl, kcdcp, kcany)
3533 ifposs = .true.
3534 end select
3535 case (kwhol)
3536
3537 = .false.
3538 case (kwifp)
3539 select case (kctxt)
3540 case default
3541 ifposs = .false.
3542 case (kcbeg, kcbex, kcblb, kcbnb)
3543 ifposs = (krctx == krpou)
3544 case (kcany)
3545 ifposs = .true.
3546 end select
3547 case (kwipl)
3548 select case (kctxt)
3549 case default
3550 ifposs = .false.
3551 case (kcbeg, kcany)
3552 ifposs = .true.
3553 end select
3554 case (kwntt)
3555 select case (kctxt)
3556 case default
3557 ifposs = .false.
3558 case (kcbeg, kcdcl)
3559 ifposs = (krctx == krpou)
3560 case (kcany)
3561 ifposs = .true.
3562 end select
3563 case (kwntf)
3564 select case (kctxt)
3565 case default
3566 ifposs = .false.
3567 case (kcbeg, kcany)
3568 ifposs = .true.
3569 end select
3570 case (kwnon)
3571 select case (kctxt)
3572 case default
3573 ifposs = .false.
3574 case (kcipl, kcany)
3575 ifposs = .true.
3576 end select
3577 case (kwuse)
3578 select case (kctxt)
3579 case default
3580 ifposs = .false.
3581 case (kcbeg)
3582 ifposs = (krctx /= krlst)
3583 case (kcany)
3584 ifposs = .true.
3585 end select
3586 case (kwnly)
3587 select case (kctxt)
3588 case default
3589 ifposs = .false.
3590 case (kcuse, kcany)
3591 ifposs = .true.
3592 end select
3593 case (kwpps)
3594 select case (kctxt)
3595 case default
3596 ifposs = .false.
3597 case (kcbeg, kcdcl, kcany)
3598 ifposs = .true.
3599 end select
3600 case (kwrsl)
3601 select case (kctxt)
3602 case default
3603 ifposs = .false.
3604 case (kcprc, kcany)
3605 ifposs = .true.
3606 end select
3607 case (kwstt)
3608 select case (kctxt)
3609 case default
3610 ifposs = .false.
3611 case (kcall, kcany)
3612 ifposs = .true.
3613 end select
3614 case (kwthn)
3615 select case (kctxt)
3616 case default
3617 ifposs = .false.
3618 case (kcife, kcany)
3619 ifposs = .true.
3620 end select
3621 case (kwbcl)
3622 select case (kctxt)
3623 case default
3624 ifposs = .false.
3625 case (kcbeg, kcbex, kcblb, kcbnb, kcany)
3626 ifposs = .true.
3627 end select
3628 case (kwwhl)
3629 select case (kctxt)
3630 case default
3631 ifposs = .false.
3632 case (kcbcl, kcany)
3633 ifposs = .true.
3634 end select
3635 case (kwels, kweni, kwend, kwens, kwenw, kwenf, kwena)
3636 select case (kctxt)
3637 case default
3638 ifposs = .false.
3639 case (kcbeg, kcbex, kcany)
3640 ifposs = .true.
3641 end select
3642 case (kwtyp)
3643 select case (kctxt)
3644 case default
3645 ifposs = .false.
3646 case (kcbeg)
3647 ifposs = (krctx /= krpou)
3648 case (kcany)
3649 ifposs = .true.
3650 end select
3651 end select
3652 end function ifposs
3653 subroutine wrtstt (zlab, llab, zstt, lstt, zcmt, lcmt, nndti)
3654
3655 use flexprms
3656 use fpprcurs
3657 character (len=*), intent (in) :: zlab, zstt, zcmt
3658 integer, intent (in) :: llab, lstt, lcmt, nndti
3659
3660
3661 character (len=*), parameter :: zfmts = "(/)"
3662 character (len=*), parameter :: zfmt1n = "(a)"
3663 character (len=*), parameter :: zfmt1x = "(a,'&')"
3664 character (len=*), parameter :: zfmtl = "('# line ',i8,a)"
3665 character (len=1) :: zdlm
3666 character (len=linem) :: zheaw
3667 character (len=10) :: zset
3668
3669 integer, save :: nlino = 0
3670 integer, parameter :: lspltm = 5
3671 integer :: lsplt
3672
3673 = lcmt
3674
3675
3676
3677 if (lstt <= 0) then
3678 if (lcmt /= 0) then
3679 nndtw = nndti
3680 lcmtw = lcmt
3681 if (lcmtw + nndtw > linem) then
3682 nndtw = 0
3683 lcmtw = min (lcmt, linem)
3684 endif
3685 if (llab == 0) then
3686 write (lufil, zfmt1n) repeat (" ", nndtw) &
3687 // zcmt (1:lcmtw)
3688 else
3689 nndtw = max (1, nndtw - llab)
3690 write (lufil, zfmt1n) zlab (1:llab) &
3691 // repeat (" ", nndtw) &
3692 // zcmt (1:lcmtw)
3693 endif
3694 else
3695 if (llab == 0) then
3696 write (lufil, zfmts)
3697 else
3698 write (lufil, zfmt1n) zlab (1:llab)
3699 endif
3700 endif
3701 nlino = nlino + 1
3702 return
3703 endif
3704
3705
3706
3707 if (iflnb /= 0) then
3708 write (lufil, zfmtl) nlinit (iclev), &
3709 ' "' // trim(zficit(iclev)) // '"'
3710 endif
3711
3712
3713
3714 if (iffxf == 0) then
3715 nndtw = nndti
3716 linew = linel
3717 else
3718 nndtw = max (nndti, 6)
3719 = 72
3720 endif
3721 lsttw = lstt + max (llab + 1 - nndtw, 0)
3722 if (lsttw > linew-2-nndtw) then
3723 call chxspl
3724 else
3725 lsplt = 0
3726 endif
3727 if (lsplt >= lspltm) then
3728 if (iffxf == 0) then
3729 linew = linem
3730 call chxspl
3731 endif
3732 if (lsplt >= lspltm) then
3733 if (iffxf == 0) then
3734 nndtw = 0
3735 else
3736 nndtw = 6
3737 endif
3738 lsttw = lstt + max (llab + 1 - nndtw, 0)
3739 call chxspl
3740 if (lsplt >= lspltm) then
3741 ncnt = (lsttw+linew-nndtw-3) / (linew-2-nndtw)
3742 write (luerr, *) "More than max # of continuation lines"
3743 write (luerr, *) "output lines", nlino + 1, &
3744 " - ", nlino + ncnt
3745 endif
3746 endif
3747 endif
3748
3749 = 0
3750 ifchc = 0
3751 nampw = 2
3752 do
3753 ideb = ifin + 1
3754 ifin = ifin + linew - nampw - nndtw
3755 if (ideb == 1) then
3756 ifin = ifin + 1
3757 if (llab /= 0) then
3758 nndtw1 = max (nndtw, llab + 1)
3759 ifin = ifin + nndtw - nndtw1
3760 endif
3761 else
3762 if (nndtw > 1) then
3763 ifin = ifin + 1
3764 endif
3765 endif
3766 ifin = min (ifin, lstt)
3767 ifchp = ifchc
3768 if (ifin < lstt .and. lsplt < lspltm) then
3769 ilst = ideb
3770 do ichr = ideb, ifin
3771 if (ifchc == 0 .and. &
3772 (zstt (ichr:ichr) == "'" .or. &
3773 zstt (ichr:ichr) == '"' ) ) then
3774 ifchc = 1
3775 zdlm = zstt (ichr:ichr)
3776 elseif (ifchc == 1 .and. &
3777 zstt (ichr:ichr) == zdlm) then
3778 ifchc = 0
3779 ilst = ichr
3780 endif
3781 enddo
3782 if (ifchc == 0) then
3783 select case (lsplt)
3784 case default
3785 zset = " "
3786 case (1)
3787 zset = " +-"
3788 case (2)
3789 zset = " +-,:="
3790 case (3)
3791 zset = " +-,:=/*"
3792 case (4)
3793 zset = " +-,:=/*><"
3794 end select
3795 ibck = scan (zstt (ilst+1:ifin+1), zset, &
3796 back=.true.)
3797 if (ibck > 0) then
3798 ifin = ilst + ibck
3799 endif
3800 nampw = 3
3801 else
3802 nampw = 2
3803 endif
3804 endif
3805
3806
3807
3808 if (ideb == 1) then
3809 if (ifin == lstt) then
3810 if (lcmt == 0) then
3811 if (llab == 0) then
3812 write (lufil, zfmt1n) repeat (" ", nndtw) &
3813 // zstt (ideb:ifin)
3814 else
3815 nndtw2 = nndtw1 - llab
3816 write (lufil, zfmt1n) zlab (1:llab) &
3817 // repeat (" ", nndtw2) &
3818 // zstt (ideb:ifin)
3819 endif
3820 else
3821 if (llab == 0) then
3822 llin = ifin - ideb + 1 + nndtw
3823 if (llin <= linew) then
3824 write (lufil, zfmt1n) repeat (" ", nndtw) &
3825 // zstt (ideb:ifin) &
3826 // zcmt (1:lcmtw)
3827 else
3828 write (lufil, zfmt1n) repeat (" ", nndtw) &
3829 // zstt (ideb:ifin)
3830 nlino = nlino + 1
3831 write (lufil, zfmt1n) adjustl (zcmt (1:lcmtw))
3832 endif
3833 else
3834 nndtw2 = nndtw1 - llab
3835 llin = ifin - ideb + 1 + nndtw1
3836 if (llin <= linew) then
3837 write (lufil, zfmt1n) zlab (1:llab) &
3838 // repeat (" ", nndtw2) &
3839 // zstt (ideb:ifin) &
3840 // zcmt (1:lcmtw)
3841 else
3842 write (lufil, zfmt1n) zlab (1:llab) &
3843 // repeat (" ", nndtw2) &
3844 // zstt (ideb:ifin)
3845 nlino = nlino + 1
3846 write (lufil, zfmt1n) adjustl (zcmt (1:lcmtw))
3847 endif
3848 endif
3849 endif
3850 nlino = nlino + 1
3851 exit
3852 else
3853 if (iffxf == 0) then
3854 if (llab == 0) then
3855 write (lufil, zfmt1x) repeat (" ", nndtw) &
3856 // zstt (ideb:ifin)
3857 else
3858 nndtw2 = nndtw1 - llab
3859 write (lufil, zfmt1x) zlab (1:llab) &
3860 // repeat (" ", nndtw2) &
3861 // zstt (ideb:ifin)
3862 endif
3863 else
3864 nfilw = 72 - nndtw - (ifin - ideb + 1)
3865 if (llab == 0) then
3866 write (lufil, zfmt1x) repeat (" ", nndtw) &
3867 // zstt (ideb:ifin) &
3868 // repeat (" ", nfilw)
3869 else
3870 nndtw2 = nndtw1 - llab
3871 write (lufil, zfmt1x) zlab (1:llab) &
3872 // repeat (" ", nndtw2) &
3873 // zstt (ideb:ifin) &
3874 // repeat (" ", nfilw)
3875 endif
3876 endif
3877 endif
3878
3879
3880
3881 else
3882 nndtw1 = max (nndtw, 1)
3883 if (iffxf == 0) then
3884 zheaw = repeat (" ", nndtw1 - 1) // "& "
3885 if (ifchp == 0) then
3886 nndtw1 = nndtw1 + 1
3887 endif
3888 elseif (ifchp /= 0) then
3889 zheaw = repeat (" ", 5) // "&"
3890 nndtw1 = 6
3891 else
3892 zheaw = repeat (" ", 5) // "&"
3893 endif
3894 if (ifin == lstt) then
3895 if (lcmt == 0) then
3896 write (lufil, zfmt1n) zheaw (1:nndtw1) &
3897 // zstt (ideb:ifin)
3898 else
3899 llin = ifin - ideb + 1 + nndtw1
3900 if (llin <= linew) then
3901 write (lufil, zfmt1n) zheaw (1:nndtw1) &
3902 // zstt (ideb:ifin) &
3903 // zcmt (1:lcmtw)
3904 else
3905 write (lufil, zfmt1n) zheaw (1:nndtw1) &
3906 // zstt (ideb:ifin)
3907 nlino = nlino + 1
3908 write (lufil, zfmt1n) adjustl (zcmt (1:lcmtw))
3909 endif
3910 endif
3911 nlino = nlino + 1
3912 exit
3913 else
3914 if (iffxf == 0) then
3915 write (lufil, zfmt1x) zheaw (1:nndtw1) &
3916 // zstt (ideb:ifin)
3917 else
3918 nfilw = 72 - nndtw1 + 1 - (ifin - ideb + 2)
3919 write (lufil, zfmt1x) zheaw (1:nndtw1) &
3920 // zstt (ideb:ifin) &
3921 // repeat (" ", nfilw)
3922 endif
3923 endif
3924 endif
3925 nlino = nlino + 1
3926 enddo
3927 return
3928 contains
3929 subroutine chxspl
3930
3931
3932
3933 = 0
3934 levels: do
3935 if (lsplt >= lspltm) exit levels
3936 ifinw = 0
3937 ifchc = 0
3938 nlinw = 0
3939 nampw = 2
3940 do
3941 idebw = ifinw + 1
3942 ifinw = ifinw + linew - nampw - nndtw
3943 if (idebw == 1) then
3944 ifinw = ifinw + 1
3945 if (llab /= 0) then
3946 nndtw1 = max (nndtw, llab + 1)
3947 ifinw = ifinw + nndtw - nndtw1
3948 endif
3949 else
3950 if (nndtw > 1) then
3951 ifinw = ifinw + 1
3952 endif
3953 endif
3954 ifinw = min (ifinw, lstt)
3955
3956
3957
3958 if (ifinw < lstt) then
3959 ilst = idebw
3960 do ichr = idebw, ifinw
3961 if (ifchc == 0 .and. &
3962 (zstt (ichr:ichr) == "'" .or. &
3963 zstt (ichr:ichr) == '"' ) ) then
3964 ifchc = 1
3965 zdlm = zstt (ichr:ichr)
3966 elseif (ifchc == 1 .and. &
3967 zstt (ichr:ichr) == zdlm) then
3968 ifchc = 0
3969 ilst = ichr
3970 endif
3971 enddo
3972 if (ifchc == 0) then
3973 select case (lsplt)
3974 case default
3975 zset = " "
3976 case (1)
3977 zset = " +-"
3978 case (2)
3979 zset = " +-,:="
3980 case (3)
3981 zset = " +-,:=/*"
3982 case (4)
3983 zset = " +-,:=/*><"
3984 end select
3985 ibck = scan (zstt (ilst+1:ifinw+1), zset, &
3986 back=.true.)
3987 if (ibck > 0) then
3988 ifinw = ilst + ibck
3989 nampw = 3
3990 else
3991 lsplt = lsplt + 1
3992 cycle levels
3993 endif
3994 else
3995 ibck = index (zstt (ilst+1:ifinw+1), zdlm, &
3996 back=.true.)
3997 if (ibck > 0) then
3998 ifinw = ilst + ibck - 1
3999 nampw = 3
4000 ifchc = 0
4001 else
4002 nampw = 2
4003 endif
4004 endif
4005 endif
4006
4007
4008
4009 if (idebw == 1) then
4010 if (ifinw == lstt) then
4011 nlinw = nlinw + 1
4012 exit
4013 endif
4014
4015
4016
4017 else
4018 if (ifinw == lstt) then
4019 nlinw = nlinw + 1
4020 exit
4021 endif
4022 endif
4023 nlinw = nlinw + 1
4024 if (nlinw > ncntm) exit
4025 enddo
4026 if (nlinw <= ncntm) then
4027 return
4028 else
4029 lsplt = lsplt + 1
4030 endif
4031 enddo levels
4032 end subroutine chxspl
4033 end subroutine wrtstt
4034 subroutine fpperr (zstr)
4035
4036 use fpprcurs
4037 character (len=*), intent (in) :: zstr
4038
4039
4040 character (len=*), parameter :: zfmt = &
4041 "(a, ', line ', a, ': Error:', ' ', a)"
4042 character (len=11) :: znum
4043
4044 write (znum, "(i11)") nlinit (iclev)
4045 write (luerr, zfmt) trim (zficit (iclev)), &
4046 trim (adjustl (znum)), &
4047 trim (zstr)
4048 return
4049 end subroutine fpperr
4050 subroutine lexfxd (trttok, ifstp, ksta)
4051
4052
4053 use flexprms
4054 use fpprcurs
4055 interface
4056 subroutine trttok (ztok, ltok, kktok)
4057
4058 use flexvars
4059 use fpprcurs
4060 integer, intent (in) :: ltok, kktok
4061 character (len=ltok), intent (in) :: ztok
4062 end subroutine trttok
4063 end interface
4064 integer, intent (in) :: ifstp
4065 integer, intent (out) :: ksta
4066
4067 character (len=2*linem) :: zlinw
4068 character (len=lsttm) :: zlin
4069 character (len=lsttm) :: ztok
4070 character (len=1) :: zdlm, zchr
4071 integer, save :: ifctn = 0
4072
4073 = 0
4074 llin = 0
4075 ifchc = 0
4076 ifcnt = 0
4077 ntok = 0
4078 kktok = kkndf
4079
4080 body: do
4081 llin = 0
4082 ibeg = 1
4083
4084
4085
4086 rdlin: do
4087 do
4088 ifctn = 0
4089 if (klrea == kllst .or. klrea == kltcm) then
4090 if (iclev > 0) then
4091 zlinb = zlinbh (iclev)
4092 nhav = nhavh (iclev)
4093 klnxt = klnxth (iclev)
4094 iclev = iclev - 1
4095 close (lufic)
4096 lufic = lufic - 1
4097 if (iclev == 0) then
4098 luinp = lustdi
4099 else
4100 luinp = lufic
4101 endif
4102 if (klnxt /= kllst .or. nhav /= 0) exit
4103 else
4104 ksta = -1
4105 exit body
4106 endif
4107 elseif (klrea == klctd) then
4108 ifctn = 1
4109 endif
4110
4111 call realin (luinp, zlinw, klrea)
4112 if (klrea == klunv .and. iclev /= 0) then
4113 klrea = kllst
4114 cycle
4115 endif
4116 exit
4117 enddo
4118
4119 select case (klrea)
4120
4121
4122
4123 case (klunv)
4124 ksta = 1
4125 call fpperr ("Problem reading input")
4126 exit body
4127
4128
4129
4130 case (klfcm)
4131 llinw = len_trim (zlinw)
4132 do icmti = 1, ncmti
4133 lcmti = len_trim (zcmtit (icmti))
4134 if (llinw > lcmti .and. &
4135 zlinw (1:lcmti) == zcmtit (icmti)(1:lcmti)) then
4136 call trttok (zlinw (1:lcmti), lcmti, kkfcm)
4137 ibeg = lcmti + 1
4138 exit rdlin
4139 endif
4140 enddo
4141
4142
4143
4144 case (klcmt, kltcm)
4145 llinw = len_trim (zlinw)
4146 call trttok (zlinw, llinw, kkcmt)
4147 call trttok (ztok, 0, kkeos)
4148 cycle rdlin
4149
4150
4151
4152 case (klnrm, kllst)
4153 llinw = len_trim (zlinw)
4154 ilinw = verify (zlinw (1:llinw), ztab // " ")
4155 ilin = llin + 1
4156 llin = llinw - ilinw + ilin
4157 zlin (ilin:llin) = zlinw (ilinw:llinw)
4158 exit rdlin
4159
4160
4161
4162 case (klctd)
4163
4164
4165
4166 if (ifctn == 0) then
4167 llinw = 72
4168 else
4169 llinw = 72 - 6
4170 endif
4171 ichr = ibeg - 1
4172 ifctc = 0
4173 check: do
4174 if (ichr >= llinw) then
4175 exit check
4176 endif
4177 ichr = ichr + 1
4178 zchr = zlinw (ichr:ichr)
4179 if (ifctc == 0) then
4180 if (zchr == "!") then
4181 if (ifstp == 0) &
4182 call wrtstt (zlinw, 0, zlinw, 0, &
4183 zlinw (ichr:llinw), &
4184 llinw - ichr + 1, ichr-1)
4185 llinw = ichr - 1
4186 exit check
4187 elseif (zchr == '"' .or. zchr == "'") then
4188 zdlm = zchr
4189 ifctc = 1
4190 endif
4191 else
4192 if (zchr == zdlm) then
4193 ifctc = 0
4194 endif
4195 endif
4196 enddo check
4197
4198 = verify (zlinw (1:llinw), ztab // " ")
4199 ilin = llin + 1
4200 llin = llinw - ilinw + ilin
4201 zlin (ilin:llin) = zlinw (ilinw:llinw)
4202 cycle rdlin
4203 end select
4204
4205 enddo rdlin
4206
4207 = ibeg - 1
4208
4209
4210
4211 do
4212 do
4213 if (ichr >= llin) then
4214 if (ifcnt == 0) then
4215 if (kktok /= kkndf) then
4216 call trttok (ztok, ltok, kktok)
4217 endif
4218 exit body
4219 else
4220 cycle body
4221 endif
4222 endif
4223 ichr = ichr + 1
4224 zchr = zlin (ichr:ichr)
4225 if (ifchc == 0) then
4226 select case (zchr)
4227
4228
4229
4230 case (ztab)
4231 if (kktok /= kkndf) then
4232 call trttok (ztok, ltok, kktok)
4233 endif
4234 kktok = kkndf
4235
4236
4237
4238 case (' ')
4239 if (kktok /= kkndf) then
4240 call trttok (ztok, ltok, kktok)
4241 endif
4242 kktok = kkndf
4243
4244
4245
4246 case ('A':'Z','a':'z')
4247 if (kktok == kkidf .or. kktok == kkcmd) then
4248 ltok = ltok + 1
4249 ztok (ltok:ltok) = zchr
4250 else
4251 if (kktok /= kkndf) then
4252 call trttok (ztok, ltok, kktok)
4253 endif
4254 ntok = ntok + 1
4255 ltok = 1
4256 ztok (ltok:ltok) = zchr
4257 kktok = kkidf
4258 endif
4259
4260
4261
4262 case ('0':'9')
4263 if (kktok == kkidf .or. kktok == kknui) then
4264 ltok = ltok + 1
4265 ztok (ltok:ltok) = zchr
4266 else
4267 if (kktok /= kkndf) then
4268 call trttok (ztok, ltok, kktok)
4269 endif
4270 ntok = ntok + 1
4271 ltok = 1
4272 ztok (ltok:ltok) = zchr
4273 kktok = kknui
4274 endif
4275
4276
4277
4278 case ('_')
4279 select case (kktok)
4280 case (kkidf)
4281 ltok = ltok + 1
4282 ztok (ltok:ltok) = zchr
4283 case (kknui, kkstr)
4284 call trttok (ztok, ltok, kktok)
4285 ntok = ntok + 1
4286 call trttok (zchr, 1, kkknd)
4287 kktok = kkndf
4288 case default
4289 if (kktok /= kkndf) then
4290 call trttok (ztok, ltok, kktok)
4291 endif
4292 ntok = ntok + 1
4293 ltok = 1
4294 ztok (ltok:ltok) = zchr
4295 kktok = kkidf
4296 end select
4297
4298
4299
4300 case (':')
4301 if (kktok /= kkndf) then
4302 call trttok (ztok, ltok, kktok)
4303 endif
4304 ntok = ntok + 1
4305 call trttok (zchr, 1, kkdpt)
4306 kktok = kkndf
4307
4308
4309
4310 case (';')
4311 if (kktok /= kkndf) then
4312 call trttok (ztok, ltok, kktok)
4313 endif
4314 ntok = ntok + 1
4315 call trttok (zchr, 1, kkpvg)
4316 kktok = kkndf
4317
4318
4319
4320 case ('(')
4321 if (kktok /= kkndf) then
4322 call trttok (ztok, ltok, kktok)
4323 endif
4324 ntok = ntok + 1
4325 ltok = 1
4326 ztok (ltok:ltok) = zchr
4327 kktok = kkpou
4328
4329
4330
4331 case (')')
4332 if (kktok == kkslh) then
4333 ltok = ltok + 1
4334 ztok (ltok:ltok) = zchr
4335 call trttok (ztok, ltok, kkcfr)
4336 kktok = kkndf
4337 else
4338 if (kktok /= kkndf) then
4339 call trttok (ztok, ltok, kktok)
4340 endif
4341 ntok = ntok + 1
4342 call trttok (zchr, 1, kkpfr)
4343 kktok = kkndf
4344 endif
4345
4346
4347
4348 case ('!')
4349 if (kktok /= kkndf .and. ifcnt == 0) then
4350 call trttok (ztok, ltok, kktok)
4351 endif
4352 if (ifcnt == 0) then
4353 ntok = ntok + 1
4354 call trttok (zlin (ichr:llin), (llin-ichr+1),&
4355 kkcmt)
4356 exit body
4357 else
4358 if (ifstp == 0) &
4359 call wrtstt (zlin, 0, zlin, 0, &
4360 zlin (ichr:llin), &
4361 llin - ichr + 1, ichr-1)
4362 cycle body
4363 endif
4364
4365
4366
4367 case ('$')
4368 if (kktok /= kkndf) then
4369 call trttok (ztok, ltok, kktok)
4370 endif
4371 ntok = ntok + 1
4372 ltok = 1
4373 ztok (ltok:ltok) = '$'
4374 kktok = kkcmd
4375
4376
4377
4378 case ('#')
4379 if (ifsed /= 0) then
4380 if (kktok /= kkndf) then
4381 call trttok (ztok, ltok, kktok)
4382 endif
4383 ntok = ntok + 1
4384 ltok = 1
4385 ztok (ltok:ltok) = '$'
4386 kktok = kkcmd
4387 else
4388 if (kktok /= kkndf .and. ifcnt == 0) then
4389 call trttok (ztok, ltok, kktok)
4390 endif
4391 if (ifcnt == 0) then
4392 ntok = ntok + 1
4393 call trttok (zlin (ichr:llin),&
4394 (llin-ichr+1), kkcmt)
4395 exit body
4396 else
4397 if (ifstp == 0) &
4398 call wrtstt (zlin, 0, zlin, 0, &
4399 zlin (ichr:llin), &
4400 llin - ichr + 1, ichr-1)
4401 cycle body
4402 endif
4403 endif
4404
4405
4406
4407 case ('?')
4408 if (kktok /= kkndf) then
4409 call trttok (ztok, ltok, kktok)
4410 endif
4411 ntok = ntok + 1
4412 call trttok (zchr, 1, kkqst)
4413 kktok = kkndf
4414
4415
4416
4417 case ('&')
4418 ifcnt = 1
4419 if (ichr < llin) then
4420 inxt = verify (zlin (ichr+1:llin), &
4421 ztab // " ")
4422 if (inxt /= 0) then
4423 if (zlin (ichr+inxt:ichr+inxt) /= "!") then
4424 if (kktok /= kkndf) then
4425 call trttok (ztok, ltok, kktok)
4426 endif
4427 ntok = ntok + 1
4428 call trttok (zchr, 1, kkamp)
4429 kktok = kkndf
4430 ifcnt = 0
4431 endif
4432 endif
4433 endif
4434