![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to prtsht CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / pfort|
Return to prtsht CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 ! root 1: C XXXXXBLOCKDATA0.f ! 2: BLOCK DATA ! 3: C ! 4: C ! 5: C ! 6: C ! 7: C ! 8: C ! 9: C ! 10: C ! 11: C ! 12: C ! 13: C ! 14: C ! 15: C ! 16: C ! 17: C ! 18: C ! 19: C ! 20: C ! 21: C PFORT VERIFIER ! 22: C ! 23: C B. G. RYDER ! 24: C A. D. HALL ! 25: C ! 26: C BELL LABORATORIES, MURRAY HILL, NEW JERSEY 07974 ! 27: C ! 28: C ! 29: C COPYRIGHT C 1978, BELL TELEPHONE LABORATORIES, INCOR- ! 30: C PORATED. GENERAL PERMISSION IS GRANTED TO MAKE AND ! 31: C DISTRIBUTE UNMODIFIED COMPLETE COPIES OF THIS COMPUTER ! 32: C PROGRAM, BUT NOT FOR PROFIT, PROVIDED THAT THIS COPYRIGHT ! 33: C NOTICE AND STATEMENT ARE INCLUDED. ! 34: C ! 35: C ! 36: C ! 37: C ! 38: C ! 39: C ! 40: C ! 41: C ! 42: C ! 43: C ! 44: C ! 45: C ! 46: C ! 47: C ! 48: C ! 49: C ! 50: C ! 51: C ! 52: INTEGER Z ! 53: COMMON /INTS/ Z(346) ! 54: DATA Z(1) /3/ ! 55: DATA Z(2) /1HA/ ! 56: DATA Z(3) /1HB/ ! 57: DATA Z(4) /1HS/ ! 58: DATA Z(5) /201/ ! 59: DATA Z(6) /4/ ! 60: DATA Z(7) /1HI/ ! 61: DATA Z(8) /1HA/ ! 62: DATA Z(9) /1HB/ ! 63: DATA Z(10) /1HS/ ! 64: DATA Z(11) /210/ ! 65: DATA Z(12) /4/ ! 66: DATA Z(13) /1HD/ ! 67: DATA Z(14) /1HA/ ! 68: DATA Z(15) /1HB/ ! 69: DATA Z(16) /1HS/ ! 70: DATA Z(17) /192/ ! 71: DATA Z(18) /4/ ! 72: DATA Z(19) /1HA/ ! 73: DATA Z(20) /1HI/ ! 74: DATA Z(21) /1HN/ ! 75: DATA Z(22) /1HT/ ! 76: DATA Z(23) /201/ ! 77: DATA Z(24) /3/ ! 78: DATA Z(25) /1HI/ ! 79: DATA Z(26) /1HN/ ! 80: DATA Z(27) /1HT/ ! 81: DATA Z(28) /202/ ! 82: DATA Z(29) /5/ ! 83: DATA Z(30) /1HI/ ! 84: DATA Z(31) /1HD/ ! 85: DATA Z(32) /1HI/ ! 86: DATA Z(33) /1HN/ ! 87: DATA Z(34) /1HT/ ! 88: DATA Z(35) /194/ ! 89: DATA Z(36) /4/ ! 90: DATA Z(37) /1HA/ ! 91: DATA Z(38) /1HM/ ! 92: DATA Z(39) /1HO/ ! 93: DATA Z(40) /1HD/ ! 94: DATA Z(41) /329/ ! 95: DATA Z(42) /3/ ! 96: DATA Z(43) /1HM/ ! 97: DATA Z(44) /1HO/ ! 98: DATA Z(45) /1HD/ ! 99: DATA Z(46) /338/ ! 100: DATA Z(47) /5/ ! 101: DATA Z(48) /1HA/ ! 102: DATA Z(49) /1HM/ ! 103: DATA Z(50) /1HA/ ! 104: DATA Z(51) /1HX/ ! 105: DATA Z(52) /1H0/ ! 106: DATA Z(53) /273/ ! 107: DATA Z(54) /5/ ! 108: DATA Z(55) /1HA/ ! 109: DATA Z(56) /1HM/ ! 110: DATA Z(57) /1HA/ ! 111: DATA Z(58) /1HX/ ! 112: DATA Z(59) /1H1/ ! 113: DATA Z(60) /265/ ! 114: DATA Z(61) /4/ ! 115: DATA Z(62) /1HM/ ! 116: DATA Z(63) /1HA/ ! 117: DATA Z(64) /1HX/ ! 118: DATA Z(65) /1H0/ ! 119: DATA Z(66) /274/ ! 120: DATA Z(67) /4/ ! 121: DATA Z(68) /1HM/ ! 122: DATA Z(69) /1HA/ ! 123: DATA Z(70) /1HX/ ! 124: DATA Z(71) /1H1/ ! 125: DATA Z(72) /266/ ! 126: DATA Z(73) /5/ ! 127: DATA Z(74) /1HD/ ! 128: DATA Z(75) /1HM/ ! 129: DATA Z(76) /1HA/ ! 130: DATA Z(77) /1HX/ ! 131: DATA Z(78) /1H1/ ! 132: DATA Z(79) /256/ ! 133: DATA Z(80) /5/ ! 134: DATA Z(81) /1HA/ ! 135: DATA Z(82) /1HM/ ! 136: DATA Z(83) /1HI/ ! 137: DATA Z(84) /1HN/ ! 138: DATA Z(85) /1H0/ ! 139: DATA Z(86) /273/ ! 140: DATA Z(87) /5/ ! 141: DATA Z(88) /1HA/ ! 142: DATA Z(89) /1HM/ ! 143: DATA Z(90) /1HI/ ! 144: DATA Z(91) /1HN/ ! 145: DATA Z(92) /1H1/ ! 146: DATA Z(93) /265/ ! 147: DATA Z(94) /4/ ! 148: DATA Z(95) /1HM/ ! 149: DATA Z(96) /1HI/ ! 150: DATA Z(97) /1HN/ ! 151: DATA Z(98) /1H0/ ! 152: DATA Z(99) /274/ ! 153: DATA Z(100) /4/ ! 154: DATA Z(101) /1HM/ ! 155: DATA Z(102) /1HI/ ! 156: DATA Z(103) /1HN/ ! 157: DATA Z(104) /1H1/ ! 158: DATA Z(105) /266/ ! 159: DATA Z(106) /5/ ! 160: DATA Z(107) /1HD/ ! 161: DATA Z(108) /1HM/ ! 162: DATA Z(109) /1HI/ ! 163: DATA Z(110) /1HN/ ! 164: DATA Z(111) /1H1/ ! 165: DATA Z(112) /256/ ! 166: DATA Z(113) /5/ ! 167: DATA Z(114) /1HF/ ! 168: DATA Z(115) /1HL/ ! 169: DATA Z(116) /1HO/ ! 170: DATA Z(117) /1HA/ ! 171: DATA Z(118) /1HT/ ! 172: DATA Z(119) /209/ ! 173: DATA Z(120) /4/ ! 174: DATA Z(121) /1HI/ ! 175: DATA Z(122) /1HF/ ! 176: DATA Z(123) /1HI/ ! 177: DATA Z(124) /1HX/ ! 178: DATA Z(125) /202/ ! 179: DATA Z(126) /4/ ! 180: DATA Z(127) /1HS/ ! 181: DATA Z(128) /1HI/ ! 182: DATA Z(129) /1HG/ ! 183: DATA Z(130) /1HN/ ! 184: DATA Z(131) /329/ ! 185: DATA Z(132) /5/ ! 186: DATA Z(133) /1HI/ ! 187: DATA Z(134) /1HS/ ! 188: DATA Z(135) /1HI/ ! 189: DATA Z(136) /1HG/ ! 190: DATA Z(137) /1HN/ ! 191: DATA Z(138) /338/ ! 192: DATA Z(139) /5/ ! 193: DATA Z(140) /1HD/ ! 194: DATA Z(141) /1HS/ ! 195: DATA Z(142) /1HI/ ! 196: DATA Z(143) /1HG/ ! 197: DATA Z(144) /1HN/ ! 198: DATA Z(145) /320/ ! 199: DATA Z(146) /3/ ! 200: DATA Z(147) /1HD/ ! 201: DATA Z(148) /1HI/ ! 202: DATA Z(149) /1HM/ ! 203: DATA Z(150) /329/ ! 204: DATA Z(151) /4/ ! 205: DATA Z(152) /1HI/ ! 206: DATA Z(153) /1HD/ ! 207: DATA Z(154) /1HI/ ! 208: DATA Z(155) /1HM/ ! 209: DATA Z(156) /338/ ! 210: DATA Z(157) /4/ ! 211: DATA Z(158) /1HS/ ! 212: DATA Z(159) /1HN/ ! 213: DATA Z(160) /1HG/ ! 214: DATA Z(161) /1HL/ ! 215: DATA Z(162) /193/ ! 216: DATA Z(163) /4/ ! 217: DATA Z(164) /1HR/ ! 218: DATA Z(165) /1HE/ ! 219: DATA Z(166) /1HA/ ! 220: DATA Z(167) /1HL/ ! 221: DATA Z(168) /217/ ! 222: DATA Z(169) /5/ ! 223: DATA Z(170) /1HA/ ! 224: DATA Z(171) /1HI/ ! 225: DATA Z(172) /1HM/ ! 226: DATA Z(173) /1HA/ ! 227: DATA Z(174) /1HG/ ! 228: DATA Z(175) /217/ ! 229: DATA Z(176) /4/ ! 230: DATA Z(177) /1HD/ ! 231: DATA Z(178) /1HB/ ! 232: DATA Z(179) /1HL/ ! 233: DATA Z(180) /1HE/ ! 234: DATA Z(181) /200/ ! 235: DATA Z(182) /5/ ! 236: DATA Z(183) /1HC/ ! 237: DATA Z(184) /1HM/ ! 238: DATA Z(185) /1HP/ ! 239: DATA Z(186) /1HL/ ! 240: DATA Z(187) /1HX/ ! 241: DATA Z(188) /331/ ! 242: DATA Z(189) /5/ ! 243: DATA Z(190) /1HC/ ! 244: DATA Z(191) /1HO/ ! 245: DATA Z(192) /1HN/ ! 246: DATA Z(193) /1HJ/ ! 247: DATA Z(194) /1HG/ ! 248: DATA Z(195) /219/ ! 249: DATA Z(196) /3/ ! 250: DATA Z(197) /1HE/ ! 251: DATA Z(198) /1HX/ ! 252: DATA Z(199) /1HP/ ! 253: DATA Z(200) /713/ ! 254: DATA Z(201) /4/ ! 255: DATA Z(202) /1HD/ ! 256: DATA Z(203) /1HE/ ! 257: DATA Z(204) /1HX/ ! 258: DATA Z(205) /1HP/ ! 259: DATA Z(206) /704/ ! 260: DATA Z(207) /4/ ! 261: DATA Z(208) /1HC/ ! 262: DATA Z(209) /1HE/ ! 263: DATA Z(210) /1HX/ ! 264: DATA Z(211) /1HP/ ! 265: DATA Z(212) /731/ ! 266: DATA Z(213) /4/ ! 267: DATA Z(214) /1HA/ ! 268: DATA Z(215) /1HL/ ! 269: DATA Z(216) /1HO/ ! 270: DATA Z(217) /1HG/ ! 271: DATA Z(218) /713/ ! 272: DATA Z(219) /4/ ! 273: DATA Z(220) /1HD/ ! 274: DATA Z(221) /1HL/ ! 275: DATA Z(222) /1HO/ ! 276: DATA Z(223) /1HG/ ! 277: DATA Z(224) /704/ ! 278: DATA Z(225) /4/ ! 279: DATA Z(226) /1HC/ ! 280: DATA Z(227) /1HL/ ! 281: DATA Z(228) /1HO/ ! 282: DATA Z(229) /1HG/ ! 283: DATA Z(230) /731/ ! 284: DATA Z(231) /6/ ! 285: DATA Z(232) /1HA/ ! 286: DATA Z(233) /1HL/ ! 287: DATA Z(234) /1HO/ ! 288: DATA Z(235) /1HG/ ! 289: DATA Z(236) /1H1/ ! 290: DATA Z(237) /1H0/ ! 291: DATA Z(238) /713/ ! 292: DATA Z(239) /6/ ! 293: DATA Z(240) /1HD/ ! 294: DATA Z(241) /1HL/ ! 295: DATA Z(242) /1HO/ ! 296: DATA Z(243) /1HG/ ! 297: DATA Z(244) /1H1/ ! 298: DATA Z(245) /1H0/ ! 299: DATA Z(246) /704/ ! 300: DATA Z(247) /3/ ! 301: DATA Z(248) /1HS/ ! 302: DATA Z(249) /1HI/ ! 303: DATA Z(250) /1HN/ ! 304: DATA Z(251) /713/ ! 305: DATA Z(252) /4/ ! 306: DATA Z(253) /1HD/ ! 307: DATA Z(254) /1HS/ ! 308: DATA Z(255) /1HI/ ! 309: DATA Z(256) /1HN/ ! 310: DATA Z(257) /704/ ! 311: DATA Z(258) /4/ ! 312: DATA Z(259) /1HC/ ! 313: DATA Z(260) /1HS/ ! 314: DATA Z(261) /1HI/ ! 315: DATA Z(262) /1HN/ ! 316: DATA Z(263) /731/ ! 317: DATA Z(264) /3/ ! 318: DATA Z(265) /1HC/ ! 319: DATA Z(266) /1HO/ ! 320: DATA Z(267) /1HS/ ! 321: DATA Z(268) /713/ ! 322: DATA Z(269) /4/ ! 323: DATA Z(270) /1HD/ ! 324: DATA Z(271) /1HC/ ! 325: DATA Z(272) /1HO/ ! 326: DATA Z(273) /1HS/ ! 327: DATA Z(274) /704/ ! 328: DATA Z(275) /4/ ! 329: DATA Z(276) /1HC/ ! 330: DATA Z(277) /1HC/ ! 331: DATA Z(278) /1HO/ ! 332: DATA Z(279) /1HS/ ! 333: DATA Z(280) /731/ ! 334: DATA Z(281) /4/ ! 335: DATA Z(282) /1HT/ ! 336: DATA Z(283) /1HA/ ! 337: DATA Z(284) /1HN/ ! 338: DATA Z(285) /1HH/ ! 339: DATA Z(286) /713/ ! 340: DATA Z(287) /4/ ! 341: DATA Z(288) /1HS/ ! 342: DATA Z(289) /1HQ/ ! 343: DATA Z(290) /1HR/ ! 344: DATA Z(291) /1HT/ ! 345: DATA Z(292) /713/ ! 346: DATA Z(293) /5/ ! 347: DATA Z(294) /1HD/ ! 348: DATA Z(295) /1HS/ ! 349: DATA Z(296) /1HQ/ ! 350: DATA Z(297) /1HR/ ! 351: DATA Z(298) /1HT/ ! 352: DATA Z(299) /704/ ! 353: DATA Z(300) /5/ ! 354: DATA Z(301) /1HC/ ! 355: DATA Z(302) /1HS/ ! 356: DATA Z(303) /1HQ/ ! 357: DATA Z(304) /1HR/ ! 358: DATA Z(305) /1HT/ ! 359: DATA Z(306) /731/ ! 360: DATA Z(307) /4/ ! 361: DATA Z(308) /1HA/ ! 362: DATA Z(309) /1HT/ ! 363: DATA Z(310) /1HA/ ! 364: DATA Z(311) /1HN/ ! 365: DATA Z(312) /713/ ! 366: DATA Z(313) /5/ ! 367: DATA Z(314) /1HD/ ! 368: DATA Z(315) /1HA/ ! 369: DATA Z(316) /1HT/ ! 370: DATA Z(317) /1HA/ ! 371: DATA Z(318) /1HN/ ! 372: DATA Z(319) /704/ ! 373: DATA Z(320) /5/ ! 374: DATA Z(321) /1HA/ ! 375: DATA Z(322) /1HT/ ! 376: DATA Z(323) /1HA/ ! 377: DATA Z(324) /1HN/ ! 378: DATA Z(325) /1H2/ ! 379: DATA Z(326) /841/ ! 380: DATA Z(327) /6/ ! 381: DATA Z(328) /1HD/ ! 382: DATA Z(329) /1HA/ ! 383: DATA Z(330) /1HT/ ! 384: DATA Z(331) /1HA/ ! 385: DATA Z(332) /1HN/ ! 386: DATA Z(333) /1H2/ ! 387: DATA Z(334) /832/ ! 388: DATA Z(335) /4/ ! 389: DATA Z(336) /1HD/ ! 390: DATA Z(337) /1HM/ ! 391: DATA Z(338) /1HO/ ! 392: DATA Z(339) /1HD/ ! 393: DATA Z(340) /832/ ! 394: DATA Z(341) /4/ ! 395: DATA Z(342) /1HC/ ! 396: DATA Z(343) /1HA/ ! 397: DATA Z(344) /1HB/ ! 398: DATA Z(345) /1HS/ ! 399: DATA Z(346) /729/ ! 400: END ! 401: C XXXXXBLOCKDATA1.f ! 402: BLOCK DATA ! 403: INTEGER EX(4,4), PT, PB, AO(4,4), RO(3,3) ! 404: COMMON /EXPRS/ PT, PB, AO, RO, EX ! 405: DATA AO(1,1), AO(1,2), AO(2,1) /3*0/, AO(1,3), AO(1,4), AO(3,1), ! 406: * AO(3,2), AO(4,1), AO(4,3) /6*-1/, AO(2,2) /1/, AO(3,3) /2/, ! 407: * AO(4,4), AO(2,4), AO(4,2) /3*3/, AO(3,4), AO(2,3) /2*-1/ ! 408: DATA RO(1,1), RO(1,2), RO(2,1), RO(2,2), RO(3,3) /5*4/, RO(1,3), ! 409: * RO(2,3), RO(3,1), RO(3,2) /4*-1/ ! 410: DATA EX(1,1) /0/, EX(1,2) /0/, EX(1,3) /0/, EX(1,4) /-1/, EX(2,1) ! 411: * /0/, EX(2,2) /1/, EX(2,3) /1/, EX(2,4) /-1/, EX(3,1) /-1/, ! 412: * EX(3,2) /-1/, EX(3,3) /2/, EX(3,4) /-1/, EX(4,1) /-1/, ! 413: * EX(4,2) /-1/, EX(4,3) /3/, EX(4,4) /-1/ ! 414: END ! 415: C XXXXXBLOCKDATA2.f ! 416: BLOCK DATA ! 417: C ! 418: COMMON /TRANS/ Q(70) ! 419: INTEGER Q ! 420: C ! 421: DATA Q(1) /1H0/, Q(2) /1H1/, Q(3) /1H2/, Q(4) /1H3/, Q(5) /1H4/ ! 422: DATA Q(6) /1H5/, Q(7) /1H6/, Q(8) /1H7/, Q(9) /1H8/, Q(10) /1H9/ ! 423: C ! 424: DATA Q(31) /1HA/, Q(32) /1HB/, Q(33) /1HC/, Q(34) /1HD/, Q(35) / ! 425: * 1HE/ ! 426: DATA Q(36) /1HF/, Q(37) /1HG/, Q(38) /1HH/, Q(39) /1HI/, Q(40) / ! 427: * 1HJ/ ! 428: DATA Q(41) /1HK/, Q(42) /1HL/, Q(43) /1HM/, Q(44) /1HN/, Q(45) / ! 429: * 1HO/ ! 430: DATA Q(46) /1HP/, Q(47) /1HQ/, Q(48) /1HR/, Q(49) /1HS/, Q(50) / ! 431: * 1HT/ ! 432: DATA Q(51) /1HU/, Q(52) /1HV/, Q(53) /1HW/, Q(54) /1HX/, Q(55) / ! 433: * 1HY/ ! 434: DATA Q(56) /1HZ/ ! 435: C ! 436: DATA Q(61) /1H+/, Q(62) /1H-/, Q(63) /1H)/, Q(64) /1H=/, Q(65) / ! 437: * 1H./ ! 438: DATA Q(66) /1H(/, Q(67) /1H*/, Q(68) /1H//, Q(69) /1H,/, Q(70) / ! 439: * 1H / ! 440: END ! 441: C XXXXXBLOCKDATA3.f ! 442: BLOCK DATA ! 443: INTEGER K(186), KI(30), KT(30) ! 444: COMMON /STS/ K, KI, KT ! 445: DATA K(1) /33/, K(2) /44/, K(3) /50/, K(4) /31/, K(5) /41/, K(6) ! 446: * /34/, K(7) /45/, K(8) /47/, K(9) /34/, K(10) /32/, K(11) ! 447: * /38/, K(12) /48/, K(13) /38/, K(14) /44/, K(15) /43/ ! 448: DATA K(16) /47/, K(17) /34/, K(18) /30/, K(19) /41/ ! 449: DATA K(20) /38/, K(21) /43/, K(22) /49/, K(23) /34/, K(24) /36/, ! 450: * K(25) /34/, K(26) /47/ ! 451: DATA K(27) /32/, K(28) /44/, K(29) /42/, K(30) /45/, K(31) /41/, ! 452: * K(32) /34/, K(33) /53/, K(34) /41/, K(35) /44/, K(36) /36/, ! 453: * K(37) /38/, K(38) /32/, K(39) /30/, K(40) /41/ ! 454: DATA K(41) /34/, K(42) /53/, K(43) /49/, K(44) /34/, K(45) /47/, ! 455: * K(46) /43/, K(47) /30/, K(48) /41/, K(49) /33/, K(50) /38/, ! 456: * K(51) /42/, K(52) /34/, K(53) /43/, K(54) /48/, K(55) /38/, ! 457: * K(56) /44/, K(57) /43/, K(58) /32/, K(59) /44/, K(60) /42/, ! 458: * K(61) /42/, K(62) /44/, K(63) /43/, K(64) /48/, K(65) /50/, ! 459: * K(66) /31/, K(67) /47/, K(68) /44/, K(69) /50/, K(70) /49/, ! 460: * K(71) /38/, K(72) /43/, K(73) /34/ ! 461: DATA K(74) /35/, K(75) /50/, K(76) /43/, K(77) /32/, K(78) /49/, ! 462: * K(79) /38/, K(80) /44/, K(81) /43/, K(82) /31/, K(83) /41/, ! 463: * K(84) /44/, K(85) /32/, K(86) /40/, K(87) /33/, K(88) /30/, ! 464: * K(89) /49/, K(90) /30/, K(91) /34/, K(92) /46/, K(93) /50/, ! 465: * K(94) /38/, K(95) /51/, K(96) /30/, K(97) /41/, K(98) /34/, ! 466: * K(99) /43/, K(100) /32/, K(101) /34/, K(102) /33/, K(103) ! 467: * /30/, K(104) /49/, K(105) /30/ ! 468: DATA K(106) /30/, K(107) /48/, K(108) /48/, K(109) /38/, K(110) ! 469: * /36/, K(111) /43/, K(112) /36/, K(113) /44/, K(114) /49/, ! 470: * K(115) /44/, K(116) /47/, K(117) /34/, K(118) /49/, K(119) ! 471: * /50/, K(120) /47/, K(121) /43/ ! 472: DATA K(122) /32/, K(123) /44/, K(124) /43/, K(125) /49/, K(126) ! 473: * /38/, K(127) /43/, K(128) /50/, K(129) /34/, K(130) /32/, ! 474: * K(131) /30/, K(132) /41/, K(133) /41/, K(134) /48/, K(135) ! 475: * /49/, K(136) /44/, K(137) /45/, K(138) /38/, K(139) /35/, ! 476: * K(140) /33/, K(141) /44/, K(142) /45/, K(143) /30/, K(144) ! 477: * /50/, K(145) /48/, K(146) /34/ ! 478: DATA K(147) /47/, K(148) /34/, K(149) /30/, K(150) /33/, K(151) ! 479: * /52/, K(152) /47/, K(153) /38/, K(154) /49/, K(155) /34/, ! 480: * K(156) /47/, K(157) /34/, K(158) /52/, K(159) /38/, K(160) ! 481: * /43/, K(161) /33/, K(162) /34/, K(163) /43/, K(164) /33/, ! 482: * K(165) /35/, K(166) /38/, K(167) /41/, K(168) /34/, K(169) ! 483: * /31/, K(170) /30/, K(171) /32/, K(172) /40/, K(173) /48/, ! 484: * K(174) /45/, K(175) /30/, K(176) /32/, K(177) /34/, K(178) ! 485: * /34/, K(179) /43/, K(180) /33/ ! 486: DATA K(181) /35/, K(182) /44/, K(183) /47/, K(184) /42/, K(185) ! 487: * /30/, K(186) /49/ ! 488: DATA KI(1) /15/, KI(2) /4/, KI(3) /7/, KI(4) /7/, KI(5) /7/, ! 489: * KI(6) /8/, KI(7) /9/, KI(8) /6/, KI(9) /10/, KI(10) /8/, ! 490: * KI(11) /9/, KI(12) /11/, KI(13) /4/, KI(14) /6/, KI(15) /4/, ! 491: * KI(16) /6/, KI(17) /8/, KI(18) /4/, KI(19) /4/, KI(20) /2/, ! 492: * KI(21) /2/, KI(22) /5/, KI(23) /4/, KI(24) /5/, KI(25) /6/, ! 493: * KI(26) /7/, KI(27) /9/, KI(28) /3/, KI(29) /6/, KI(30) /0/ ! 494: DATA KT(1), KT(2), KT(3), KT(4), KT(5), KT(6), KT(7), KT(8) ! 495: * /8*1/, KT(9), KT(10), KT(11) /3*0/, KT(12) /2/, KT(13) /3/, ! 496: * KT(14), KT(15), KT(16), KT(17), KT(18), KT(19), KT(20), ! 497: * KT(21), KT(22), KT(23), KT(24), KT(25), KT(26), KT(27) ! 498: * /14*5/, KT(29), KT(30) /2*5/, KT(28) /6/ ! 499: END ! 500: C XXXXXMAIN0.f ! 501: INTEGER STMT, PSTMT, SYMLEN, OUTUT, SYMHD, BNEXT, HASH, DSA, ! 502: * STACK, DOLIST, DOPT, OUTUT2, OUTUT3, PDSA, OUTUT4, REF, PREF, ! 503: * PNODE, PLAT, PCOM, COM ! 504: LOGICAL ERR, SYSERR, OPT, P1ERR, ABORT, P2 ! 505: LOGICAL SW, QBR ! 506: COMMON /SWS/ SW(10) ! 507: C*****SWS ! 508: C SW(1) (LOG) IF TRUE, CAN USE END= OPTION IN READ STMTS ! 509: C ! 510: COMMON /OPTNS/ OPT(5), P1ERR ! 511: C ! 512: C*****OPTNS ! 513: C OPT(1) (LOG) IF TRUE, SYMBOL TABLE PRINTED FOR EACH P. U. ! 514: C OPT(2) (LOG) IF TRUE, CROSS REFERENCES PRINTED FOR EACH SYMBOL ! 515: C OPT(3) (LOG) IF TRUE, PASS 2 IS EXECUTED ! 516: C OPT(4) (LOG) IF TRUE, LISTING PRINTED FOR EACH P. U. ! 517: C OPT(5) (LOG) IF TRUE, FORTRAN PGM COMPILED AFTER VERIFIER ! 518: C RUN; IF ANY OF THESE ARE FALSE THE CORRESPONDING ACTION IS NOT TA ! 519: C P1ERR (LOG) SET TO TRUE IF INFO NORMALLY SAVED FOR PASS 2 IS ! 520: C SUPPRESSED FOR THIS P. U. ! 521: C ! 522: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 523: C ! 524: C*****INPUT ! 525: C NSTMT (INT) INDEX OF END-OF-INPUT-STMT CHARACTER IN STMT ! 526: C PSTMT (INT) POINTS TO CURRENT POSITION IN STMT (EXCEPT IN LEXICAL ! 527: C SUBPGMS WHERE IT IS UPDATED IN CALLING SUBPGM AFTER A TOKEN IS ! 528: C FOUND) ! 529: C STMT (INT) ENCODED FORM OF DEBLANKED INPUT STMT ! 530: C ! 531: COMMON /CEXPRS/ LSTACK, STACK(620) ! 532: C ! 533: C*****CEXPRS ! 534: C LSTACK (INT) LENGTH OF STACK ! 535: C STACK(*), (INT) ARRAY USED IN EXPR AS A STACK; ALSO FOR AUXILLARY ! 536: C STORAGE AND OUTPUT ! 537: C ! 538: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, ! 539: * OUTUT4 ! 540: C ! 541: C*****PARAMS ! 542: C INUT (INT) LOGICAL INPUT NUMBER FOR THE HOST MACHINE ! 543: C OUTUT (INT) LOGICAL OUTPUT NUMBER FOR THE HOST MACHINE ! 544: C NOCHAR (INT) NUMBER OF CHARACTERS PER MACHINE WORD IN HOST ! 545: C SYMLEN (INT) NUMBER OF WORDS NECESSARY ON HOST TO STORE 6 ! 546: C CHARACTERS (I.E. A FORTRAN SYMBOL) ! 547: C OUTUT2 (INT), OUTUT3(INT), OUTUT4(INT) LOGICAL OUTPUT NUMBERS ! 548: C FOR THE HOST MACHINE TO BE USED BY THE VERIFIER FOR INTERPASS ! 549: C COMMUNICATION ! 550: C ! 551: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 552: C ! 553: C*****FACTS ! 554: C NAME (INT) INDEX IN SYMBOL TABLE OF ENTRY FOR CURRENT P.U. ! 555: C NOST (INT) STMT NUMBER OF CURRENT STMT BEING PROCESSED ! 556: C ITYP (INT) TYPE OF STMT CURRENTLY BEING PROCESSED (SEE PU ! 557: C FOR FURTHER DOC) ! 558: C ! 559: COMMON /DETECT/ ERR, SYSERR, ABORT ! 560: C ! 561: C*****DETECT ! 562: C ERROR (LOG) SET TO TRUE IN VARIOUS SUBPGMS USUALLY TO CEASE PROCES ! 563: C OF CURRENT STMT ! 564: C SYSERR (LOG) IRRECOVERABLE ERROR IN SYSTEM; (E.G., TABLE OVERFLOW) ! 565: C IN PASS 1 CAUSES CURRENT P.U. TO HAVE AN END STMT SIMULATED AND ! 566: C EXECUTION PROCEDES TO NEXT P.U.; IN PASS 2 CAUSES PROCESSING ! 567: C OF PROGRAM TO CEASE. ! 568: C ! 569: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 570: C ! 571: C*****TABL ! 572: C NEXT (INT) POINTS TO NEXT FREE WORD IN DSA (COUNTING FROM DSA(1)) ! 573: C LABHD (INT) POINTS TO HEAD OF LINEAR LINKED LIST IN DSA OF ALL ! 574: C LABELS IN P.U. ! 575: C SYMHD (INT) POINTS TO HEAD OF LINEAR LINKED LIST IN DSA OF ALL ! 576: C SYMBOLS IN P.U. ! 577: C BNEXT (INT) POINTS TO NEXT FREE WORD IN DSA (COUNTING FROM ! 578: C DSA(LDSA)) ! 579: C ! 580: COMMON /CHASH/ LHASH, HASH(401) ! 581: C ! 582: C*****CHASH ! 583: C LHASH (INT) LENGTH OF HASH ARRAY ! 584: C HASH (*) (INT) HASH TABLE USED TO INDEX INTO DSA ! 585: C ! 586: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 587: C ! 588: C*****CTABL ! 589: C LDSA (INT) LENGTH OF DSA ! 590: C DSA(*) (INT) SYMBOL TABLE (SEE LOOKUP FOR MORE EXPLICIT DOC) ! 591: C ! 592: COMMON /DOS/ DOPT, LDO, DOLIST(192) ! 593: C ! 594: C*****DOS ! 595: C DOPT (INT) POINTER TO FIRST FREE WORD IN DOLIST ! 596: C LDO (INT) LENGTH OF DOLIST ! 597: C DOLIST (*) (INT) ARRAY USED AS STACK FOR NESTING OF DOS (USED ! 598: C TO TEST FOR LEGAL BRANCHING WITHIN P.U. (SEE DOSPEC FOR FURTHER ! 599: C DOC) ! 600: C ! 601: COMMON /LISTDO/ LPT, LEN, LS(64) ! 602: C ! 603: C*****LISTDO ! 604: C LPT (INT) POINTER TO FIRST FREE WORD IN LS ! 605: C LEN (INT) LENGTH OF LS ! 606: C LS (*) (INT) ARRAY USED AS STACK FOR NESTING OF IMPLIED ! 607: C DO'S IN INPUT/OUTPUT STMTS (SEE DOSPEC FOR FURTHER DOC) ! 608: C ! 609: COMMON /PASS/ P2, QBR ! 610: C ! 611: C*****PASS ! 612: C P2 (LOG) IF TRUE, VERIFIER IS IN PASS 2; ELSE VERIFIER IS IN PASS ! 613: C QBR (LOG) IF TRUE, VERIFIER IS TO PRINT ERROR MESSAGES ! 614: C ELSE IS NOT ! 615: C ! 616: COMMON /CREF/ LREF, PREF, REF(100) ! 617: C ! 618: C*****CREF ! 619: C LREF (INT) TOTAL LENGTH OF ARRAY REF ! 620: C PREF (INT) CURRENT LENGTH OF REF ! 621: C REF (*) (INT) ARRAY CONTAINING INFORMATION CONCERNING A SUBR/FCN ! 622: C REF (SEE SETREF FOR FURTHER DOC) ! 623: C ! 624: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 625: C ! 626: C*****HEAD ! 627: C LNODE (INT) LENGTH OF NODE ! 628: C PNODE (INT) POINTER TO NEXT FREE WORD IN NODE ! 629: C NODE (*) (INT) ARRAY OF INDICES OF P.U. ENTRIES IN LAT ! 630: C ! 631: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 632: C ! 633: C*****GRAPH ! 634: C LLAT (INT) LENGTH OF LAT ! 635: C PLAT (INT) POINTER TO NEXT FREE WORD IN LAT ! 636: C LAT (*) (INT) ARRAY WHOSE ENTRIES DESCRIBE EACH P.U. IN PGM ! 637: C AND THEIR INTER-RELNS (SEE SETNOD FOR FURTHER DOC) ! 638: C ! 639: COMMON /COMS/ LCOM, PCOM, COM(300) ! 640: C ! 641: C*****COMS ! 642: C LCOM (INT) LENGTH OF COM ! 643: C PCOM (INT) POINTER TO NEXT FREE WORD IN COM ! 644: C COM (*) (INT) ARRAY WHOSE ENTRIES DESCRIBE EACH COMMON BLOCK ! 645: C IN PGM (SEE SETCOM FOR FURTHER DOC) ! 646: COMMON /SCR1/ LINODE, INODE(500) ! 647: COMMON /SCR2/ LNNODE, NNODE(500) ! 648: C ! 649: C***SCR1,SCR2,SCR3 ! 650: C INODE(INT), NNODE(INT) SCRATCH ARRAYS KEYED ON LENGTH NODE(*) ! 651: C LINNODE = LNNODE .GE. MAX( LNODE, LCOM/(SYMLEN+5) ) ! 652: C ! 653: C THREE MORE BLOCK COMMON REGIONS ARE USED : STS -SEE TYPST ! 654: C TRANS - SEE MAPCHR EXPRS - SEE EXPR FOR FURTHER DOC ! 655: C ! 656: QBR = .FALSE. ! 657: NOCHAR = 4 ! 658: INUT = 5 ! 659: OUTUT = 6 ! 660: OUTUT2 = 7 ! 661: OUTUT3 = 8 ! 662: OUTUT4 = 9 ! 663: C NOCHAR WAS &, OUT2-4 was 12,13,14 in distribution tape ! 664: REWIND INUT ! 665: REWIND OUTUT2 ! 666: REWIND OUTUT3 ! 667: REWIND OUTUT4 ! 668: LEN = 64 ! 669: SYMLEN = (5/NOCHAR) + 1 ! 670: P2 = .FALSE. ! 671: ERR = .FALSE. ! 672: ABORT = .FALSE. ! 673: SYSERR = .FALSE. ! 674: SW(1) = .FALSE. ! 675: PDSA = 1 ! 676: LDSA = 5000 ! 677: LHASH = 401 ! 678: DO 10 I=1,LHASH ! 679: HASH(I) = 0 ! 680: 10 CONTINUE ! 681: OPT(1) = .TRUE. ! 682: OPT(2) = .TRUE. ! 683: OPT(3) = .TRUE. ! 684: OPT(4) = .TRUE. ! 685: OPT(5) = .FALSE. ! 686: LSTACK = 620 ! 687: LREF = 100 ! 688: PREF = 1 ! 689: LDO = 192 ! 690: CALL OVRLAY(1) ! 691: CALL PU ! 692: IF (.NOT.OPT(3) .OR. SYSERR) GO TO 30 ! 693: P2 = .TRUE. ! 694: IF (.NOT.OPT(4)) WRITE (OUTUT,99999) ! 695: 99999 FORMAT (1H1) ! 696: CALL OVRLAY(2) ! 697: LLAT = 6000 ! 698: PLAT = 1 ! 699: BNEXT = LDSA ! 700: NEXT = 1 ! 701: LNODE = 500 ! 702: PNODE = 1 ! 703: LCOM = 300 ! 704: PCOM = 1 ! 705: LINODE = LNODE ! 706: LNNODE = LNODE ! 707: C ! 708: C PASS 1 CAN SUPPRESS PASS 2 PROCESSING FOR SPECIFIC P.U. ! 709: C BUT NEVER SHUTS OFF PASS 2 COMPLETELY; PASS 2 CAN CEASE ! 710: C PROCESSING FOR VARIOUS REASONS: ! 711: C 1. 2 SUBPRGMS WITH SAME NAME(IN SETNOD) ! 712: C 2. NO PROGRAM UNIT SUCCESSFULLY PASSED TO PASS 2 ! 713: C (IN CONSTR) ! 714: C 3. RECURSION (IN ASLEV AND INVOKE) ! 715: C IF MISSING SUBPRGMS ARE DISCOVERED, PASS 2 CAN ! 716: C PROCEDE WITH INCOMPLETE PROCESSING, A MESSAGE ! 717: C IS PRINTED TO INFORM THE USER ! 718: C ! 719: REWIND OUTUT2 ! 720: REWIND OUTUT3 ! 721: REWIND OUTUT4 ! 722: CALL CONSTR(IROOT) ! 723: C CAN RETURN FROM CONSTR IN ERROR CONDITION WITH FILES LACKING ! 724: C VERIFIER SOFTWARE END OF FILE ! 725: IF (ABORT .OR. SYSERR) GO TO 30 ! 726: REWIND OUTUT4 ! 727: REWIND OUTUT3 ! 728: REWIND OUTUT2 ! 729: CALL CHECKS(IROOT) ! 730: 20 REWIND INUT ! 731: CALL OVRLAY(3) ! 732: CALL COMPIL(.NOT.(ABORT.OR.SYSERR).AND.OPT(5)) ! 733: STOP ! 734: 30 WRITE (OUTUT,99998) ! 735: 99998 FORMAT (47H1INTER-PROGRAM-UNIT COMMUNICATIONS NOT VERIFIED) ! 736: GO TO 20 ! 737: END ! 738: C XXXXXCOMPIL.f ! 739: SUBROUTINE COMPIL(FLAG) ! 740: C ! 741: LOGICAL FLAG ! 742: C ! 743: RETURN ! 744: C ! 745: END ! 746: C XXXXXOVRLAY.f ! 747: SUBROUTINE OVRLAY(N) ! 748: C ! 749: RETURN ! 750: C ! 751: END ! 752: C XXXXXSATT1.f ! 753: SUBROUTINE SATT1(INDEX, FIELD, ATT) ! 754: C ! 755: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 756: C ! 757: INTEGER INDEX, FIELD, ATT ! 758: INTEGER LDSA, PDSA, DSA ! 759: INTEGER FWTH(8), FPOS(8) ! 760: C ! 761: DATA FWTH(1) /16/, FPOS(1) /1/ ! 762: DATA FWTH(2) /2/, FPOS(2) /16/ ! 763: DATA FWTH(3) /2/, FPOS(3) /32/ ! 764: DATA FWTH(4) /2/, FPOS(4) /64/ ! 765: DATA FWTH(5) /2/, FPOS(5) /128/ ! 766: DATA FWTH(6) /2/, FPOS(6) /256/ ! 767: DATA FWTH(7) /4/, FPOS(7) /512/ ! 768: DATA FWTH(8) /32/, FPOS(8) /2048/ ! 769: C ! 770: DSA(INDEX) = DSA(INDEX) + (ATT-MOD(DSA(INDEX)/FPOS(FIELD), ! 771: * FWTH(FIELD)))*FPOS(FIELD) ! 772: C ! 773: RETURN ! 774: C ! 775: END ! 776: C XXXXXIGATT1.f ! 777: INTEGER FUNCTION IGATT1(INDEX, FIELD) ! 778: C ! 779: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 780: C ! 781: INTEGER INDEX, FIELD ! 782: INTEGER LDSA, PDSA, DSA ! 783: INTEGER FWTH(8), FPOS(8) ! 784: C ! 785: DATA FWTH(1) /16/, FPOS(1) /1/ ! 786: DATA FWTH(2) /2/, FPOS(2) /16/ ! 787: DATA FWTH(3) /2/, FPOS(3) /32/ ! 788: DATA FWTH(4) /2/, FPOS(4) /64/ ! 789: DATA FWTH(5) /2/, FPOS(5) /128/ ! 790: DATA FWTH(6) /2/, FPOS(6) /256/ ! 791: DATA FWTH(7) /4/, FPOS(7) /512/ ! 792: DATA FWTH(8) /32/, FPOS(8) /2048/ ! 793: C ! 794: IGATT1 = MOD(DSA(INDEX)/FPOS(FIELD),FWTH(FIELD)) ! 795: C ! 796: RETURN ! 797: C ! 798: END ! 799: C XXXXXEXCH.f ! 800: INTEGER FUNCTION EXCH(J1, J2, DSA, LDSA, HASH, LHASH, OFFSET) ! 801: INTEGER DSA(LDSA), HASH(LHASH), OFFSET ! 802: INTEGER OUTUT, SYMLEN, OUTUT2, OUTUT3, OUTUT4 ! 803: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, ! 804: * OUTUT4 ! 805: C ! 806: C DSA(HASH(J1)+OFFSET) CONTAINS ELE TO BE COMPARED ! 807: C DSA(HASH(J2)+OFFSET) CONTAINS ELE TO BE COMPARED ! 808: C ! 809: JJ1 = HASH(J1) + OFFSET ! 810: JJ2 = HASH(J2) + OFFSET ! 811: DO 40 I=1,SYMLEN ! 812: K1 = JJ1 + I - 1 ! 813: K2 = JJ2 + I - 1 ! 814: IF (DSA(K1)) 10, 20, 20 ! 815: 10 IF (DSA(K2)) 30, 50, 50 ! 816: 20 IF (DSA(K2)) 70, 30, 30 ! 817: 30 IF (DSA(K1)-DSA(K2)) 70, 40, 50 ! 818: 40 CONTINUE ! 819: C ! 820: C COMPARISON SHOWS ELEMENTS IN PROPER ORDER ! 821: C ! 822: 50 EXCH = 0 ! 823: 60 RETURN ! 824: C ! 825: C COMPARISON SHOWS NEED FOR EXCHANGE ! 826: C ! 827: 70 I = HASH(J1) ! 828: HASH(J1) = HASH(J2) ! 829: HASH(J2) = I ! 830: EXCH = -1 ! 831: GO TO 60 ! 832: END ! 833: C XXXXXSSORT.f ! 834: SUBROUTINE SSORT(EX, X, LX, Q, L, OFFSET) ! 835: INTEGER EX, X(LX), Q(L), OFFSET ! 836: EXTERNAL EX ! 837: C ! 838: C ENTRIES SPACED 1 APART IN HASH TABLE ! 839: C EX IS EXCHANGE ROUTINE--RETURNS<0 IF EXCHANGES ITEMS ! 840: C RETURNS >=0 IF DOESN'T ! 841: C L IS NUMBER OF THINGS TO BE SORTED, SPACING IS 1 HERE ! 842: C START SHELL SORT ! 843: C ! 844: M = 1 ! 845: 10 IF (M.GE.L) GO TO 20 ! 846: M = M*2 ! 847: GO TO 10 ! 848: 20 M = M/2 ! 849: IF (M.LT.1) RETURN ! 850: K = L - M ! 851: C ! 852: C IN PASS1 ARE SORTING SYMBOL TABLE ! 853: C IN PASS 2 ARE SORTING LATTICE ! 854: C OR COMMON BLOCK DEFS ! 855: C ! 856: DO 50 J=1,K ! 857: I = J ! 858: 30 IF (EX(I+M,I,X,LX,Q,L,OFFSET)) 40, 50, 50 ! 859: C ! 860: C BUBBLE SORT W/I SUBLIST ! 861: C ! 862: 40 I = I - M ! 863: IF (I.GE.1) GO TO 30 ! 864: 50 CONTINUE ! 865: GO TO 20 ! 866: END ! 867: C XXXXXERROR1.f ! 868: SUBROUTINE ERROR1(MESS, LMESS) ! 869: C ! 870: INTEGER MESS(20), LMESS ! 871: INTEGER ZERO(1) ! 872: C ! 873: DATA ZERO(1) /0/ ! 874: C ! 875: CALL ERROR2(MESS, LMESS, ZERO(1), ZERO(1), 1, 1) ! 876: C ! 877: RETURN ! 878: C ! 879: END ! 880: C XXXXXERROR2.f ! 881: SUBROUTINE ERROR2( I, JJ, K, NN, SPBEF, SPAFT ) ! 882: C ! 883: C PRINTS ERROR MESSAGES AND SYMBOLIC NAME ! 884: C I IS PACKED HOLLERITH STRING ! 885: C JJ IS NUMBER OF CHARACTERS TO BE PRINTED ( N = JJ) ! 886: C K CONTAINS INTEGER OR HOLLERITH INFO TO FOLLOW MESSAGE ! 887: C NN CONTROLS TYPE OF LINE TO BE PRINTED ! 888: C ! 889: C NN = 0 MEANS PRINT MESSAGE ! 890: C ! 891: C NN < 0 MEANS IF JJ=0 NO MESSAGE, ELSE PRINT MESSAGE ! 892: C ON NEXT LINE IF NN = -1 PRINT PGM UNIT AND/OR STMT NO ! 893: C (CONTROLLED BY CONTENTS OF K). ! 894: C ON NEXT LINE IF NN = -2 PRINT PARAMETER NUMBER IN K ! 895: C NN = -3 USED FOR SPACING CONTROL IN LONG MESSAGES ! 896: C ! 897: C NN > 0 MEANS PRINT MESSAGE FOLLOWED BY IDENTIFIER IN K ! 898: C SPBEF, SPAFT CONTROL LINE SPACING BEFORE AND AFTER MESSAGE ! 899: C IF = 1, BLANK LINE EMMITTED ! 900: C ! 901: INTEGER I(1), J(80), OUTUT, PDSA, DSA, M(6), K(6), W ! 902: INTEGER SPBEF, SPAFT ! 903: LOGICAL OPT, P1ERR, P2, QBR ! 904: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 905: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, I1, I2, I3, I4 ! 906: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 907: COMMON /OPTNS/ OPT(5), P1ERR ! 908: COMMON /PASS/ P2, QBR ! 909: DATA W /1HW/, KK /1H-/ ! 910: C ! 911: C ERROR IN P.U. DURING PROCESSING OF A HEADING STMT, SPECIFI STMT, ! 912: C EQUIV STMT, OR DATA STMT CAUSES PASS 2 TO BE SUPPRESSED FOR THAT ! 913: C P.U. ! 914: C ! 915: IF (QBR) GOTO 45 ! 916: IF(SPBEF.EQ.1) WRITE(OUTUT, 99998) ! 917: N = JJ ! 918: IF (N.GT.72) N = 72 ! 919: J(2) = KK ! 920: IF (N.GE.1) CALL S5UNPK(I, J, N) ! 921: IF (ITYP.LT.14 .AND. J(2).NE.W) P1ERR = .TRUE. ! 922: IF (NN) 50, 10, 30 ! 923: C ! 924: C NN=0 ! 925: C ! 926: 10 CONTINUE ! 927: WRITE (OUTUT,99997) (J(L),L=1,N) ! 928: IF(P2 .OR. OPT(4)) GOTO 40 ! 929: CALL S5UNPK(DSA(NAME+4), J(1), 6) ! 930: WRITE (OUTUT,99999) NOST, (J(L),L=1,6) ! 931: 99999 FORMAT (16H *** AT STMT NO , I6, 13H IN PGM UNIT , 6A1) ! 932: 99998 FORMAT(1H ) ! 933: GO TO 40 ! 934: C ! 935: C NN>0 ! 936: C ! 937: 30 CONTINUE ! 938: IF (N.GT.68) N = 68 ! 939: CALL S5UNPK(K, J(73), 6) ! 940: WRITE (OUTUT,99997) (J(L),L=1,N), KK, KK, (J(L),L=73,78) ! 941: 99997 FORMAT (4H ***, 76A1) ! 942: 40 IF(SPAFT.EQ.1) WRITE(OUTUT, 99998) ! 943: 45 RETURN ! 944: C ! 945: C NN<0 ! 946: C ! 947: 50 CONTINUE ! 948: IF (N.GE.1) WRITE (OUTUT,99997) (J(L),L=1,N) ! 949: IF( -2.EQ.NN ) GOTO 70 ! 950: IF( -3.EQ.NN ) GOTO 40 ! 951: CALL S5UNPK(DSA(NAME+4), M(1), 6) ! 952: C WRITE OUT STMT NO AND/OR PGM UNIT ! 953: IF (K(1).EQ.0) GO TO 60 ! 954: WRITE (OUTUT,99996) K(1), (M(L),L=1,6) ! 955: 99996 FORMAT (16H *** AT STMT NO , I6, 1X, 13H IN PGM UNIT , 6A1) ! 956: GO TO 40 ! 957: 60 WRITE (OUTUT,99995) (M(L),L=1,6) ! 958: 99995 FORMAT (17H *** IN PGM UNIT , 6A1) ! 959: GO TO 40 ! 960: C WRITE OUT PARAMETER NO FOR PARAMETERLIST ERRORS ! 961: 70 WRITE(OUTUT,99994) K(1) ! 962: 99994 FORMAT(22H *** PARAMETER NUMBER ,I6) ! 963: GOTO 40 ! 964: END ! 965: C XXXXXARDECL.f ! 966: LOGICAL FUNCTION ARDECL(K2, KK) ! 967: C ! 968: C K2 IS INDEX OF END OF ARRAY DECLARATOR IN STMT ! 969: C KK IS SYMBOL TABLE INDEX FOR THIS ARRAY ! 970: C PROCESSES ARRAY DECLARATOR AND DECLARATOR CONSTRUCTS. ! 971: C CAN EXPECT ARRAY DECLARATOR, ARRAY ELEMENT; ARRAY, VARIABLE. ! 972: C ENTERS INTO SYMBOL TABLE AND TYPES ID; SETS USAGE ON ARRAY ! 973: C DECLARATOR ! 974: C CHECKS SYNTAX OF BOUNDS; IF VARIABLY DIMENSIONED, BOUNDS ! 975: C VARIABLE AND ARRAY ITSELF MUST BE DUMMY ARGUMENTS. ! 976: C ACCUMULATES TOTAL LENGTH OF ARRAY WITH CONSTANT BOUNDS AND STORES ! 977: C IT OFF ARRAY SYMBOL TABLE ENTRY. -1 LENGTH INDICATES VARIABLE ! 978: C DIMENSION ! 979: C CALLED BY DIMENSION, TYPE, COMMON, EQUIVALENCE, DATA STMT. ! 980: C ! 981: C ARRY IS TRUE FOR ARRAY ELEMENTS/ARRAY DECLARATORS ! 982: C FALSE FOR ARRAYS AND VARIABLES ! 983: C CORNER IS TRUE FOR ARRAY ELEMENTS WITH (1,1,1)--NEEDED IN EQUIV. ! 984: C STMT ; IF SUCH AN ELEMENT IS RECOGNIZED KK IS SENT AS ITS ! 985: C NEGATIVE. ! 986: C ! 987: LOGICAL ERR, SYSERR, ABORT, TOKPNO, VAR, CORNER, ARRY, FLUSH ! 988: INTEGER STMT, PSTMT, PDSA, BNEXT, SYMHD, DSA ! 989: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 990: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 991: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 992: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 993: COMMON /DETECT/ ERR, SYSERR, ABORT ! 994: ERR = .FALSE. ! 995: FLUSH = .FALSE. ! 996: ARRY = .FALSE. ! 997: CORNER = .TRUE. ! 998: ARDECL = .FALSE. ! 999: C ! 1000: C CHECK NAME; CAN'T HAVE BEEN USED PREVIOUSLY AS A NONVAR; ! 1001: C CHECK TO SEE IF HAVE ARRAY ELEMENT/ARRAY DECLARATOR. IF SO ! 1002: C ARRY=.TRUE. ! 1003: C ! 1004: ICNT = 0 ! 1005: CALL NEXTOK(PSTMT, K2, I1) ! 1006: IF (I1.EQ.0) GO TO 10 ! 1007: CALL ERROR1(20H ILLEGAL PUNCTUATION, 20) ! 1008: ERR = .TRUE. ! 1009: GO TO 280 ! 1010: 10 IF (STMT(K2).EQ.65) ARRY = .TRUE. ! 1011: KK = LOOKUP(K2,.FALSE.) ! 1012: IF (SYSERR) GO TO 70 ! 1013: ARDECL = .TRUE. ! 1014: L = IGATT1(KK,8) ! 1015: IF (L.EQ.0 .OR. L.EQ.10) GO TO 30 ! 1016: IF (ITYP.LT.6 .AND. L.EQ.13) GO TO 30 ! 1017: 20 CALL ERROR1(45H ILLEGAL USE OF PREVIOUSLY DEFINED IDENTIFIER, 45) ! 1018: ERR = .TRUE. ! 1019: GO TO 280 ! 1020: C ! 1021: C SET TYPE (EXPLICITLY FOR TYPE STMTS) ! 1022: C ! 1023: 30 I1 = IGATT1(KK,1) ! 1024: IF (ITYP.GE.6) GO TO 50 ! 1025: C ! 1026: C TYPE EXPLICITLY ! 1027: C ! 1028: IF (I1.GE.8) GO TO 40 ! 1029: CALL SATT1(KK, 1, ITYP+7) ! 1030: GO TO 60 ! 1031: 40 CALL ERROR1(34H IDENTIFIER TYPED EXPLICITLY TWICE, 34) ! 1032: GO TO 60 ! 1033: C ! 1034: C TYPE IMPLICITLY ! 1035: C ! 1036: 50 IF (I1.GT.0) GO TO 60 ! 1037: I1 = 1 ! 1038: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2 ! 1039: CALL SATT1(KK, 1, I1) ! 1040: C ! 1041: C IF NOT ARRAY ELEMENT/ARAY DECLARATOR--RECOGNITION COMPLETE ! 1042: C ! 1043: C CHECK NOT A DUMMY ARG IN COMMON, DATA, EQUIV STMT ! 1044: C ! 1045: 60 IF (ARRY) GO TO 80 ! 1046: IF (IGATT1(KK,7).EQ.0) GO TO 65 ! 1047: IF (ITYP.EQ.12) ! 1048: 1 CALL ERROR1(46H WARNING - ILLEGAL USE OF ARRAY IN EQUIVALENCE ! 1049: 2 , 46) ! 1050: IF (ITYP.EQ.13) ! 1051: 1 CALL ERROR1(39H WARNING - ILLEGAL USE OF ARRAY IN DATA, 39) ! 1052: 65 CONTINUE ! 1053: I1 = IGATT1(KK,4) ! 1054: IF (.NOT.(I1.EQ.1 .AND. (ITYP.EQ.8 .OR. ITYP.EQ.12 .OR. ! 1055: * ITYP.EQ.13))) GO TO 70 ! 1056: ERR = .TRUE. ! 1057: CALL ERROR1(32H ILLEGAL USAGE OF DUMMY ARGUMENT, 32) ! 1058: 70 RETURN ! 1059: 80 ISIZ = 1 ! 1060: VAR = .FALSE. ! 1061: IF (L.EQ.0) CALL SATT1(KK, 8, 10) ! 1062: C ! 1063: C LOOP TO FIND BOUNDS; CHECK THAT VARIABLE BOUNDS ARE DUMMY ARGS ! 1064: C SET ADJUSTIBLE DIMENSION VARIABLE BIT; SET TYPE IMPLICITLY IF NOT ! 1065: C ALREADY SET ! 1066: C ACCUMULATE LENGTH IF IN DIMENSION, COMMON, OR TYPE STMT. ! 1067: C CHECK FOR REPEAT DIMENSIONING IN THOSE STMTS ! 1068: C ! 1069: L = IGATT1(KK,7) ! 1070: IF (ITYP.EQ.13 .OR. ITYP.EQ.12) GO TO 90 ! 1071: IF (L.EQ.0) GO TO 100 ! 1072: CALL ERROR1(44H ILLEGAL USE OF PREVIOUSLY DIMENSIONED ARRAY, 44) ! 1073: ERR = .TRUE. ! 1074: GO TO 270 ! 1075: 90 IF (L.EQ.0) CALL ERROR1( ! 1076: * 44H ILLEGAL USE OF ARRAY NOT PREVIOUSLY DEFINED, 44) ! 1077: 100 IF (K2+1.LT.NSTMT) GO TO 120 ! 1078: 110 CALL ERROR1(28H ILLEGAL ARRAY BOUNDS SYNTAX, 28) ! 1079: GO TO 270 ! 1080: C ! 1081: C CHECK FOR POSITIVE INTEGER BOUND ! 1082: C ! 1083: 120 PSTMT = K2 + 1 ! 1084: IF (.NOT.TOKPNO(PSTMT,I1,LL)) GO TO 130 ! 1085: IF (ITYP.EQ.7 .OR. ITYP.EQ.8 .OR. ITYP.LT.6) ISIZ = ISIZ*LL ! 1086: IF (ITYP.NE.12) GO TO 170 ! 1087: IF (I1-K2.NE.2 .OR. STMT(PSTMT).NE.1) CORNER = .FALSE. ! 1088: GO TO 170 ! 1089: C ! 1090: C SEEK A VARIABLE BOUND ! 1091: C ! 1092: 130 CALL NEXTOK(PSTMT, I1, L) ! 1093: IF (L.NE.0) GO TO 110 ! 1094: IF (ITYP.LT.6 .OR. ITYP.EQ.7) GO TO 140 ! 1095: CALL ERROR1(32H VARIABLE DIMENSION ILLEGAL HERE, 32) ! 1096: ERR = .TRUE. ! 1097: GO TO 270 ! 1098: 140 VAR = .TRUE. ! 1099: L = LOOKUP(I1,.FALSE.) ! 1100: IF (SYSERR) GO TO 70 ! 1101: N = IGATT1(L,8) ! 1102: IF (N.NE.0 .AND. N.NE.10) GO TO 20 ! 1103: I2 = IGATT1(L,4) ! 1104: IF (I2.EQ.1) GO TO 150 ! 1105: CALL ERROR1(42H ILLEGAL USAGE OF VARIABLE IN ARRAY BOUNDS, 42) ! 1106: ERR = .TRUE. ! 1107: GO TO 270 ! 1108: 150 I2 = IGATT1(KK,4) ! 1109: IF (I2.EQ.1) GO TO 160 ! 1110: CALL ERROR1(50H VARIABLY DIMENSIONED ARRAY MUST BE DUMMY ARGUMENT, ! 1111: * 50) ! 1112: ERR = .TRUE. ! 1113: GO TO 270 ! 1114: 160 CALL SATT1(L, 6, 1) ! 1115: CALL SATT1(L, 8, 10) ! 1116: N = IGATT1(L,1) ! 1117: IF (N.GT.0) GO TO 170 ! 1118: N = 1 ! 1119: IF (STMT(K2+1).GE.38 .AND. STMT(K2+1).LE.43) N = 2 ! 1120: CALL SATT1(L, 1, N) ! 1121: GO TO 170 ! 1122: C ! 1123: C FIND "," AND ACCUMULATE LENGTH ! 1124: C ! 1125: 170 ICNT = ICNT + 1 ! 1126: IF (ICNT.LE.3) GO TO 180 ! 1127: ISIZ = ISIZ/LL ! 1128: CALL ERROR1(30H WARNING - TOO MANY SUBSCRIPTS, 30) ! 1129: ICNT = 3 ! 1130: FLUSH = .TRUE. ! 1131: GO TO 190 ! 1132: 180 K2 = I1 ! 1133: IF (STMT(K2).EQ.68) GO TO 100 ! 1134: C ! 1135: C FIND ")" STORE LENGTH OR -1 INTO ARRAY SYMBOL TABLE ELEMENT ! 1136: C ! 1137: IF (STMT(K2).NE.62) GO TO 110 ! 1138: 190 IF (ITYP.EQ.13 .OR. ITYP.EQ.12) GO TO 260 ! 1139: CALL SATT1(KK, 7, ICNT) ! 1140: C ! 1141: C STORE LENGTH OF ARRAY ! 1142: C ! 1143: IF (VAR) GO TO 240 ! 1144: IF (DSA(KK+2).EQ.0) GO TO 200 ! 1145: N = DSA(KK+2) ! 1146: DSA(N) = ISIZ ! 1147: GO TO 220 ! 1148: 200 IF (NEXT+2.GE.BNEXT) GO TO 210 ! 1149: DSA(KK+2) = NEXT ! 1150: DSA(NEXT) = ISIZ ! 1151: DSA(NEXT+1) = 0 ! 1152: NEXT = NEXT + 2 ! 1153: GO TO 220 ! 1154: 210 SYSERR = .TRUE. ! 1155: CALL ERROR1(33H IN ARDECL, TABLE OVERFLOW OF DSA,33) ! 1156: 220 IF (FLUSH) GO TO 270 ! 1157: 230 K2 = K2 + 1 ! 1158: GO TO 70 ! 1159: C ! 1160: C FIXUP FOR VARIABLY DIMENSIONED ARRAYS ! 1161: C ! 1162: 240 IF (DSA(KK+2).EQ.0) GO TO 250 ! 1163: N = DSA(KK+2) ! 1164: DSA(N) = -1 ! 1165: GO TO 220 ! 1166: 250 IF (NEXT+2.GE.BNEXT) GO TO 210 ! 1167: DSA(KK+2) = NEXT ! 1168: DSA(NEXT) = -1 ! 1169: DSA(NEXT+1) = 0 ! 1170: NEXT = NEXT + 2 ! 1171: GO TO 220 ! 1172: C ! 1173: C CHECK FORCORNER ELEMENT IN EQUIVALENCE STMT ! 1174: C ! 1175: 260 IF (ITYP.NE.12) GO TO 220 ! 1176: IF (CORNER) KK = -KK ! 1177: GO TO 220 ! 1178: C ! 1179: C CODE TO FLUSH CONSTRUCT--TO NEXT ")" ! 1180: C ! 1181: 270 IF (K2.EQ.NSTMT) GO TO 70 ! 1182: IF (STMT(K2).EQ.62) GO TO 230 ! 1183: K2 = K2 + 1 ! 1184: GO TO 270 ! 1185: C ! 1186: C CODE TO FLUSH TO NEXT CONSTRUCT ")",",", "/" ! 1187: C ! 1188: 280 K = 90 ! 1189: IF (ITYP.EQ.8 .OR. ITYP.EQ.13) K = 67 ! 1190: 290 IF (K2.EQ.NSTMT) GO TO 70 ! 1191: L = STMT(K2) ! 1192: IF (L.EQ.65) GO TO 270 ! 1193: IF (L.EQ.68 .OR. L.EQ.K) GO TO 70 ! 1194: K2 = K2 + 1 ! 1195: GO TO 290 ! 1196: END ! 1197: C XXXXXASSASF.f ! 1198: SUBROUTINE ASSASF(IGP) ! 1199: INTEGER STMT, PSTMT, PDSA, EXPR, DSA, BNEXT, SYMHD ! 1200: LOGICAL ERR, SYSERR, ABORT, ASF, DOVAR ! 1201: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 1202: COMMON /DETECT/ ERR, SYSERR, ABORT ! 1203: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 1204: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 1205: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 1206: C ! 1207: C PROCESSES ARITHMETIC STMT FCNS AND ASSIGNMENT STMTS ! 1208: C FIRST LOOKS FOR ELEMENT ON RHS. AND TYPES IT ! 1209: C ! 1210: CALL NEXTOK(PSTMT, K2, K) ! 1211: ASF = .FALSE. ! 1212: IF (K.NE.0) GO TO 180 ! 1213: K = LOOKUP(K2,.FALSE.) ! 1214: IF (SYSERR) GO TO 190 ! 1215: I1 = IGATT1(K,1) ! 1216: IF (I1.NE.0) GO TO 10 ! 1217: I1 = 1 ! 1218: IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I1 = 2 ! 1219: CALL SATT1(K, 1, I1) ! 1220: C ! 1221: C LOOK FOR A "(" ; FIND ARRAY = CASE AND SEND IT TO ERROR ! 1222: C FIND ARRAY ELEMENT = , ID = CASES AND SEND THEM TO ! 1223: C ASSIGNMENT CODE ! 1224: C ! 1225: 10 I2 = IGATT1(K,7) ! 1226: I1 = MOD(I1,8) ! 1227: IF (STMT(K2).NE.65 .AND. I2.NE.0) GO TO 180 ! 1228: IF (STMT(K2).NE.65 .OR. I2.NE.0) GO TO 240 ! 1229: C ! 1230: C ASF DEFN ! 1231: C ! 1232: ITYP = 31 ! 1233: ASF = .TRUE. ! 1234: IGP = 4 ! 1235: NUM = 0 ! 1236: IASF = K ! 1237: 20 PSTMT = K2 + 1 ! 1238: IF (PSTMT.GE.NSTMT) GO TO 180 ! 1239: C ! 1240: C ASF HAS LIST OF SCALAR VARIABLES; THEY ARE TYPED AND USAGE SET ! 1241: C ! 1242: CALL NEXTOK(PSTMT, K2, I) ! 1243: IF (I.EQ.0) GO TO 30 ! 1244: CALL ERROR1(17H ILLEGAL ASF DEFN, 17) ! 1245: GO TO 190 ! 1246: 30 I = LOOKUP(K2,.FALSE.) ! 1247: IF (SYSERR) GO TO 190 ! 1248: NUM = NUM + 1 ! 1249: I2 = IGATT1(I,1) ! 1250: IF (I2.GT.0) GO TO 40 ! 1251: I2 = 1 ! 1252: IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I2 = 2 ! 1253: CALL SATT1(I, 1, I2) ! 1254: 40 I2 = IGATT1(I,8) ! 1255: IF (I2.EQ.0) GO TO 50 ! 1256: IF (I2.EQ.1) GO TO 60 ! 1257: CALL ERROR1(29H ILLEGAL VARIABLE IN ASF DEFN, 29) ! 1258: GO TO 210 ! 1259: 50 CALL SATT1(I, 8, 1) ! 1260: C STORE PTR TO CURRENT ASF-FCN ENTRY IN SYMBOL ! 1261: C TABLE IN 3D WORD OF ASF-DUMMY ENTRY IN SYM TABLE ! 1262: 60 DSA(I+2) = K ! 1263: C ! 1264: C LIST OF INDICES OF ASF ARGS IS HUNG OFF OF ASF DEF IN DSA ! 1265: C ! 1266: IF (DSA(K+2).EQ.0) GO TO 120 ! 1267: L = DSA(K+2) ! 1268: 70 IF (DSA(L+1).EQ.0) GO TO 80 ! 1269: L = DSA(L+1) ! 1270: GO TO 70 ! 1271: 80 IF (NEXT+2.LT.BNEXT) GO TO 100 ! 1272: 90 CALL ERROR1(33H IN ASSASF, TABLE OVERFLOW OF DSA, 33) ! 1273: SYSERR = .TRUE. ! 1274: GO TO 190 ! 1275: 100 DSA(L+1) = NEXT ! 1276: 110 DSA(NEXT) = I ! 1277: DSA(NEXT+1) = 0 ! 1278: NEXT = NEXT + 2 ! 1279: GO TO 130 ! 1280: 120 IF (NEXT+2.GE.BNEXT) GO TO 90 ! 1281: DSA(K+2) = NEXT ! 1282: GO TO 110 ! 1283: 130 IF (STMT(K2).NE.62) GO TO 170 ! 1284: C ! 1285: C CHECK FOR TWO ELEMENTS ONLIST BEING THE SAME ID ! 1286: C ! 1287: I2 = DSA(K+2) ! 1288: DO 160 I=1,NUM ! 1289: L = DSA(K+2) ! 1290: DO 150 J=1,NUM ! 1291: IF (I.EQ.J) GO TO 140 ! 1292: IF (DSA(L).NE.DSA(I2)) GO TO 140 ! 1293: CALL ERROR1(18H ILLEGAL ASF-DUMMY, 18) ! 1294: CALL SATT1(K, 8, 0) ! 1295: GO TO 190 ! 1296: 140 L = DSA(L+1) ! 1297: 150 CONTINUE ! 1298: I2 = DSA(I2+1) ! 1299: 160 CONTINUE ! 1300: GO TO 200 ! 1301: 170 IF (STMT(K2).EQ.68) GO TO 20 ! 1302: 180 CALL ERROR1(15H ILLEGAL SYNTAX, 15) ! 1303: 190 RETURN ! 1304: C ! 1305: C = AND EXPR CHECK ! 1306: C ! 1307: 200 PSTMT = K2 + 1 ! 1308: 210 IF (PSTMT.GE.NSTMT) GO TO 180 ! 1309: IF (STMT(PSTMT).NE.63) GO TO 180 ! 1310: PSTMT = PSTMT + 1 ! 1311: IF (PSTMT.GE.NSTMT) GO TO 180 ! 1312: L = EXPR(I) ! 1313: IF (SYSERR) GO TO 190 ! 1314: C ! 1315: C CHECK THAT ASF WAS NOT DEFINED RECURSIVELY, SET USAGE ! 1316: C ! 1317: IF (.NOT.ASF) GO TO 230 ! 1318: I2 = IGATT1(K,8) ! 1319: IF (I2.EQ.0) GO TO 220 ! 1320: CALL ERROR1(17H ILLEGAL ASF NAME, 17) ! 1321: GO TO 190 ! 1322: 220 CALL SATT1(K, 8, 2) ! 1323: 230 IF (L/8.EQ.1) GO TO 280 ! 1324: L = MOD(L,8) ! 1325: C ! 1326: C COMPARE TYPES OF RHS AND LHS ! 1327: C ! 1328: IF ((L.EQ.3 .AND. I1.EQ.3) .OR. (L.EQ.4 .AND. I1.EQ.4) .OR. ! 1329: * (L.LE.2 .AND. I1.LE.2) .OR. (L.EQ.5 .AND. I1.EQ.5)) GO TO 190 ! 1330: IF (.NOT.(L.EQ.2 .AND. I1.EQ.5 .OR. L.EQ.5 .AND. I1.EQ.2)) CALL ! 1331: * ERROR1(38H INCOMPATIBLE DATA TYPES IN ASSIGNMENT, 38) ! 1332: GO TO 190 ! 1333: C ! 1334: C PROCESSING FOR ASSIGNMENT STMT ! 1335: C ! 1336: 240 I = IGATT1(K,8) ! 1337: IF (I.NE.0) GO TO 250 ! 1338: I = 10 ! 1339: CALL SATT1(K, 8, 10) ! 1340: 250 IF (I.EQ.10 .OR. (I.EQ.4 .AND. K.EQ.NAME)) GO TO 260 ! 1341: CALL ERROR1(31H CANNOT ASSIGN VALUE TO THIS ID, 31) ! 1342: GO TO 190 ! 1343: 260 CALL SATT1(K, 5, 1) ! 1344: IF (STMT(K2).EQ.65) GO TO 270 ! 1345: IF (DOVAR(K)) CALL ERROR1( ! 1346: * 57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS, ! 1347: * 57) ! 1348: PSTMT = K2 ! 1349: GO TO 210 ! 1350: 270 PSTMT = K2 + 1 ! 1351: IF (PSTMT.GE.NSTMT) GO TO 180 ! 1352: CALL SUBS(I, I2) ! 1353: C ! 1354: C PEEL SUBSCRIPTS OFF ! 1355: C ! 1356: IF (SYSERR .OR. ERR) GO TO 190 ! 1357: PSTMT = I ! 1358: GO TO 210 ! 1359: 280 CALL ERROR1(30H ILLEGAL USE OF ARRAY VARIABLE, 30) ! 1360: GO TO 190 ! 1361: END ! 1362: C XXXXXASSIGN.f ! 1363: SUBROUTINE ASSIGN ! 1364: INTEGER PSTMT, STMT ! 1365: LOGICAL TOKLAB, ERR, SYSERR, ABORT ! 1366: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 1367: COMMON /DETECT/ ERR, SYSERR, ABORT ! 1368: C ! 1369: C PROCESSES AN ASSIGN STMT: ASSIGN <LABEL> TO <VAR> ! 1370: C ! 1371: IF (PSTMT.GE.NSTMT) GO TO 10 ! 1372: IF (.NOT.TOKLAB(1,K2,KK,.FALSE.)) GO TO 80 ! 1373: IF (SYSERR) GO TO 20 ! 1374: PSTMT = K2 ! 1375: IF (PSTMT+2.GE.NSTMT) GO TO 10 ! 1376: IF (STMT(PSTMT).EQ.49 .AND. STMT(PSTMT+1).EQ.44) GO TO 30 ! 1377: 10 CALL ERROR1(15H ILLEGAL SYNTAX, 15) ! 1378: 20 RETURN ! 1379: 30 PSTMT = PSTMT + 2 ! 1380: IF (PSTMT.GE.NSTMT) GO TO 10 ! 1381: CALL NEXTOK(PSTMT, K2, K) ! 1382: IF (K.NE.0) GO TO 10 ! 1383: K = LOOKUP(K2,.FALSE.) ! 1384: IF (SYSERR) GO TO 20 ! 1385: I1 = IGATT1(K,1) ! 1386: I2 = IGATT1(K,7) ! 1387: I3 = IGATT1(K,8) ! 1388: IF (I3.EQ.0) GO TO 40 ! 1389: IF (I3.NE.8) GO TO 90 ! 1390: GO TO 50 ! 1391: 40 CALL SATT1(K, 8, 8) ! 1392: 50 IF (I1.NE.0) GO TO 60 ! 1393: I1 = 1 ! 1394: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2 ! 1395: CALL SATT1(K, 1, I1) ! 1396: 60 IF (MOD(I1,8).EQ.2 .AND. I2.EQ.0) GO TO 70 ! 1397: CALL ERROR1(35H ASSIGN VARIABLE NOT INTEGER SCALAR, 35) ! 1398: GO TO 20 ! 1399: 70 IF (K2.NE.NSTMT) GO TO 10 ! 1400: GO TO 20 ! 1401: 80 CALL ERROR1(14H MISSING LABEL, 14) ! 1402: GO TO 20 ! 1403: 90 CALL ERROR1(23H ILLEGAL VARIABLE USAGE, 23) ! 1404: GO TO 20 ! 1405: END ! 1406: C XXXXXCOMMON.f ! 1407: SUBROUTINE COMMON ! 1408: INTEGER PSTMT, PDSA, STMT, DSA, BNEXT, SYMHD, S(4) ! 1409: LOGICAL ERR, SYSERR, ABORT, ARDECL ! 1410: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 1411: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 1412: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 1413: COMMON /DETECT/ ERR, SYSERR, ABORT ! 1414: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 1415: DATA S(1) /66/, S(2) /32/, S(3) /44/, S(4) /42/ ! 1416: C ! 1417: C PROCESSES A COMMON STMT ! 1418: C FIRST, PEEL OFF NAME OF COMMON AND SET SYMBOL TABLE ENTRY USAGE ! 1419: C CHECK NAME HAS NOT APPEARED BEFORE IN PGM UNIT ! 1420: C ! 1421: IF (STMT(PSTMT).EQ.67) GO TO 30 ! 1422: C ! 1423: C SET SYMBOL TABLE ENTRY FOR BLANK COMMON ! 1424: C ! 1425: 10 I1 = IGATT1(NAME,8) ! 1426: IF (I1.EQ.11) GO TO 170 ! 1427: IF (PSTMT.GE.NSTMT) GO TO 200 ! 1428: L = PSTMT ! 1429: DO 20 I1=1,4 ! 1430: STMT(I1) = S(I1) ! 1431: 20 CONTINUE ! 1432: PSTMT = 1 ! 1433: KK = LOOKUP(5,.FALSE.) ! 1434: IF (SYSERR) GO TO 190 ! 1435: PSTMT = L ! 1436: CALL SATT1(KK, 8, 7) ! 1437: GO TO 60 ! 1438: 30 PSTMT = PSTMT + 1 ! 1439: IF (STMT(PSTMT).NE.67) GO TO 40 ! 1440: PSTMT = PSTMT + 1 ! 1441: GO TO 10 ! 1442: 40 IF (PSTMT.GE.NSTMT) GO TO 200 ! 1443: CALL NEXTOK(PSTMT, K2, L) ! 1444: IF (L.NE.0) GO TO 200 ! 1445: KK = LOOKUP(K2,.FALSE.) ! 1446: IF (SYSERR) GO TO 190 ! 1447: I1 = IGATT1(KK,1) ! 1448: N = IGATT1(KK,8) ! 1449: IF (I1.EQ.0 .AND. (N.EQ.0 .OR. N.EQ.7)) GO TO 50 ! 1450: CALL ERROR1(20H ILLEGAL COMMON NAME, 20) ! 1451: GO TO 190 ! 1452: 50 CALL SATT1(KK, 8, 7) ! 1453: I1 = IGATT1(NAME,8) ! 1454: IF (I1.EQ.11) CALL SATT1(KK, 2, 1) ! 1455: PSTMT = K2 + 1 ! 1456: IF (PSTMT.GE.NSTMT .OR. STMT(K2).NE.67) GO TO 200 ! 1457: C ! 1458: C ELEMENTS IN COMMON: ARRAYS,VARIABLES,DECLARATIONS OF ARRAYS( NOT ! 1459: C VARIABLY DIMENSIONED). IMPLICITLY TYPE THEM ! 1460: C ! 1461: 60 IF (ARDECL(K2,N)) GO TO 70 ! 1462: CALL ERROR1(47H COMMON ELEMENT NOT VARIABLE, ARRAY, DECLARATOR, ! 1463: * 47) ! 1464: GO TO 190 ! 1465: 70 IF (SYSERR .OR. ERR) GO TO 190 ! 1466: C ! 1467: C SET SYMBOL TABLE ENTRY OF ELEMENT TO SHOW ITS IN COMMON ! 1468: C PUT POINTER TO COMMON NAME INTO 3D WORD OF ENTRY (OR OFF 3D ! 1469: C WORD--FOR ARRAYS ! 1470: C ! 1471: I1 = IGATT1(N,2) ! 1472: IF (I1.NE.0) GO TO 160 ! 1473: CALL SATT1(N, 2, 1) ! 1474: I1 = IGATT1(N,7) ! 1475: IF (I1.EQ.0) GO TO 80 ! 1476: L = DSA(N+2) ! 1477: DSA(L+1) = KK ! 1478: GO TO 90 ! 1479: 80 CALL SATT1(N, 8, 10) ! 1480: IF (NEXT+2.GE.BNEXT) GO TO 180 ! 1481: DSA(N+2) = NEXT ! 1482: DSA(NEXT) = 0 ! 1483: DSA(NEXT+1) = KK ! 1484: NEXT = NEXT + 2 ! 1485: C ! 1486: C SETUP CHAIN OF ELEMENTS OF COMMON HANGING OFF SYMBOL TABLE ! 1487: C ENTRY OF COMMON NAME ! 1488: C ! 1489: 90 IF (DSA(KK+2).EQ.0) GO TO 130 ! 1490: L = DSA(KK+2) ! 1491: 100 IF (DSA(L+1).EQ.0) GO TO 110 ! 1492: L = DSA(L+1) ! 1493: GO TO 100 ! 1494: 110 IF (NEXT+2.GE.BNEXT) GO TO 180 ! 1495: DSA(L+1) = NEXT ! 1496: 120 DSA(NEXT) = N ! 1497: DSA(NEXT+1) = 0 ! 1498: NEXT = NEXT + 2 ! 1499: GO TO 140 ! 1500: 130 IF (NEXT+2.GE.BNEXT) GO TO 180 ! 1501: DSA(KK+2) = NEXT ! 1502: GO TO 120 ! 1503: C ! 1504: C CHECK FOR END OF STMT ! 1505: C ! 1506: 140 IF (K2.EQ.NSTMT) GO TO 190 ! 1507: IF (STMT(K2).NE.68) GO TO 150 ! 1508: PSTMT = K2 + 1 ! 1509: GO TO 60 ! 1510: 150 IF (STMT(K2).NE.67) GO TO 200 ! 1511: PSTMT = K2 ! 1512: GO TO 30 ! 1513: 160 CALL ERROR1(23H ELEMENT IN TWO COMMONS, 23) ! 1514: GO TO 140 ! 1515: 170 CALL ERROR1( ! 1516: * 51H BLANK COMMON NOT ALLOWED IN BLOCK DATA SUBPROGRAMS, 51) ! 1517: GO TO 190 ! 1518: 180 SYSERR = .TRUE. ! 1519: CALL ERROR1(33H IN COMMON, TABLE OVERFLOW OF DSA,33) ! 1520: 190 RETURN ! 1521: 200 CALL ERROR1(15H ILLEGAL SYNTAX, 15) ! 1522: GO TO 190 ! 1523: END ! 1524: C XXXXXDIMENS.f ! 1525: SUBROUTINE DIMENS ! 1526: C ! 1527: C PROCESSES DIMENSION STMT, RECORDING OF ARRAY BOUNDS, LENGTH ! 1528: C ETC. DONE IN ORDER ! 1529: C ! 1530: INTEGER STMT, PSTMT ! 1531: LOGICAL ERR, SYSERR, ABORT, ARDECL ! 1532: COMMON /DETECT/ ERR, SYSERR, ABORT ! 1533: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 1534: 10 IF (ARDECL(K2,K3)) GO TO 20 ! 1535: CALL ERROR1(35H ILLEGAL SYNTAX OF ARRAY DECLARATOR, 35) ! 1536: GO TO 40 ! 1537: 20 IF (SYSERR) RETURN ! 1538: IF (K2.EQ.NSTMT) GO TO 40 ! 1539: IF (STMT(K2).EQ.68 .AND. K2+1.NE.NSTMT) GO TO 30 ! 1540: CALL ERROR1(20H ILLEGAL PUNCTUATION, 20) ! 1541: GO TO 40 ! 1542: 30 PSTMT = K2 + 1 ! 1543: GO TO 10 ! 1544: 40 RETURN ! 1545: END ! 1546: C XXXXXDOCHK.f ! 1547: SUBROUTINE DOCHK(KK) ! 1548: INTEGER DOLIST, DOPT, OUTUT, SYMLEN, OUTUT2, DSA, PDSA, OUTUT3, ! 1549: * STACK, OUTUT4 ! 1550: COMMON /DOS/ DOPT, LDO, DOLIST(192) ! 1551: COMMON /CEXPRS/ LSTACK, STACK(620) ! 1552: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, ! 1553: * OUTUT4 ! 1554: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 1555: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 1556: C ! 1557: C KK IS SYMBOL TABLE ENTRY OF LABEL ! 1558: C ROUTINE CHECKS ALL LABELS FOR BEING END OF DO-STMTS; IF LABEL IS ! 1559: C END-OF-DO, ALL LABELS WITHIN THAT DO, HAVE END-OF-DEFN STMT NO ! 1560: C RECORDED IN THEM; DOPT IS DECREMENTED, A MOCK END-OF-DO IS ! 1561: C CREATED BY THE END STMT IN THE PGM UNIT; DOLIST MUST BE EMPTY ! 1562: C AFTER THIS PROCESSING OF AN END, ! 1563: C PERFORMS FIXUP ON SCOPE OF LABELS ENDING MULTIPLE NESTED DO'S ! 1564: C ! 1565: IF (ITYP.EQ.28) GO TO 50 ! 1566: IF (DOLIST(DOPT+1).NE.KK) GO TO 40 ! 1567: 10 CALL FIXLAB(.FALSE.) ! 1568: DOPT = DOPT - 6 ! 1569: IF (ITYP.EQ.15 .OR. ITYP.EQ.16 .OR. (ITYP.GE.19 .AND. ! 1570: * ITYP.LE.22)) CALL ERROR1(26H ILLEGAL ENDING STMT ON DO, 26) ! 1571: IF (DOLIST(DOPT+1).NE.KK) GO TO 40 ! 1572: C ! 1573: C GET REFERENCE TO NESTED DO ENDING AND MAKE REFERENCE ! 1574: C TO DO STATEMENT A NEGATIVE NUMBER ! 1575: C SO IT WON'T BE AN ILLEGAL BRANCH ! 1576: C ! 1577: K = DSA(KK+1) ! 1578: L = DOLIST(DOPT) ! 1579: 20 IF (DSA(K).EQ.L) GO TO 30 ! 1580: K = DSA(K+1) ! 1581: GO TO 20 ! 1582: 30 DSA(K) = -DSA(K) ! 1583: GO TO 10 ! 1584: 40 RETURN ! 1585: 50 CALL FIXLAB(.TRUE.) ! 1586: IF (DOPT-6.LE.0) GO TO 40 ! 1587: LL = 1 ! 1588: L = DOPT/6 ! 1589: DO 60 I=1,L ! 1590: J = DOPT + 7 - 6*I ! 1591: K = DOLIST(J) ! 1592: CALL S5UNPK(DSA(K+4), STACK(LL), 6) ! 1593: LL = LL + 6 ! 1594: 60 CONTINUE ! 1595: LL = LL - 1 ! 1596: IF (LL.LE.55) GO TO 70 ! 1597: 99999 FORMAT (/25H MISSING DO ENDING LABEL , 55A1) ! 1598: WRITE (OUTUT,99999) (STACK(L),L=1,55) ! 1599: WRITE (OUTUT,99998) (STACK(L),L=56,LL) ! 1600: GO TO 40 ! 1601: 99998 FORMAT (25X, 55A1) ! 1602: 70 WRITE (OUTUT,99999) (STACK(L),L=1,LL) ! 1603: GO TO 40 ! 1604: END ! 1605: C XXXXXDOSPEC.f ! 1606: SUBROUTINE DOSPEC(KK, K2, LOG) ! 1607: INTEGER STMT, PSTMT, DOPT, DOLIST, LOOKUP ! 1608: LOGICAL SYSERR, ABORT, DOVAR, ERR, TOKPNO, LOG ! 1609: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 1610: COMMON /LISTDO/ LPT, LEN, LS(64) ! 1611: COMMON /DOS/ DOPT, LDO, DOLIST(192) ! 1612: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 1613: COMMON /DETECT/ ERR, SYSERR, ABORT ! 1614: C ! 1615: C ROUTINE RECOGNIZES DO-SPECIFICATION CONSTRUCT ! 1616: C DOLIST ARRAY IS DO STACK USED TO CHECK NESTING; 6 WORD ENTRY ! 1617: C WORD 1-CURRENT STMT NO ! 1618: C WORD 2-INDEX OF LABEL IN DSA ! 1619: C WORD 3-INDEX OF DO CONTROL VARIABLE IN DSA ! 1620: C WORD 4-6,-INDICES OF LIMITS IN DSA OR 0 FOR CONSTANT LIMITS ! 1621: C LS ARRAY IS IMPLICIT DO STACK- IN EACH ENTRY IS SAME DATA ! 1622: C AS WORDS 3-6 OF DOLIST ENTRIES. ! 1623: C ! 1624: IF (.NOT.LOG) GO TO 10 ! 1625: IF (LPT.LE.1) GO TO 20 ! 1626: LPT = LPT - 4 ! 1627: LS(LPT) = 0 ! 1628: LS(LPT+1) = 0 ! 1629: LS(LPT+2) = 0 ! 1630: LS(LPT+3) = 0 ! 1631: GO TO 40 ! 1632: 10 IF (DOPT.LE.LDO-11) GO TO 30 ! 1633: 20 CALL ERROR1(20H DO NESTING TOO DEEP, 20) ! 1634: GO TO 190 ! 1635: 30 DOPT = DOPT + 6 ! 1636: DOLIST(DOPT) = NOST ! 1637: DOLIST(DOPT+1) = KK ! 1638: DOLIST(DOPT+2) = 0 ! 1639: DOLIST(DOPT+3) = 0 ! 1640: DOLIST(DOPT+4) = 0 ! 1641: DOLIST(DOPT+5) = 0 ! 1642: C ! 1643: C DO CONTROL VARIABLE MUST BE INTEGER, SCALAR VARIABLE ! 1644: C ! 1645: 40 IF (PSTMT.LT.NSTMT) GO TO 60 ! 1646: 50 CALL ERROR1(35H ILLEGAL SYNTAX IN DO SPECIFICATION, 35) ! 1647: GO TO 190 ! 1648: 60 CALL NEXTOK(PSTMT, K2, K) ! 1649: IF (K.NE.0) GO TO 50 ! 1650: K = LOOKUP(K2,.FALSE.) ! 1651: IF (SYSERR) GO TO 180 ! 1652: I1 = IGATT1(K,1) ! 1653: IF (I1.GT.0) GO TO 70 ! 1654: I1 = 1 ! 1655: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2 ! 1656: CALL SATT1(K, 1, I1) ! 1657: 70 I2 = IGATT1(K,7) ! 1658: I3 = IGATT1(K,8) ! 1659: IF (MOD(I1,8).NE.2 .OR. I2.NE.0) GO TO 220 ! 1660: IF (I3.NE.0) GO TO 80 ! 1661: I3 = 10 ! 1662: CALL SATT1(K, 8, 10) ! 1663: 80 IF (I3.NE.10) GO TO 220 ! 1664: CALL SATT1(K, 5, 1) ! 1665: IF (DOVAR(K)) CALL ERROR1( ! 1666: * 57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS, ! 1667: * 57) ! 1668: I3 = IGATT1(K,2) ! 1669: IF (I3.EQ.1) CALL ERROR1(37H WARNING - CONTROL VARIABLE IN COMMON, ! 1670: * 37) ! 1671: IF (K.EQ.NAME) CALL ERROR1( ! 1672: * 49H WARNING - FUNCTION NAME USED AS CONTROL VARIABLE, 49) ! 1673: IF (.NOT.LOG) GO TO 90 ! 1674: LS(LPT) = K ! 1675: GO TO 100 ! 1676: 90 DOLIST(DOPT+2) = K ! 1677: C ! 1678: C FIND AN = ! 1679: C ! 1680: 100 IF (STMT(K2).NE.63) GO TO 50 ! 1681: C ! 1682: C DO-LIMITS LIMS COUNTS NUMBER OF LIMITS; THESE MUST BE INTEGER ! 1683: C SCALAR VARIABLES OR POSITIVE INTEGER CONSTANTS ! 1684: C ! 1685: LIMS = 0 ! 1686: 110 PSTMT = K2 + 1 ! 1687: IF (PSTMT.GE.NSTMT) GO TO 50 ! 1688: IF (.NOT.TOKPNO(PSTMT,K2,K)) GO TO 120 ! 1689: LIMS = LIMS + 1 ! 1690: GO TO 170 ! 1691: 120 CALL NEXTOK(PSTMT, K2, K) ! 1692: IF (K.NE.0) GO TO 210 ! 1693: K = LOOKUP(K2,.FALSE.) ! 1694: IF (SYSERR) GO TO 180 ! 1695: LIMS = LIMS + 1 ! 1696: IF (.NOT.LOG) GO TO 130 ! 1697: IF (LS(LPT).EQ.K) CALL ERROR1(17H ILLEGAL DO LIMIT, 17) ! 1698: I1 = LPT + LIMS ! 1699: LS(I1) = K ! 1700: GO TO 140 ! 1701: 130 IF (DOLIST(DOPT+2).EQ.K) CALL ERROR1(17H ILLEGAL DO LIMIT, 17) ! 1702: I1 = DOPT + 2 + LIMS ! 1703: DOLIST(I1) = K ! 1704: 140 I1 = IGATT1(K,1) ! 1705: I2 = IGATT1(K,7) ! 1706: I3 = IGATT1(K,8) ! 1707: IF (I3.NE.0) GO TO 150 ! 1708: CALL SATT1(K, 8, 10) ! 1709: I3 = 10 ! 1710: 150 IF (I3.NE.10) GO TO 50 ! 1711: IF (I1.GT.0) GO TO 160 ! 1712: I1 = 1 ! 1713: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2 ! 1714: CALL SATT1(K, 1, I1) ! 1715: 160 IF (MOD(I1,8).NE.2 .OR. I2.NE.0) GO TO 210 ! 1716: C ! 1717: C CHECK FOR END OF STMT ! 1718: C ! 1719: 170 IF (K2.LT.NSTMT .AND. STMT(K2).NE.62) GO TO 200 ! 1720: C ! 1721: C IF THERE ARE NO MORE CHARS, WE ARE DONE WITH THIS STMT; ! 1722: C THERE MUST BE AT LEAST 2 AND NO MORE THAN 3 LIMITS IN DO ! 1723: C ! 1724: IF (LIMS.LE.1) GO TO 230 ! 1725: 180 RETURN ! 1726: 190 ERR = .TRUE. ! 1727: GO TO 180 ! 1728: C ! 1729: C CHECK FOR A "," MUST FIND HERE ! 1730: C ! 1731: 200 IF (STMT(K2).NE.68) GO TO 50 ! 1732: IF (LIMS.GE.3) GO TO 230 ! 1733: GO TO 110 ! 1734: 210 CALL ERROR1(47H DO LIMIT NOT INTEGER SCALAR VAR OR POS INTEGER, ! 1735: * 47) ! 1736: GO TO 190 ! 1737: 220 CALL ERROR1(36H CONTROL VARIABLE NOT INTEGER SCALAR, 36) ! 1738: GO TO 190 ! 1739: 230 CALL ERROR1(18H ILLEGAL DO LIMITS, 18) ! 1740: GO TO 190 ! 1741: END ! 1742: C XXXXXDOVAR.f ! 1743: LOGICAL FUNCTION DOVAR(INDX) ! 1744: INTEGER DOPT, DOLIST ! 1745: COMMON /DOS/ DOPT, LDO, DOLIST(192) ! 1746: C ! 1747: C CHECKS VAR AT DSA(INDX) NOT IN DOSTACK ALREADY ! 1748: C AS A LIMIT OR INDEX OF PREVIOUSLY DEFINED AND CURRENTLY ! 1749: C DEFINED DO ! 1750: C ! 1751: DOVAR = .FALSE. ! 1752: IF (DOPT) 40, 40, 10 ! 1753: 10 DO 30 I=1,DOPT,6 ! 1754: L1 = I + 2 ! 1755: L2 = L1 + 3 ! 1756: DO 20 K=L1,L2 ! 1757: IF (DOLIST(K).EQ.INDX) GO TO 50 ! 1758: 20 CONTINUE ! 1759: 30 CONTINUE ! 1760: 40 RETURN ! 1761: 50 DOVAR = .TRUE. ! 1762: GO TO 40 ! 1763: END ! 1764: C XXXXXEQUIV.f ! 1765: SUBROUTINE EQUIV ! 1766: INTEGER STMT, PSTMT, PDSA, DSA, TYPE, STACK, BNEXT, SYMHD ! 1767: LOGICAL ARDECL, CORNR, SAME, ERR, SYSERR, ABORT ! 1768: COMMON /DETECT/ ERR, SYSERR, ABORT ! 1769: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 1770: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 1771: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 1772: COMMON /CEXPRS/ LSTACK, STACK(620) ! 1773: C ! 1774: C PROCESSES AN EQUIVALENCE STMT-FINDS DECLARATORS SEPARATED BY , ! 1775: C IF DIFFERENT TYPE VARIABLES INVOLVED, CHECKS FOR USE OF CORNER ! 1776: C ELEMENTS; ARDECL CALLED TO PROCESS DECLARATORS ! 1777: C SAME IS .TRUE. IF ALL ITEMS EQUIVALENCED IN ONE (--) ARE SAME TYPE ! 1778: C CORNR IS .TRUE. IF ALL ITEMS EQUIV. IN ONE (--) ARE CORNER ELES. ! 1779: C E.G. A(1,1,1) ! 1780: C ! 1781: 10 IF (STMT(PSTMT).EQ.65) GO TO 30 ! 1782: 20 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20) ! 1783: GO TO 150 ! 1784: 30 TYPE = -1 ! 1785: IPT = 1 ! 1786: CORNR = .TRUE. ! 1787: SAME = .TRUE. ! 1788: 40 PSTMT = PSTMT + 1 ! 1789: IF (PSTMT.GE.NSTMT) GO TO 20 ! 1790: IF (.NOT.ARDECL(K2,KK)) GO TO 150 ! 1791: IF (SYSERR .OR. ERR) GO TO 150 ! 1792: C ! 1793: C KK>= 0 FOR AN ARRAY ELEMENT MEANS IT WASN'T A CORNER ELEMENT ! 1794: C ! 1795: L = IGATT1(IABS(KK),7) ! 1796: IF (KK.GT.0 .AND. L.GT.0) CORNR = .FALSE. ! 1797: KK = IABS(KK) ! 1798: C ! 1799: C SET USAGE, IF UNSET ! 1800: C ! 1801: L = IGATT1(KK,8) ! 1802: IF (L.EQ.0) CALL SATT1(KK, 8, 10) ! 1803: C ! 1804: C STORE VARIABLE IN STACK, CHECK VARIABLE TYPE ! 1805: C ! 1806: STACK(IPT) = KK ! 1807: IPT = IPT + 1 ! 1808: CALL SATT1(KK, 3, 1) ! 1809: I = IGATT1(KK,1) ! 1810: I = MOD(I,8) ! 1811: IF (-1.EQ.TYPE) TYPE = I ! 1812: IF (TYPE.EQ.I) GO TO 50 ! 1813: SAME = .FALSE. ! 1814: C ! 1815: C END OF DELARATOR CHECKS; NEED , OR ) ! 1816: C ! 1817: 50 IF (STMT(K2).NE.68) GO TO 60 ! 1818: PSTMT = K2 ! 1819: GO TO 40 ! 1820: 60 IF (STMT(K2).NE.62) GO TO 20 ! 1821: C ! 1822: C CHECK FOR CORNER ELEMENTS IF ARRAY ELEMENTS WERE USED ! 1823: C ! 1824: IF (.NOT.SAME .AND. .NOT.CORNR) CALL ERROR1( ! 1825: * 53H WARNING - USE CORNER ELEMENTS WHEN MIXING DATA TYPES, 53) ! 1826: C ! 1827: C CHECK FOR ELEMENTS IN COMMON; MAKE SURE ONLY ONE COMMON ! 1828: C REGION APPEARS ! 1829: C ! 1830: KK = IPT - 1 ! 1831: C ! 1832: C PUT COMMON REGIONS OF EACH DECLARATOR (IF ANY) ON STACK ! 1833: C ! 1834: DO 80 I=1,KK ! 1835: L = IGATT1(STACK(I),2) ! 1836: IF (L) 80, 80, 70 ! 1837: 70 IF(IPT+1.GT.LSTACK) GOTO 160 ! 1838: L = STACK(I) ! 1839: L = DSA(L+2) ! 1840: STACK(IPT) = DSA(L+1) ! 1841: IPT = IPT + 1 ! 1842: 80 CONTINUE ! 1843: IF (KK+2.GE.IPT) GO TO 90 ! 1844: CALL ERROR1(40H EQUIVALENCE CONFLICTS WITH COMMON DEFNS, 40) ! 1845: GO TO 130 ! 1846: 90 IF (KK+1.EQ.IPT) GO TO 130 ! 1847: C ! 1848: C MARK ALL DECLARATORS IN EQUIV (--) AS IF IN COMMON BLOCK ! 1849: C THAT ANY ONE OF THEM IS ACTUALLY IN ! 1850: C ! 1851: DO 120 I=1,KK ! 1852: L = IGATT1(STACK(I),2) ! 1853: IF (L.EQ.1) GO TO 120 ! 1854: CALL SATT1(STACK(I), 2, 1) ! 1855: L = STACK(I) ! 1856: IF (DSA(L+2)) 100, 100, 110 ! 1857: 100 IF(NEXT+2.GE.BNEXT) GOTO 170 ! 1858: DSA(L+2) = NEXT ! 1859: DSA(NEXT) = 0 ! 1860: DSA(NEXT+1) = STACK(IPT-1) ! 1861: NEXT = NEXT + 2 ! 1862: GO TO 120 ! 1863: 110 L = DSA(L+2) ! 1864: DSA(L+1) = STACK(IPT-1) ! 1865: 120 CONTINUE ! 1866: 130 IF (K2+1.EQ.NSTMT) GO TO 150 ! 1867: IF (STMT(K2+1).NE.68) GO TO 20 ! 1868: PSTMT = K2 + 2 ! 1869: GO TO 10 ! 1870: 150 RETURN ! 1871: 160 CALL ERROR1(34H IN EQUIV, TABLE OVERFLOW OF STACK,34) ! 1872: 180 SYSERR = .TRUE. ! 1873: GOTO 150 ! 1874: 170 CALL ERROR1(32H IN EQUIV, TABLE OVERFLOW OF DSA, 32) ! 1875: GOTO 180 ! 1876: END ! 1877: C XXXXXEXTERN.f ! 1878: SUBROUTINE EXTERN ! 1879: LOGICAL ERR, SYSERR, ABORT ! 1880: LOGICAL BR, INTEXT ! 1881: INTEGER STMT, PSTMT ! 1882: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 1883: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 1884: COMMON /DETECT/ ERR, SYSERR, ABORT ! 1885: C ! 1886: C PROCESS AN EXTERNAL STMT. CAUSES IDS TO BE MARKED AS EXTERNAL ! 1887: C PROCEDURES. ERROR OCCURS IF ID HAS PREVIOUSLY DEFINED INCONSISTANT ! 1888: C USAGE. EXTERNAL CAN'T APPEAR IN BLOCK DATA PGM UNIT. ! 1889: C ! 1890: L = IGATT1(NAME,8) ! 1891: IF (L.EQ.11) GO TO 60 ! 1892: 10 CALL NEXTOK(PSTMT, K2, KK) ! 1893: IF (KK.EQ.0) GO TO 20 ! 1894: CALL ERROR1(19H ILLEGAL IDENTIFIER, 19) ! 1895: GO TO 70 ! 1896: 20 KK = LOOKUP(K2,.FALSE.) ! 1897: IF (SYSERR) RETURN ! 1898: L = IGATT1(KK,8) ! 1899: IF (L.EQ.0) GO TO 30 ! 1900: CALL ERROR1(26H ILLEGAL USE OF IDENTIFIER, 26) ! 1901: GO TO 40 ! 1902: 30 CALL SATT1(KK, 8, 13) ! 1903: C ! 1904: C CAUSE EXTERNAL BIT TO BE SET IF POSSIBLE BASIC EXTERNAL ! 1905: C ! 1906: 40 BR = INTEXT(KK,0,0,.FALSE.) ! 1907: IF (K2.EQ.NSTMT) GO TO 70 ! 1908: IF (STMT(K2).NE.68) GO TO 50 ! 1909: PSTMT = K2 + 1 ! 1910: GO TO 10 ! 1911: 50 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20) ! 1912: GO TO 70 ! 1913: 60 CALL ERROR1( ! 1914: *60H ILLEGAL USAGE OF EXTERNAL STMT WITHIN BLOCK DATA SUBPROGRAM, ! 1915: * 60) ! 1916: 70 RETURN ! 1917: END ! 1918: C XXXXXFIXLAB.f ! 1919: SUBROUTINE FIXLAB(ND) ! 1920: C ! 1921: C ROUTINE SETS END-OF-DEF-STMT NO FOR LABELS ! 1922: C WHEN CALLED BY END STMT, FIXES ALL LABEL DEFS YET UNBOUND ! 1923: C TO THE END OF PGM STMT NO. WHEN CALLED BY DO STMT ! 1924: C FIXES UP ALL LABELS AT THE LEVEL OF THE CURRENT ! 1925: C DO TO END-OF-DO STMT NO; ND TRUE MEANS AN END STMT CALLED FIXLAB ! 1926: C ! 1927: LOGICAL ND ! 1928: INTEGER DOLIST, DOPT, BNEXT, SYMHD, DSA, PDSA ! 1929: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 1930: COMMON /DOS/ DOPT, LDO, DOLIST(192) ! 1931: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 1932: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 1933: LEV = -DOPT/6 ! 1934: I = LABHD ! 1935: 10 IF (I.EQ.0) RETURN ! 1936: K = IGATT1(I,2) ! 1937: IF (K.NE.1) GO TO 30 ! 1938: K = IGATT1(I,1) ! 1939: IF (K.NE.1) GO TO 30 ! 1940: K = DSA(I+2) ! 1941: IF (ND) GO TO 20 ! 1942: IF (DSA(K+1).EQ.LEV) DSA(K+1) = NOST ! 1943: GO TO 30 ! 1944: 20 IF (DSA(K+1).LE.0) DSA(K+1) = NOST ! 1945: 30 I = DSA(I+3) ! 1946: GO TO 10 ! 1947: END ! 1948: C XXXXXFORMAT.f ! 1949: SUBROUTINE FORMAT ! 1950: INTEGER STMT, PSTMT ! 1951: LOGICAL TOKPNO, SIGN, ERROR ! 1952: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 1953: C ! 1954: C ROUTINE PROCESSES FORMAT STMT ! 1955: C FORMAT (Q1 T1 Z1 T2 Z2 ... TN Q2) ! 1956: C Q1,Q2 ARE EMPTY OR ARE SEPARARTERS ! 1957: C T1,T2 ETC. ARE FORMAT-ITEMS ! 1958: C Z1,Z2, ETC. ARE SEPARATERS ! 1959: C CHECKS FOR <= 2 LEVELS OF PARENTHESES ! 1960: C ! 1961: ERROR = .FALSE. ! 1962: ICNT = 0 ! 1963: C ! 1964: C "(" ! 1965: C ! 1966: IF (STMT(PSTMT).EQ.65) GO TO 30 ! 1967: 10 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20) ! 1968: C ! 1969: C SEARCH FOR FORMAT ITEMS ! 1970: C ! 1971: 20 RETURN ! 1972: 30 ICNT = ICNT + 1 ! 1973: IF (ICNT.GT.2) CALL ERROR1(28H TOO MANY PARENTHESES LEVELS, 28) ! 1974: PSTMT = PSTMT + 1 ! 1975: C ! 1976: C LOOK FOR Q1 ! 1977: C ! 1978: CALL SEPAR(I) ! 1979: C TAKES CARE OF FORMAT() ! 1980: IF (STMT(PSTMT).EQ.62) GO TO 180 ! 1981: IF (STMT(PSTMT-1).EQ.68) CALL ERROR1(25H ILLEGAL PUNCTUATION (, , ! 1982: * 25) ! 1983: 40 IF (STMT(PSTMT).EQ.65) GO TO 30 ! 1984: IF (PSTMT.GE.NSTMT) GO TO 10 ! 1985: SIGN = .FALSE. ! 1986: C ! 1987: C SEARCH FOR REPEAT FACTER (POSITIVE INTEGER) ! 1988: C ! 1989: IF (TOKPNO(PSTMT,K2,N)) GO TO 70 ! 1990: C ! 1991: C HOLLERITH STRINGS ! 1992: C ! 1993: IF (STMT(PSTMT).LT.0) GO TO 120 ! 1994: C ! 1995: C "-" IN P SCALING FORMAT-ITEM ! 1996: C ! 1997: IF (STMT(PSTMT).NE.61) GO TO 50 ! 1998: SIGN = .TRUE. ! 1999: PSTMT = PSTMT + 1 ! 2000: 50 IF (PSTMT.GE.NSTMT) GO TO 10 ! 2001: C ! 2002: C LOOK FOR <INT> IN PSCALING FORMAT-ITEM ! 2003: C P SCALING FORMAT-ITEM ! 2004: C ( - ) <INTEGER> P REPEAT (A,I,L) <WIDTH> . <INT> ! 2005: C ! 2006: CALL NEXTOK(PSTMT, K2, K) ! 2007: C ! 2008: C CHECK FOR USE OF "-" WITH NON P-SCALING CONSTRUCTS ! 2009: C ! 2010: IF (K.NE.1 .AND. SIGN) GO TO 100 ! 2011: IF (K.EQ.1) GO TO 60 ! 2012: N = STMT(PSTMT) ! 2013: GO TO 90 ! 2014: 60 SIGN = .TRUE. ! 2015: PSTMT = K2 ! 2016: N = STMT(PSTMT) ! 2017: GO TO 80 ! 2018: C ! 2019: C LOOK FOR PART OF FORMAT-ITEM AFTER REPEAT FACTOR ! 2020: C ! 2021: 70 PSTMT = K2 ! 2022: N = STMT(PSTMT) ! 2023: C ! 2024: C "(" ! 2025: C ! 2026: IF (N.EQ.65) GO TO 30 ! 2027: C ! 2028: C "X" ! 2029: C ! 2030: IF (N.EQ.53) GO TO 120 ! 2031: C ! 2032: C "P" ! 2033: C ! 2034: 80 IF (N.EQ.45) GO TO 130 ! 2035: IF (SIGN) GO TO 100 ! 2036: C ! 2037: C A,I,L ! 2038: C ! 2039: 90 IF (N.EQ.30 .OR. N.EQ.38 .OR. N.EQ.41) GO TO 110 ! 2040: C ! 2041: C D,E,F,G ! 2042: C ! 2043: IF (N.GE.33 .AND. N.LE.36) GO TO 150 ! 2044: 100 CALL ERROR1(20H ILLEGAL FORMAT ITEM, 20) ! 2045: GO TO 20 ! 2046: C ! 2047: C A,I,L FOUND. LOOK FOR <WIDTH> ! 2048: C ! 2049: 110 IF (PSTMT+1.GE.NSTMT) GO TO 10 ! 2050: PSTMT = PSTMT + 1 ! 2051: IF (.NOT.TOKPNO(PSTMT,K2,I)) GO TO 100 ! 2052: IF (N.NE.30 .OR. I.EQ.1 .OR. ERROR) GO TO 160 ! 2053: CALL ERROR1(48H WARNING - A FORMAT ITEM NOT PORTABLE FOR N.GT.1, ! 2054: * 48) ! 2055: ERROR = .TRUE. ! 2056: GO TO 160 ! 2057: C ! 2058: C SKIP TO NEXT CHAR IN X OR HOLLERITH ! 2059: C ! 2060: 120 PSTMT = PSTMT + 1 ! 2061: GO TO 170 ! 2062: C ! 2063: C LOOK FOR CONSTRUCT FOLLOWING THE P. CAN BE A REPEAT ! 2064: C ! 2065: 130 IF (PSTMT+1.GE.NSTMT) GO TO 10 ! 2066: PSTMT = PSTMT + 1 ! 2067: IF (STMT(PSTMT).GT.9 .OR. STMT(PSTMT).LT.0) GO TO 140 ! 2068: CALL NEXTOK(PSTMT, K2, K) ! 2069: IF (K.NE.1) GO TO 10 ! 2070: PSTMT = K2 ! 2071: C ! 2072: C AFTER D,E,F,G FIND <WIDTH> . <INT> ! 2073: C ! 2074: 140 IF (STMT(PSTMT).LT.33 .OR. STMT(PSTMT).GT.36) GO TO 10 ! 2075: 150 IF (PSTMT+1.GE.NSTMT) GO TO 10 ! 2076: PSTMT = PSTMT + 1 ! 2077: IF (.NOT.TOKPNO(PSTMT,K2,N)) GO TO 100 ! 2078: IF (STMT(K2).NE.64) GO TO 100 ! 2079: IF (K2+1.GE.NSTMT) GO TO 10 ! 2080: PSTMT = K2 + 1 ! 2081: CALL NEXTOK(PSTMT, K2, K) ! 2082: IF (K.NE.1) GO TO 100 ! 2083: 160 PSTMT = K2 ! 2084: C ! 2085: C FINISHED A FORMAT-ITEM ! 2086: C LOOK FOR SEPARATER OR ")" ! 2087: C ! 2088: 170 IF (STMT(PSTMT).NE.62) GO TO 210 ! 2089: 180 ICNT = ICNT - 1 ! 2090: IF (ICNT.LT.0) GO TO 190 ! 2091: IF (PSTMT+1.LT.NSTMT) GO TO 200 ! 2092: IF (ICNT.EQ.0) GO TO 20 ! 2093: 190 CALL ERROR1(28H ILLEGAL PARENTHESES NESTING, 28) ! 2094: GO TO 20 ! 2095: 200 PSTMT = PSTMT + 1 ! 2096: GO TO 170 ! 2097: 210 CALL SEPAR(I) ! 2098: IF (I.EQ.0) CALL ERROR1(24H MISSING FIELD SEPARATOR, 24) ! 2099: IF (STMT(PSTMT).NE.62) GO TO 40 ! 2100: IF (STMT(PSTMT-1).EQ.68) CALL ERROR1(25H ILLEGAL PUNCTUATION ,) , ! 2101: * 25) ! 2102: GO TO 180 ! 2103: END ! 2104: C XXXXXGETTOK.f ! 2105: INTEGER FUNCTION GETTOK(K1, K2) ! 2106: C ! 2107: C GETTOK FINDS NEXT TOKEN IN STMT(K1)-STMT(K2-1) ! 2108: C AND RETURNS A VALUE: ! 2109: C 0= DOUBLE PRECISION CONSTANT- ! 2110: C 2= INTEGER CONSTANT ! 2111: C 1= REAL CONSTANT- ! 2112: C 3= COMPLEX CONSTANT ! 2113: C 4= LOGICAL CONSTANT ! 2114: C 5= HOLLERITH CONSTANT ! 2115: C 6= ID ! 2116: C >10=OPERATOR (10+CODE FOR OPERATOR;HERE ARRAY AND FCN REFS ARE 16 ! 2117: C ! 2118: INTEGER PSTMT, STMT ! 2119: LOGICAL ERR, SYSERR, ABORT, TOKLOP, TOKRL, TOKCOM, TOKLOG ! 2120: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 2121: COMMON /DETECT/ ERR, SYSERR, ABORT ! 2122: 10 GETTOK = -1 ! 2123: IF (.NOT.TOKRL(K1,K2,K)) GO TO 20 ! 2124: GETTOK = 1 ! 2125: IF (K.EQ.0) GETTOK = 0 ! 2126: GO TO 40 ! 2127: 20 CALL NEXTOK(K1, K2, K) ! 2128: K = K + 1 ! 2129: GO TO (50, 30, 60, 70), K ! 2130: 30 GETTOK = 2 ! 2131: 40 RETURN ! 2132: C ! 2133: C PROCESS ID, SEE IF ITS A FCN CALL OR ARRAY NAME ! 2134: C ! 2135: 50 GETTOK = 6 ! 2136: IF (STMT(K2).NE.65) GO TO 40 ! 2137: GETTOK = 16 ! 2138: K2 = K2 + 1 ! 2139: GO TO 40 ! 2140: 60 GETTOK = 5 ! 2141: GO TO 40 ! 2142: 70 K = STMT(K1) ! 2143: IF (K.EQ.64) GO TO 100 ! 2144: IF (K.EQ.65) GO TO 80 ! 2145: IF (K.EQ.62) GETTOK = 12 ! 2146: IF (K.EQ.68) GETTOK = 18 ! 2147: IF (K.EQ.60 .OR. K.EQ.61) GETTOK = 11 ! 2148: IF (K.EQ.66 .OR. K.EQ.67) GETTOK = 17 ! 2149: IF (K2.EQ.K1+2) GETTOK = 13 ! 2150: IF (GETTOK+1) 40, 120, 40 ! 2151: 80 GETTOK = 15 ! 2152: IF (TOKCOM(K1,K)) GO TO 90 ! 2153: GO TO 40 ! 2154: 90 GETTOK = 3 ! 2155: K2 = K ! 2156: GO TO 40 ! 2157: C ! 2158: C CHECK FOR LOGICAL CONSTANTS,OPERATORS ! 2159: C ! 2160: 100 IF (.NOT.TOKLOG(K1,K2)) GO TO 110 ! 2161: GETTOK = 4 ! 2162: GO TO 40 ! 2163: 110 IF (.NOT.TOKLOP(K1,K2,K)) GO TO 120 ! 2164: GETTOK = K ! 2165: GO TO 40 ! 2166: 120 CALL ERROR1(26H ILLEGAL CHARACTER IGNORED, 26) ! 2167: IF (K1+1.GE.NSTMT) GO TO 130 ! 2168: K1 = K1 + 1 ! 2169: GO TO 10 ! 2170: 130 ERR = .TRUE. ! 2171: RETURN ! 2172: END ! 2173: C XXXXXGOTO.f ! 2174: SUBROUTINE GOTO ! 2175: INTEGER STMT, PSTMT ! 2176: LOGICAL TOKLAB, DONE, ERR, SYSERR, ABORT ! 2177: COMMON /DETECT/ ERR, SYSERR, ABORT ! 2178: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 2179: C ! 2180: C PROCESSES UNCONDITIONAL, ASSIGNED, AND COMPUTED GOTO STMTS ! 2181: C ! 2182: IF (PSTMT.GE.NSTMT) GO TO 100 ! 2183: DONE = .FALSE. ! 2184: C ! 2185: C UNCONDITIONAL GOTO ! 2186: C ! 2187: IF (TOKLAB(1,K2,K,.FALSE.)) GO TO 110 ! 2188: C ! 2189: C COMPUTED GOTO ! 2190: C ! 2191: IF (SYSERR) GO TO 110 ! 2192: IF (STMT(PSTMT).EQ.65) GO TO 70 ! 2193: C ! 2194: C ASSIGNED GOTO: GOTO <VAR> , ( <LAB> , ETC. ) ! 2195: C ! 2196: 10 CALL NEXTOK(PSTMT, K2, K) ! 2197: IF (K.NE.0) GO TO 100 ! 2198: K = LOOKUP(K2,.FALSE.) ! 2199: IF (SYSERR) GO TO 110 ! 2200: I1 = IGATT1(K,1) ! 2201: IF (I1.NE.0) GO TO 20 ! 2202: I1 = 1 ! 2203: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2 ! 2204: CALL SATT1(K, 1, I1) ! 2205: 20 I2 = IGATT1(K,7) ! 2206: IF (MOD(I1,8).NE.2 .OR. I2.NE.0) CALL ERROR1( ! 2207: * 31H NOT AN INTEGER SCALAR VARIABLE, 31) ! 2208: I1 = IGATT1(K,8) ! 2209: IF (DONE) GO TO 40 ! 2210: C ! 2211: C CHECK FOR ASSIGN VARIABLE IN USAGE ! 2212: C ! 2213: IF (I1.EQ.0) GO TO 30 ! 2214: IF (I1.NE.8) CALL ERROR1(26H ID NOT AN ASSIGN VARIABLE, 26) ! 2215: GO TO 60 ! 2216: 30 CALL SATT1(K, 8, 8) ! 2217: GO TO 60 ! 2218: C ! 2219: C CHECK FOR VARIABLE IN USAGE ! 2220: C ! 2221: 40 IF (I1.EQ.0) GO TO 50 ! 2222: IF (I1.NE.10) CALL ERROR1(19H ILLEGAL ID IN GOTO, 19) ! 2223: GO TO 130 ! 2224: 50 CALL SATT1(K, 8, 10) ! 2225: GO TO 130 ! 2226: C ! 2227: C LOOK FOR "," ! 2228: C ! 2229: 60 IF (STMT(K2).NE.68) GO TO 100 ! 2230: K2 = K2 + 1 ! 2231: DONE = .TRUE. ! 2232: IF (STMT(K2).NE.65) GO TO 100 ! 2233: GO TO 80 ! 2234: 70 PSTMT = PSTMT + 1 ! 2235: GO TO 90 ! 2236: 80 PSTMT = K2 + 1 ! 2237: C ! 2238: C LOOK FOR ( <LAB> , ETC.) ! 2239: C ! 2240: 90 IF (PSTMT.GE.NSTMT) GO TO 100 ! 2241: IF (.NOT.TOKLAB(1,K2,K,.FALSE.)) GO TO 100 ! 2242: IF(SYSERR) GOTO 110 ! 2243: IF (STMT(K2).EQ.68) GO TO 80 ! 2244: IF (STMT(K2).NE.62) GO TO 100 ! 2245: IF (DONE) GO TO 120 ! 2246: DONE = .TRUE. ! 2247: IF (STMT(K2+1).NE.68) GO TO 100 ! 2248: PSTMT = K2 + 2 ! 2249: IF (PSTMT.LT.NSTMT) GO TO 10 ! 2250: 100 CALL ERROR1(15H ILLEGAL SYNTAX, 15) ! 2251: 110 RETURN ! 2252: C ! 2253: C CHECK END OF STMT IS REACHED ! 2254: C ! 2255: 120 K2 = K2 + 1 ! 2256: 130 IF (K2.NE.NSTMT) CALL ERROR1( ! 2257: * 34H EXTRANEOUS INFO AFTER END OF STMT, 34) ! 2258: GO TO 110 ! 2259: END ! 2260: C XXXXXID.f ! 2261: SUBROUTINE ID(K2) ! 2262: INTEGER STMT, PSTMT ! 2263: LOGICAL ERR, SYSERR, ABORT, DOVAR ! 2264: COMMON /DETECT/ ERR, SYSERR, ABORT ! 2265: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 2266: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 2267: C ! 2268: C ROUTINE CHECKS IDENTIFIERS IN <LIST> FOR BEING ARRAY,ARRAY ELEMENT ! 2269: C OR VARIABLE.- RETURNS ERR=.TRUE. IF MUST CEASE PROCESSING ! 2270: C FIRST CHECK USAGE ! 2271: C ! 2272: K = LOOKUP(K2,.FALSE.) ! 2273: IF (SYSERR) GO TO 50 ! 2274: C ! 2275: C CHECK USAGE ! 2276: C ! 2277: I3 = IGATT1(K,8) ! 2278: IF (I3.NE.0) GO TO 10 ! 2279: CALL SATT1(K, 8, 10) ! 2280: GO TO 20 ! 2281: 10 IF (I3.NE.10) CALL ERROR1(27H ILLEGAL IDENTIFIER IN LIST, 27) ! 2282: C ! 2283: C SET TYPE ! 2284: C ! 2285: 20 I3 = IGATT1(K,1) ! 2286: IF (I3.NE.0) GO TO 30 ! 2287: I3 = 1 ! 2288: IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I3 = 2 ! 2289: CALL SATT1(K, 1, I3) ! 2290: C ! 2291: C CHECK FOR READING INTO DO CONTROL VARIABLE OR LIMIT ! 2292: C ! 2293: 30 IF (ITYP.NE.23) GO TO 40 ! 2294: IF (DOVAR(K)) CALL ERROR1( ! 2295: * 57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS, ! 2296: * 57) ! 2297: C ! 2298: C MARK VARIABLES AS SET IF VALUES READ IN ! 2299: C ! 2300: CALL SATT1(K, 5, 1) ! 2301: C ! 2302: C SEPARATE OUT ARRAY ELEMENTS AND CHECK SUBSCRIPTS ! 2303: C ! 2304: 40 IF (STMT(K2).NE.65) GO TO 50 ! 2305: I3 = IGATT1(K,7) ! 2306: IF (I3.EQ.0) GO TO 60 ! 2307: PSTMT = K2 + 1 ! 2308: IF (PSTMT.GE.NSTMT) GO TO 80 ! 2309: CALL SUBS(K2, I3) ! 2310: ERR = .FALSE. ! 2311: 50 RETURN ! 2312: 60 CALL ERROR1(40H ILLEGAL SUBSCRIPTING OF SCALAR VARIABLE, 40) ! 2313: 70 ERR = .TRUE. ! 2314: GO TO 50 ! 2315: 80 CALL ERROR1(19H SUBSCRIPTING ERROR, 19) ! 2316: GO TO 70 ! 2317: END ! 2318: C XXXXXIDLIST.f ! 2319: LOGICAL FUNCTION IDLIST(IDO) ! 2320: INTEGER PSTMT, STMT ! 2321: LOGICAL ERR, SYSERR, ABORT, IDO ! 2322: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 2323: COMMON /DETECT/ ERR, SYSERR, ABORT ! 2324: C ! 2325: C RECOGNIZES IDLIST=<ID> �, <ID>! ;LAST <ID> CANNOT BE FOLLOWED BY ! 2326: C A '='; IDLIST MUST CONTAIN AT LEAST ONE ID. IDLIST=.FALSE. WILL ! 2327: C BE RETURNED FOR AN IRRECOVERABLE SYNTAX ERROR. ! 2328: C IDO SET TO .TRUE. WHEN <IDLIST> IS FOLLOWED BY <DOSPEC> ! 2329: C ! 2330: IDO = .FALSE. ! 2331: IDLIST = .TRUE. ! 2332: IF (PSTMT.GE.NSTMT) GO TO 60 ! 2333: CALL NEXTOK(PSTMT, K2, K) ! 2334: IF (K.NE.0) GO TO 60 ! 2335: IF (STMT(K2).EQ.63) GO TO 20 ! 2336: CALL ID(K2) ! 2337: IF (ERR .OR. SYSERR) GO TO 20 ! 2338: 10 PSTMT = K2 ! 2339: IF (STMT(PSTMT).EQ.68 .AND. STMT(PSTMT+1).EQ.65 .OR. ! 2340: * STMT(PSTMT).EQ.62 .OR. PSTMT.EQ.NSTMT) GO TO 30 ! 2341: IF (STMT(PSTMT).EQ.68) GO TO 50 ! 2342: CALL ERROR1(35H ILLEGAL TOKEN FOLLOWING IDENTIFIER, 35) ! 2343: 20 IDLIST = .FALSE. ! 2344: ERR = .FALSE. ! 2345: 30 RETURN ! 2346: 40 IDO = .TRUE. ! 2347: GO TO 30 ! 2348: C ! 2349: C MAKE SURE <ID> = ISN'T NEXT CONSTRUCT ! 2350: C ! 2351: 50 K2 = K2 + 1 ! 2352: IF (K2.GE.NSTMT) GO TO 60 ! 2353: CALL NEXTOK(K2, K3, K) ! 2354: IF (STMT(K3).EQ.63) GO TO 40 ! 2355: PSTMT = K2 ! 2356: K2 = K3 ! 2357: CALL ID(K2) ! 2358: IF (ERR .OR. SYSERR) GO TO 20 ! 2359: GO TO 10 ! 2360: 60 CALL ERROR1(23H ILLEGAL SYNTAX IN LIST, 23) ! 2361: GO TO 20 ! 2362: END ! 2363: C XXXXXIFS.f ! 2364: SUBROUTINE IFS(LOG) ! 2365: LOGICAL TOKLAB, ERR, SYSERR, ABORT, LOG ! 2366: INTEGER STMT, PSTMT, EXPR ! 2367: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 2368: COMMON /DETECT/ ERR, SYSERR, ABORT ! 2369: C ! 2370: C ROUTINE PROCESSES ARITHMETIC AND LOGICAL IF STMTS ! 2371: C LOG RETURNED AS TRUE IF LOGICAL-IF IS ENCOUNTERED;PU CHECKS FOR ! 2372: C ACCEPTIBLE EXECUTABLE STMT AFTER LOGICAL EXPRESSION ! 2373: C ! 2374: LOG = .FALSE. ! 2375: L = MOD(EXPR(I),8) ! 2376: IF (-1.EQ.L .OR. SYSERR) GO TO 30 ! 2377: LOG = L.EQ.4 ! 2378: IF (LOG) GO TO 30 ! 2379: C ! 2380: C ARITHMETIC IF--SEARCH FOR <LAB>,<LAB>,<LAB> ! 2381: C ! 2382: IF (L.GT.2) GO TO 50 ! 2383: I = 0 ! 2384: IF (PSTMT.GE.NSTMT) GO TO 20 ! 2385: 10 IF (.NOT.TOKLAB(1,K2,L,.FALSE.)) GO TO 40 ! 2386: IF (SYSERR) GO TO 30 ! 2387: I = I + 1 ! 2388: IF (I.EQ.3) GO TO 60 ! 2389: IF (STMT(K2).NE.68) GO TO 20 ! 2390: PSTMT = K2 + 1 ! 2391: IF (PSTMT.LT.NSTMT) GO TO 10 ! 2392: 20 CALL ERROR1(15H ILLEGAL SYNTAX, 15) ! 2393: 30 RETURN ! 2394: 40 CALL ERROR1(14H MISSING LABEL, 14) ! 2395: GO TO 30 ! 2396: 50 CALL ERROR1(39H COMPLEX EXPRESSION ILLEGAL IN ARITH-IF, 39) ! 2397: GO TO 30 ! 2398: 60 IF (K2.EQ.NSTMT) GO TO 30 ! 2399: CALL ERROR1(34H EXTRANEOUS INFO AFTER END OF STMT, 34) ! 2400: GO TO 30 ! 2401: END ! 2402: C XXXXXINTEXT.f ! 2403: LOGICAL FUNCTION INTEXT(LL, L1, L2, BR) ! 2404: C ! 2405: C LL POINTS TO DSA ENTRY OF FCN NAME ! 2406: C L1 POINTS INTO STACK TO BEGINNING OF ARGS ! 2407: C L2 POINTS INTO STACK TO LAST ARG ENTRY ! 2408: C BR .TRUE. MEANS LOOK FOR BOTH EXTERNALS ND INTRINS ! 2409: C BR FALSE MEANS JUST LOOK FOR EXTERNALS ! 2410: C ROUTINE CHECKS FOR REFERENCES TO INTRINSIC OR BASIC EXTERNAL ! 2411: C FCNS; RETURNS TRUE IF FINDS INTRINSIC FCN. CHECKS INTRINSICS ! 2412: C ARGS FOR USAGE, TYPE AND NUMBER. MARKS POSSIBLE BASIC EXTDRNAL ! 2413: C FCNS SENT DOWN TO IT ! 2414: C ! 2415: INTEGER STACK, BL, PDSA, DSA, FCN(6), Z ! 2416: LOGICAL BR ! 2417: COMMON /CEXPRS/ LSTACK, STACK(620) ! 2418: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 2419: COMMON /INTS/ Z(346) ! 2420: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 2421: DATA BL /1H / ! 2422: INTEXT = .FALSE. ! 2423: CALL S5UNPK(DSA(LL+4), FCN(1), 6) ! 2424: K = 1 ! 2425: DO 40 I=1,55 ! 2426: K1 = K + 1 ! 2427: K2 = K1 + Z(K) - 1 ! 2428: L = 0 ! 2429: DO 10 J=K1,K2 ! 2430: L = L + 1 ! 2431: IF (FCN(L).NE.Z(J)) GO TO 30 ! 2432: 10 CONTINUE ! 2433: IF (L.EQ.6) GO TO 60 ! 2434: L = L + 1 ! 2435: DO 20 J=L,6 ! 2436: IF (FCN(J).NE.BL) GO TO 30 ! 2437: 20 CONTINUE ! 2438: GO TO 60 ! 2439: 30 K = K2 + 2 ! 2440: 40 CONTINUE ! 2441: 50 RETURN ! 2442: C ! 2443: C DIFFERENTIATES BETWEEN A POSSIBLE BASIC EXTERNAL AND POSSIBLE ! 2444: C INTRINSIC FCN ! 2445: C ! 2446: 60 L = MOD(Z(K2+1),1024)/512 ! 2447: C ! 2448: C IF POSSIBLE BASIC EXTERNAL CHECK TYPE AND SET IT IF NOT ALREADY ! 2449: C EXPLICITLY SET ! 2450: C ! 2451: IF (L.NE.1) GO TO 70 ! 2452: L = IGATT1(LL,1) ! 2453: IF (L/8.GE.1) GO TO 190 ! 2454: L = MOD(Z(K2+1),8) ! 2455: IF (BR) L = L + 8 ! 2456: CALL SATT1(LL, 1, L) ! 2457: C ! 2458: C MARK AS USED IN PASS 1 ! 2459: C ! 2460: GO TO 190 ! 2461: C ! 2462: C CHEKC IF IN EXTERNAL STMT IF SO NOT AN INTRINSIC ! 2463: C ! 2464: 70 IF (.NOT.BR) GO TO 50 ! 2465: L = IGATT1(LL,8) ! 2466: IF (L.EQ.13) GO TO 50 ! 2467: C ! 2468: C CHECK IF EXPLICITLY TYPES DIFFERENTLY THAN EXPECTED ! 2469: C ! 2470: L = IGATT1(LL,1) ! 2471: J = MOD(Z(K2+1),8) ! 2472: IF (L.GE.8) GO TO 80 ! 2473: CALL SATT1(LL, 1, J+8) ! 2474: GO TO 90 ! 2475: 80 IF (J.NE.MOD(L,8)) GO TO 50 ! 2476: C ! 2477: C K POINTS TO THE FUNCTION ENTRY IN Z ! 2478: C K1 POINTS TO FIRST LETTER IN FCN-NAME; K2 TO LAST LETTER ! 2479: C FIELDS IN ATTRIBUTE WORD ARE AS FOLLOWS: ! 2480: C BITS 0-2 TYPE FCN ! 2481: C BITS 3-5 TYPE ARGS ! 2482: C BIT 6 IF 1, FIXED NO ARGS; IF 0 VARIABLE NO OF ARGS ! 2483: C BITS 7-8 MINIMUM NUMBER OF ARGS ! 2484: C BITS 9 IF 0, INTRINSIC; IF 1 BASIC EXTERNAL ! 2485: C BITS 10 IF 1 USED IN PASS 1; ELSE NOT REFERENCED ! 2486: C ! 2487: C FCN IS INTRINSIC ! 2488: C CHECK NUMBER OF ARGS ! 2489: C ! 2490: 90 I = MOD(Z(K2+1),128)/64 ! 2491: J = MOD(Z(K2+1),512)/128 ! 2492: IF (I) 100, 100, 120 ! 2493: C ! 2494: C VARIABLE NUMBER OF ARGS ALLOWED ! 2495: C MUST BE AT LEAST J ! 2496: C ! 2497: 100 IF ((L2-L1+1)/2.GE.J) GO TO 130 ! 2498: 110 CALL ERROR2(29H INCORRECT NUMBER OF ARGS IN , 29, DSA(LL+4), ! 2499: * 1, 1, 1) ! 2500: GO TO 180 ! 2501: C ! 2502: C FIXED NUMBER OF ARGS ! 2503: C ! 2504: 120 IF ((L2-L1+1)/2.NE.J) GO TO 110 ! 2505: C ! 2506: C CHECK THRU ARG LIST OR PROPER TYPE ID AS AN ARG; ! 2507: C CHECK TYPE AND THAT ARGS ARE SCALARS ! 2508: C ! 2509: 130 L = MOD(Z(K2+1),64)/8 ! 2510: DO 170 N=L1,L2,2 ! 2511: C ! 2512: C CHECK FOR EXPRESSION AS ARG ! 2513: C ! 2514: IF (STACK(N).EQ.0) GO TO 160 ! 2515: C ! 2516: C CHECK USAGE ! 2517: C ! 2518: I = IGATT1(STACK(N),8) ! 2519: IF (I.EQ.10 .OR. ((I.EQ.2 .OR. I.EQ.5 .OR. I.EQ.14) .AND. ! 2520: * STACK(N+1).NE.6)) GO TO 160 ! 2521: IF (I.NE.0) GO TO 140 ! 2522: CALL SATT1(STACK(N), 8, 10) ! 2523: GO TO 160 ! 2524: 140 IF (I.EQ.1 .AND. ITYP.NE.31) GO TO 150 ! 2525: I = STACK(N) ! 2526: IF (DSA(I+2).EQ.IASF) GO TO 160 ! 2527: 150 CALL ERROR2(40H ILLEGAL ARGUMENT IN INTRINSIC REFERENCE, 40, ! 2528: * DSA(LL+4), 1, 1, 1) ! 2529: GO TO 170 ! 2530: C ! 2531: C CHECK STRUCTURE ! 2532: C ! 2533: 160 IF (STACK(N+1)/8.EQ.1) CALL ERROR2( ! 2534: * 48H ILLEGAL STRUCTURE OF ARG IN INTRINSIC REFERENCE, 48, ! 2535: * DSA(LL+4), 1, 1, 1) ! 2536: C ! 2537: C CHECK TYPE ! 2538: C ! 2539: IF (MOD(STACK(N+1),8).NE.L) CALL ERROR2( ! 2540: * 43H ILLEGAL TYPE OF ARG IN INTRINSIC REFERENCE, 43, ! 2541: * DSA(LL+4), 1, 1, 1) ! 2542: 170 CONTINUE ! 2543: 180 INTEXT = .TRUE. ! 2544: I = IGATT1(LL,8) ! 2545: IF (I.NE.0) GO TO 190 ! 2546: CALL SATT1(LL, 8, 14) ! 2547: C ! 2548: C MARK FCN AS USED ! 2549: C ! 2550: 190 K = Z(K2+1)/1024 ! 2551: IF (K.EQ.0) Z(K2+1) = Z(K2+1) + 1024 ! 2552: GO TO 50 ! 2553: END ! 2554: C XXXXXIO.f ! 2555: SUBROUTINE IO ! 2556: LOGICAL ERR, SYSERR, TOKPNO, OK, ABORT, TOKLAB ! 2557: INTEGER STMT, PSTMT ! 2558: INTEGER EN(4) ! 2559: LOGICAL SW ! 2560: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 2561: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 2562: COMMON /DETECT/ ERR, SYSERR, ABORT ! 2563: COMMON /SWS/ SW(10) ! 2564: DATA EN(1), EN(2), EN(3), EN(4) /34,43,33,63/ ! 2565: C ! 2566: C ROUTINE RECOGNIZES READ,WRITE,REWIND,BACKSPACE,ENDFILE,PAUSE STMTS ! 2567: C ! 2568: OK = .TRUE. ! 2569: ASSIGN 160 TO IFORM ! 2570: IF (ITYP.NE.23 .AND. ITYP.NE.24) GO TO 240 ! 2571: C ! 2572: C SYNTAX OF READ, WRITE STMTS IS THE SAME EXCEPT A BINARY WRITE ! 2573: C NEEDS A <LIST>. (SEE USE OF OK) ! 2574: C "READ" (�<UNIT> / <UNIT> , <FORM>!) �<LIST>! ! 2575: C <UNIT> IS INTEGER SCALAR VARIABLE OR POSITIVE INTEGER CONST ! 2576: C <FORM> IS <LABEL> OR <ARRAY NAME>. ! 2577: C ! 2578: IF (STMT(PSTMT).NE.65) GO TO 230 ! 2579: PSTMT = PSTMT + 1 ! 2580: IF (PSTMT.GE.NSTMT) GO TO 120 ! 2581: 10 IF (TOKPNO(PSTMT,K2,K)) GO TO 60 ! 2582: CALL NEXTOK(PSTMT, K2, K) ! 2583: IF (K.EQ.0) GO TO 20 ! 2584: CALL ERROR1(13H ILLEGAL UNIT, 13) ! 2585: GO TO 110 ! 2586: 20 K = LOOKUP(K2,.FALSE.) ! 2587: IF (SYSERR) GO TO 110 ! 2588: I1 = IGATT1(K,1) ! 2589: I2 = IGATT1(K,7) ! 2590: I3 = IGATT1(K,8) ! 2591: IF (I3.NE.0) GO TO 30 ! 2592: CALL SATT1(K, 8, 10) ! 2593: GO TO 40 ! 2594: 30 IF (I3.EQ.10) GO TO 40 ! 2595: CALL ERROR1(13H ILLEGAL UNIT, 13) ! 2596: 40 IF (I1.NE.0) GO TO 50 ! 2597: I1 = 1 ! 2598: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2 ! 2599: CALL SATT1(K, 1, I1) ! 2600: 50 IF (MOD(I1,8).NE.2 .OR. I2.NE.0) CALL ERROR1(13H ILLEGAL UNIT, 13) ! 2601: 60 PSTMT = K2 ! 2602: C ! 2603: C DISTINGUISH ( <UNIT> ) FROM ( <UNIT>,<FORM> ) ! 2604: C ! 2605: IF (ITYP.NE.23 .AND. ITYP.NE.24) GO TO 100 ! 2606: IF (STMT(PSTMT).EQ.68) GO TO 130 ! 2607: IF (STMT(PSTMT).EQ.62 .AND. ITYP.EQ.24) OK = .FALSE. ! 2608: C ! 2609: C CODE FINDS ")" AND TRIES TO FIND LIST ! 2610: C ! 2611: 70 IF (STMT(PSTMT).NE.62) GO TO 230 ! 2612: PSTMT = PSTMT + 1 ! 2613: IF (PSTMT.GE.NSTMT) GO TO 90 ! 2614: CALL LIST ! 2615: GO TO 110 ! 2616: 80 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20) ! 2617: PSTMT = PSTMT + 1 ! 2618: GO TO 70 ! 2619: 90 IF (OK) GO TO 110 ! 2620: CALL ERROR1(13H MISSING LIST, 13) ! 2621: 100 IF (PSTMT.LT.NSTMT) CALL ERROR1( ! 2622: * 34H EXTRANEOUS INFO AFTER END OF STMT, 34) ! 2623: 110 RETURN ! 2624: 120 CALL ERROR1(15H ILLEGAL SYNTAX, 15) ! 2625: GO TO 110 ! 2626: C ! 2627: C IDENTIFY END= IF THERE ! 2628: C ! 2629: 130 IF (ITYP.NE.23) GO TO IFORM, (160, 80) ! 2630: I1 = PSTMT + 1 ! 2631: DO 140 K=1,4 ! 2632: IF (STMT(I1).NE.EN(K)) GO TO IFORM, (160, 80) ! 2633: I1 = I1 + 1 ! 2634: 140 CONTINUE ! 2635: IF (.NOT.SW(1)) CALL ERROR1( ! 2636: * 37H WARNING - NON-PORTABLE EOF CONSTRUCT, 37) ! 2637: C ! 2638: C HAVE FOUND END=, TRY FOR LABEL ! 2639: C ! 2640: PSTMT = I1 ! 2641: IF(.NOT.TOKLAB(1,K2,K,.FALSE.)) ! 2642: 1CALL ERROR1(44H MISSING LABEL IN NON-PORTABLE EOF CONSTRUCT ,44) ! 2643: IF(SYSERR) GOTO 110 ! 2644: 150 PSTMT = K2 ! 2645: GO TO 70 ! 2646: C ! 2647: C SEARCH FOR FORM ! 2648: C ! 2649: 160 PSTMT = PSTMT + 1 ! 2650: IF (PSTMT.GE.NSTMT) GO TO 230 ! 2651: IF (TOKLAB(3,K2,K,.FALSE.)) GO TO 220 ! 2652: IF(SYSERR) GOTO 110 ! 2653: CALL NEXTOK(PSTMT, K2, K) ! 2654: IF (K.EQ.0) GO TO 180 ! 2655: 170 CALL ERROR1(13H ILLEGAL FORM, 13) ! 2656: GO TO 110 ! 2657: 180 K = LOOKUP(K2,.FALSE.) ! 2658: IF (SYSERR) GO TO 110 ! 2659: I1 = IGATT1(K,1) ! 2660: I2 = IGATT1(K,7) ! 2661: I3 = IGATT1(K,8) ! 2662: IF (I3.NE.0) GO TO 190 ! 2663: CALL SATT1(K, 8, 10) ! 2664: GO TO 200 ! 2665: 190 IF (I3.EQ.10) GO TO 200 ! 2666: CALL ERROR1(13H ILLEGAL FORM, 13) ! 2667: 200 IF (I1.NE.0) GO TO 210 ! 2668: I1 = 2 ! 2669: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2 ! 2670: CALL SATT1(K, 1, I1) ! 2671: 210 IF((MOD(I1,8).NE.2.AND.MOD(I1,8).NE.5).OR.I2.EQ.0) GOTO 170 ! 2672: C ! 2673: C HAVE SUCCESSFULLY FOUND A FORM ! 2674: C ! 2675: 220 IF (SYSERR) GO TO 110 ! 2676: PSTMT = K2 ! 2677: ASSIGN 80 TO IFORM ! 2678: IF (STMT(PSTMT).EQ.68) GO TO 130 ! 2679: GO TO 70 ! 2680: 230 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20) ! 2681: GO TO 110 ! 2682: C ! 2683: C LAST 4 I-O STMTS ! 2684: C ! 2685: 240 IF (ITYP.EQ.27 .OR. ITYP.EQ.22) CALL ERROR1( ! 2686: * 39H WARNING - USE OF NON-PORTABLE I/O STMT, 39) ! 2687: IF (ITYP.EQ.22) GO TO 100 ! 2688: IF (PSTMT.LT.NSTMT) GO TO 10 ! 2689: CALL ERROR1(13H MISSING UNIT, 13) ! 2690: GO TO 110 ! 2691: END ! 2692: C XXXXXLDOVAR.f ! 2693: SUBROUTINE LDOVAR ! 2694: COMMON /LISTDO/ LPT, LEN, LS(64) ! 2695: C ! 2696: C CHECKS PROPER NESTING OF DOS WITHIN LIST CONSTRUCT ! 2697: C ! 2698: IF (LPT.GE.61) GO TO 50 ! 2699: DO 40 KQ=LPT,60,4 ! 2700: KK = KQ + 4 ! 2701: DO 30 L=1,4 ! 2702: LL = L + KQ - 1 ! 2703: IF (LS(LL)) 10, 30, 10 ! 2704: 10 DO 20 K=KK,61,4 ! 2705: IF (LS(K).EQ.LS(LL)) CALL ERROR1( ! 2706: *57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS, 57) ! 2707: 20 CONTINUE ! 2708: 30 CONTINUE ! 2709: 40 CONTINUE ! 2710: 50 RETURN ! 2711: END ! 2712: C XXXXXNEXTOK.f ! 2713: SUBROUTINE NEXTOK(K1, K2, CODE) ! 2714: INTEGER STMT, CODE, PSTMT ! 2715: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 2716: C ! 2717: C NEXT TOKEN IN STMT(K1)-STMT(K2-1). CODES ARE: ! 2718: C DIGIT STRING(1) ! 2719: C HOLLERITH(2) ! 2720: C IDENTIFIER(0) ! 2721: C SPECIAL CHARACTER(3) ! 2722: C ! 2723: IF (STMT(K1).LT.0) GO TO 50 ! 2724: IF (STMT(K1).GT.9) GO TO 20 ! 2725: C ! 2726: C DIGIT STRING ! 2727: C ! 2728: CODE = 1 ! 2729: K2 = K1 + 1 ! 2730: 10 IF (K2.EQ.NSTMT) GO TO 60 ! 2731: IF ((STMT(K2).GT.9) .OR. (STMT(K2).LT.0)) GO TO 60 ! 2732: K2 = K2 + 1 ! 2733: GO TO 10 ! 2734: 20 IF (STMT(K1).GT.55) GO TO 40 ! 2735: C ! 2736: C IDENTIFIER ! 2737: C ! 2738: CODE = 0 ! 2739: K4 = K1 + 1 ! 2740: K2 = K4 ! 2741: DO 30 I=K4,NSTMT ! 2742: IF (STMT(I).GT.55 .OR. STMT(I).LT.0) GO TO 60 ! 2743: K2 = K2 + 1 ! 2744: 30 CONTINUE ! 2745: C ! 2746: C ! 2747: C SPECIAL CHARACTER ! 2748: C ! 2749: 40 K2 = K1 + 1 ! 2750: CODE = 3 ! 2751: IF (STMT(K1).NE.66) GO TO 60 ! 2752: IF (STMT(K2).EQ.66) K2 = K2 + 1 ! 2753: GO TO 60 ! 2754: C ! 2755: C HOLLERITH ! 2756: C ! 2757: 50 CODE = 2 ! 2758: K2 = K1 + 1 ! 2759: 60 RETURN ! 2760: END ! 2761: C XXXXXOUTSYM.f ! 2762: SUBROUTINE OUTSYM ! 2763: INTEGER HASH, STACK, BL, DSA, OUTUT, SYMHD, BNEXT, SYMLEN, ATT(8) ! 2764: INTEGER CODE(11), CC(30), C(4), Q(70), SYM, PDSA ! 2765: INTEGER OUTUT2, OUTUT3, OUTUT4 ! 2766: LOGICAL OK ! 2767: LOGICAL OPT, P1ERR, COMM ! 2768: COMMON /CHASH/ LHASH, HASH(401) ! 2769: COMMON /OPTNS/ OPT(5), P1ERR ! 2770: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 2771: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, ! 2772: * OUTUT4 ! 2773: COMMON /TABL/ NEXT, LAB, SYM, BNEXT ! 2774: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 2775: COMMON /CEXPRS/ LSTACK, STACK(620) ! 2776: COMMON /TRANS/ Q ! 2777: DATA BL /1H / ! 2778: DATA CODE(1) /1HD/, CODE(2) /1HR/, CODE(3) /1HI/, CODE(4) /1HC/, ! 2779: * CODE(5) /1HL/, CODE(11) /1HE/, CODE(7) /1HA/, CODE(8) /1HS/, ! 2780: * CODE(9) /1HF/, CODE(10) /1HN/, CODE(6) /1HH/, C(1) /4/, C(2) ! 2781: * /11/, C(3) /7/, C(4) /8/ ! 2782: DATA CC(2), CC(16), CC(20), CC(22), CC(26), CC(28) /6*1H /, ! 2783: * CC(3), CC(5), CC(9), CC(11) /1HF,1HS,1HF,1HF/, CC(1), CC(4) / ! 2784: * 1HU,1HA/, CC(6), CC(8), CC(10), CC(12), CC(14) /1HF,4*1HN/, ! 2785: * CC(7), CC(13) /2*1HS/, CC(15) /1HC/, CC(17) /1HG/, CC(18) / ! 2786: * 1HT/, CC(19) /1HL/, CC(21) /1HV/, CC(25) /1HM/, CC(23) /1HB/, ! 2787: * CC(24) /1HD/, CC(27) /1HE/ ! 2788: DATA CC(29) /1HI/, CC(30) /1HF/ ! 2789: C ! 2790: C ROUTINE PRINTS OUT SYMBOL TABLE FOR A PROGRAM UNIT ! 2791: C ! 2792: IF (NAME.EQ.0 .OR. .NOT.OPT(1)) RETURN ! 2793: II = IGATT1(NAME,8) ! 2794: CALL S5UNPK(DSA(NAME+4), STACK(1), 6) ! 2795: WRITE (OUTUT,99999) (STACK(I),I=1,6) ! 2796: 99999 FORMAT (14H1PROGRAM UNIT , 5X, 6A1) ! 2797: IF (II.EQ.11 .OR. II.EQ.12 .OR. DSA(NAME+2).EQ.0) GO TO 60 ! 2798: C ! 2799: C PRINT FCN/SUBROUTINE ARGS ! 2800: C ! 2801: KK = DSA(NAME+2) ! 2802: I = 0 ! 2803: 10 L = 20 ! 2804: CALL RDLIST(KK, 9, M, 0) ! 2805: IF (M) 20, 60, 20 ! 2806: 20 DO 30 I1=1,M ! 2807: J = STACK(I1) + 4 ! 2808: CALL S5UNPK(DSA(J), STACK(L), 6) ! 2809: L = L + 7 ! 2810: STACK(L-1) = BL ! 2811: 30 CONTINUE ! 2812: MM = M*7 + 19 ! 2813: IF (I) 40, 40, 50 ! 2814: 40 WRITE (OUTUT,99998) (STACK(L),L=20,MM) ! 2815: 99998 FORMAT (//10H ARGUMENTS, 9X, 63A1) ! 2816: I = 1 ! 2817: GO TO 10 ! 2818: 50 WRITE (OUTUT,99997) (STACK(L),L=20,MM) ! 2819: 99997 FORMAT (19X, 63A1) ! 2820: GO TO 10 ! 2821: C ! 2822: C PRINT SYMBOLS FOR PROGRAM UNIT ! 2823: C ! 2824: 60 CALL SORT(SYM, LBR) ! 2825: COMM = .FALSE. ! 2826: WRITE (OUTUT,99996) ! 2827: 99996 FORMAT (//1X, 4HNAME, 5X, 4HTYPE, 2X, 3HUSE, 1X, 10HATTRIBUTES, ! 2828: * 1X, 10HREFERENCES//) ! 2829: DO 230 JBR=1,LBR ! 2830: SYMHD = HASH(JBR) ! 2831: DO 70 I=20,35 ! 2832: STACK(I) = BL ! 2833: 70 CONTINUE ! 2834: DO 80 I=1,8 ! 2835: ATT(I) = IGATT1(SYMHD,I) ! 2836: 80 CONTINUE ! 2837: C SKIPS OVER SYMBOL TABLE ENTRY FOR MAIN, BLOCK DATA, ! 2838: C AND CURRENT SUBROUTINE NAME ! 2839: IF (SYMHD.EQ.NAME .AND. ATT(8).NE.4) GO TO 230 ! 2840: IF (ATT(8).NE.7) GO TO 90 ! 2841: COMM = .TRUE. ! 2842: GO TO 230 ! 2843: 90 CALL S5UNPK(DSA(SYMHD+4), STACK(20), 6) ! 2844: I1 = ATT(8) ! 2845: L = 2*(I1+1) - 1 ! 2846: STACK(28) = CC(L) ! 2847: STACK(29) = CC(L+1) ! 2848: C LEAVE BLANK IRRELEVANT TYPE INFO FOR EXT SUBR, COMMON, EXT ENTS ! 2849: IF(ATT(8).EQ.6 .OR. ATT(8).EQ.7 .OR. ATT(8).EQ.13) ! 2850: 1 GOTO 100 ! 2851: I1 = MOD(ATT(1),8) ! 2852: IF (ATT(1).GE.8) STACK(26)=CODE(11) ! 2853: STACK(27) = CODE(I1 + 1) ! 2854: 100 DO 110 I=1,4 ! 2855: L = I + 29 ! 2856: J = C(I) ! 2857: IF (ATT(I+1).EQ.1) STACK(L) = CODE(J) ! 2858: 110 CONTINUE ! 2859: IF (ATT(8).EQ.7) STACK(30) = BL ! 2860: IF (ATT(8).NE.10 .AND. ATT(8).NE.8) GO TO 140 ! 2861: IF (ATT(7)) 120, 130, 120 ! 2862: 120 STACK(34) = CODE(7) ! 2863: J = ATT(7) + 1 ! 2864: STACK(35) = Q(J) ! 2865: GO TO 140 ! 2866: 130 STACK(34) = CODE(8) ! 2867: C ! 2868: C XREF LIST ! 2869: C ! 2870: 140 IF (OPT(2)) GO TO 160 ! 2871: 150 WRITE (OUTUT,99995) (STACK(L),L=20,35) ! 2872: GO TO 230 ! 2873: 160 OK = .FALSE. ! 2874: N = DSA(SYMHD+1) ! 2875: IF (N.LE.0) GO TO 150 ! 2876: N = DSA( N+1 ) ! 2877: 170 CALL RFLIST( N, M, J, DSA(SYMHD+1) ) ! 2878: C ! 2879: C FIRST TIME PRINT WHOLE LINE ! 2880: C ! 2881: K = M ! 2882: IF (M.GE.57) K = 57 ! 2883: WRITE (OUTUT,99995) (STACK(L),L=20,35), (STACK(L),L=50,K) ! 2884: 99995 FORMAT (1X, 6A1, 5X, 2A1, 3X, 2A1, 3X, 6A1, 2X, 8(I5, 1X)) ! 2885: IF (M-57) 220, 220, 180 ! 2886: 180 L = (M-57)/8 ! 2887: LL = 58 ! 2888: IF (L) 220, 210, 190 ! 2889: 190 DO 200 K=1,L ! 2890: LK = LL + 7 ! 2891: WRITE (OUTUT,99994) (STACK(I),I=LL,LK) ! 2892: LL = LK + 1 ! 2893: 200 CONTINUE ! 2894: IF (LK.EQ.M) GO TO 220 ! 2895: 210 WRITE (OUTUT,99994) (STACK(I),I=LL,M) ! 2896: 99994 FORMAT (30X, 8(I5, 1X)) ! 2897: C ! 2898: C MAY HAVE TO CALL REFLIST AGAIN ! 2899: C ! 2900: 220 IF (J) 230, 230, 170 ! 2901: 230 CONTINUE ! 2902: C ! 2903: C PRINT LABELS ! 2904: C ! 2905: IF (LAB.EQ.0) GO TO 320 ! 2906: CALL SORT(LAB, LBR) ! 2907: DO 310 JBR=1,LBR ! 2908: LABHD = HASH(JBR) ! 2909: CALL S5UNPK(DSA(LABHD+4), STACK(20), 6) ! 2910: OK = .FALSE. ! 2911: IF (OPT(2)) GO TO 240 ! 2912: WRITE (OUTUT,99993) (STACK(L),L=20,25) ! 2913: GO TO 310 ! 2914: 240 II = DSA(LABHD+1) ! 2915: II = DSA(II+1) ! 2916: 250 CALL RFLIST(II, M, J, DSA(LABHD+1) ) ! 2917: K = M ! 2918: IF (M.GE.57) K = 57 ! 2919: WRITE (OUTUT,99993) (STACK(I),I=20,25), (STACK(I),I=50,K) ! 2920: 99993 FORMAT (1X, 6A1, 23X, 8(I5, 1X)) ! 2921: IF (M-57) 300, 300, 260 ! 2922: 260 L = (M-57)/8 ! 2923: LL = 58 ! 2924: IF (L) 300, 290, 270 ! 2925: 270 DO 280 K=1,L ! 2926: LK = LL + 7 ! 2927: WRITE (OUTUT,99992) (STACK(I),I=LL,LK) ! 2928: LL = LK + 1 ! 2929: 280 CONTINUE ! 2930: IF (LK.EQ.M) GO TO 300 ! 2931: 290 WRITE (OUTUT,99992) (STACK(I),I=LL,M) ! 2932: 99992 FORMAT (30X, 8(I5, 1X)) ! 2933: 300 IF (J) 310, 310, 250 ! 2934: 310 CONTINUE ! 2935: 320 IF (.NOT.COMM) GO TO 390 ! 2936: CALL SORT(SYM, LBR) ! 2937: WRITE (OUTUT,99991) ! 2938: 99991 FORMAT (//14H COMMON BLOCKS//) ! 2939: DO 380 JBR=1,LBR ! 2940: SYMHD = HASH(JBR) ! 2941: I = IGATT1(SYMHD,8) ! 2942: IF (I.NE.7) GO TO 380 ! 2943: CALL S5UNPK(DSA(SYMHD+4), STACK(100), 6) ! 2944: N = 0 ! 2945: II = DSA(SYMHD+2) ! 2946: 330 L = 11 ! 2947: CALL RDLIST(II, 10, M, 0) ! 2948: IF (M) 340, 380, 340 ! 2949: 340 DO 350 I=1,M ! 2950: J = STACK(I) + 4 ! 2951: CALL S5UNPK(DSA(J), STACK(L), 6) ! 2952: L = L + 7 ! 2953: STACK(L-1) = BL ! 2954: 350 CONTINUE ! 2955: L = L - 1 ! 2956: IF (N) 360, 360, 370 ! 2957: 360 WRITE (OUTUT,99990) (STACK(I),I=100,105), (STACK(I),I=11,L) ! 2958: 99990 FORMAT (1X, 6A1, 3X, 70A1) ! 2959: N = 1 ! 2960: GO TO 330 ! 2961: 370 WRITE (OUTUT,99989) (STACK(K),K=11,L) ! 2962: 99989 FORMAT (10X, 70A1) ! 2963: GO TO 330 ! 2964: 380 CONTINUE ! 2965: 390 RETURN ! 2966: END ! 2967: C XXXXXPOP.f ! 2968: SUBROUTINE POP ! 2969: LOGICAL ERR, SYSERR, ABORT ! 2970: INTEGER PB, PT, STACK, OP(12), EX(4,4), AO(4,4), RO(3,3) ! 2971: COMMON /CEXPRS/ LSTACK, STACK(620) ! 2972: COMMON /EXPRS/ PT, PB, AO, RO, EX ! 2973: COMMON /DETECT/ ERR, SYSERR, ABORT ! 2974: DATA OP(1), OP(3), OP(7), OP(9), OP(10), OP(11) /6*2/, OP(4) /1/, ! 2975: * OP(5) /0/, OP(6), OP(8), OP(2) /3*-1/, OP(12) /1/ ! 2976: C ! 2977: C JOB OF SUBROUTINE IS TO POP THE STACK; DOES ALL POPS ! 2978: C EXCEPT REMOVAL OF "FCN(" CONSTRUCTION ! 2979: C OP(I) CONTAINS NUM OF ARGS OF OPERATER I PB CHECKED BEFORE ! 2980: C CALLING POP; POP CHECKS PT; ERROR RETURNS FROM THIS ROUTINE STOP ! 2981: C EXPRESSION PROCESSING (I.E. ERR=.TRUE.) ! 2982: C ! 2983: ERR = .FALSE. ! 2984: I = STACK(PB+1) ! 2985: K = OP(I-10) ! 2986: IF (K) 190, 180, 10 ! 2987: 10 L = PT - 1 ! 2988: KQ = K ! 2989: 20 IF (K) 80, 80, 30 ! 2990: 30 IF (STACK(L)/8.EQ.1) GO TO 220 ! 2991: IF (STACK(L).GE.8 .OR. STACK(L-1).EQ.0) GO TO 40 ! 2992: J = IGATT1(STACK(L-1),8) ! 2993: IF (J.EQ.0) CALL SATT1(STACK(L-1), 8, 10) ! 2994: 40 GO TO (60, 50), K ! 2995: 50 K1 = MOD(STACK(L),8) + 1 ! 2996: GO TO 70 ! 2997: 60 K2 = MOD(STACK(L),8) + 1 ! 2998: 70 L = L - 2 ! 2999: K = K - 1 ! 3000: GO TO 20 ! 3001: C ! 3002: C 11 +,- 12 ) 13 ** 14 .NOT. 15 ( 16 FCN( 17 *,/ 18 , ! 3003: C 19 .AND. 20 .OR. 21 .EQ. 22 UNARY +,- ! 3004: C ! 3005: 80 L = I - 10 ! 3006: GO TO (90, 190, 120, 150, 190, 190, 90, 190, 130, 130, 100, 140), ! 3007: * L ! 3008: 90 IF (K1.GT.4 .OR. K2.GT.4) GO TO 210 ! 3009: KK = AO(K1,K2) ! 3010: GO TO 160 ! 3011: 100 IF (K1.GT.3 .OR. K2.GT.3) GO TO 110 ! 3012: KK = RO(K1,K2) ! 3013: GO TO 160 ! 3014: 110 IF ((K1.NE.6 .OR. K2.NE.6) .AND. (K1.NE.6 .OR. K2.NE.3) .AND. ! 3015: * (K1.NE.3 .OR. K2.NE.6) ) GO TO 210 ! 3016: KK = 4 ! 3017: GO TO 160 ! 3018: 120 IF (K1.GT.4 .OR. K2.GT.4) GO TO 210 ! 3019: KK = EX(K2,K1) ! 3020: GO TO 160 ! 3021: 130 KK = 4 ! 3022: IF (K1.NE.5 .OR. K2.NE.5) GO TO 210 ! 3023: GO TO 160 ! 3024: 140 KK = K2 - 1 ! 3025: IF (KK.LT.0 .OR. KK.GT.3) GO TO 210 ! 3026: GO TO 160 ! 3027: 150 IF (K2.NE.5) GO TO 210 ! 3028: KK = 4 ! 3029: 160 IF (-1.EQ.KK) GO TO 210 ! 3030: C ! 3031: C STORE ON STACK 0 TO SHOW EXPRESSION RESULT(NO DSA INDEX) ! 3032: C ALSO STORE TYPE OF RESULTING OPERAND ! 3033: C ! 3034: PT = PT - 2*KQ ! 3035: STACK(PT) = 0 ! 3036: STACK(PT+1) = KK ! 3037: PT = PT + 2 ! 3038: PB = PB + 1 ! 3039: 170 RETURN ! 3040: C ! 3041: C POPPING "(" ! 3042: C ! 3043: 180 PB = PB + 1 ! 3044: GO TO 170 ! 3045: 190 CALL ERROR1(25H ILLEGAL ELEMENT ON STACK, 25) ! 3046: 200 ERR = .TRUE. ! 3047: RETURN ! 3048: 210 CALL ERROR1(34H ILLEGAL COMBINATION OF DATA TYPES, 34) ! 3049: GO TO 200 ! 3050: 220 CALL ERROR1(21H ILLEGAL USE OF ARRAY, 21) ! 3051: GO TO 200 ! 3052: END ! 3053: C XXXXXRDLIST.f ! 3054: SUBROUTINE RDLIST(HEAD, L, N, M) ! 3055: C ! 3056: C HEAD IS THE HEAD OF A LINEAR LINKED LIST IN DSA ! 3057: C L IS MAX NUMBER OF ITEMS DESIRED ! 3058: C N IS NUMBER OF ITEMS RETURNED ! 3059: C M IS END OF LIST MARKER ! 3060: C ! 3061: INTEGER HEAD, STACK, DSA, PDSA ! 3062: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 3063: COMMON /CEXPRS/ LSTACK, STACK(620) ! 3064: N = 0 ! 3065: 10 IF (HEAD.EQ.M .OR. N.GE.L) GO TO 20 ! 3066: N = N + 1 ! 3067: STACK(N) = DSA(HEAD) ! 3068: HEAD = DSA(HEAD+1) ! 3069: GO TO 10 ! 3070: 20 RETURN ! 3071: END ! 3072: C XXXXXRFLIST.f ! 3073: SUBROUTINE RFLIST( I1, I2, I4, I3 ) ! 3074: C ! 3075: C I1 IS POINTER TO FIRST ELEMENT ON XREF LIST IN DSA ! 3076: C I2 IS COUNT OF HOW MANY REFS ARE RETURNED IN STACK ! 3077: C I4 IS 1 IF RFLIST MUST BE CALLED AGAIN; ELSE IS 0 ! 3078: C I3 IS LAST OF LIST ELEMENTS ! 3079: C ! 3080: INTEGER DSA, PDSA, STACK ! 3081: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 3082: COMMON /CEXPRS/ LSTACK, STACK(620) ! 3083: I4 = 0 ! 3084: I2 = 49 ! 3085: 10 IF ( I2+1.GE.LSTACK ) GOTO 30 ! 3086: I2 = I2 + 1 ! 3087: STACK(I2) = DSA(I1) ! 3088: IF( I1.EQ.I3 ) GOTO 20 ! 3089: I1 = DSA(I1+1) ! 3090: GOTO 10 ! 3091: 20 RETURN ! 3092: 30 I4 = 1 ! 3093: GO TO 20 ! 3094: END ! 3095: C XXXXXSEPAR.f ! 3096: SUBROUTINE SEPAR(ICHAR) ! 3097: C ! 3098: C FINDS SEPARATER CONSTRUCT IN FORMAT STMTS ! 3099: C SEPARATER IS A COMBINATION OF "/" AND "," ! 3100: C ",," IS ALWAYS ILLEGAL IN A SEPARATER ! 3101: C MIXING OF "/" AND "," IS WARNED AGAINST ! 3102: C ! 3103: C ICHAR CONTAINS LENGTH OF SEPARATOR FOUND ! 3104: INTEGER PSTMT, STMT ! 3105: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 3106: ICHAR = PSTMT ! 3107: ICOM = 0 ! 3108: C ! 3109: C " , " ! 3110: C ! 3111: 10 IF (STMT(PSTMT).NE.68) GO TO 20 ! 3112: ICOM = ICOM + 1 ! 3113: C ! 3114: C CHECK FOR ",," ! 3115: C ! 3116: PSTMT = PSTMT + 1 ! 3117: IF (STMT(PSTMT).EQ.68) GO TO 30 ! 3118: 20 IF (STMT(PSTMT).NE.67) GO TO 50 ! 3119: PSTMT = PSTMT + 1 ! 3120: GO TO 10 ! 3121: 30 CALL ERROR1(19H ILLEGAL ADJACENT ,, 19) ! 3122: C ! 3123: C FLUSH TO NEXT NON-SEPARATER ! 3124: C ! 3125: 40 PSTMT = PSTMT + 1 ! 3126: IF (STMT(PSTMT).EQ.67 .OR. STMT(PSTMT).EQ.68) GO TO 40 ! 3127: 50 ICHAR = PSTMT - ICHAR ! 3128: IF (ICOM.GT.0 .AND. ICHAR.GT.1) CALL ERROR1( ! 3129: * 36H ILLEGAL MIXING OF / AND , IN FORMAT, 36) ! 3130: RETURN ! 3131: END ! 3132: C XXXXXSETNAM.f ! 3133: SUBROUTINE SETNAM(KK) ! 3134: LOGICAL ERR, SYSERR, ABORT ! 3135: INTEGER STMT, PSTMT, S(5) ! 3136: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 3137: COMMON /DETECT/ ERR, SYSERR, ABORT ! 3138: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 3139: DATA S(1) /66/, S(2) /42/, S(3) /30/, S(4) /38/, S(5) /43/ ! 3140: C ! 3141: C KK=11 FOR BLOCK DATA PGM; KK=12 FOR MAIN PGM ! 3142: C NAME POINTS TO SYMBOL TABLE ENTRY FOR NEW PGM ! 3143: C ! 3144: IF (KK.EQ.11) GO TO 30 ! 3145: PSTMT = 1 ! 3146: DO 10 I=1,5 ! 3147: STMT(I) = S(I) ! 3148: 10 CONTINUE ! 3149: NAME = LOOKUP(6,.FALSE.) ! 3150: IF (SYSERR) RETURN ! 3151: CALL SATT1(NAME, 8, 12) ! 3152: 20 RETURN ! 3153: 30 PSTMT = 5 ! 3154: STMT(PSTMT) = S(1) ! 3155: NAME = LOOKUP(11,.FALSE.) ! 3156: IF (SYSERR) RETURN ! 3157: CALL SATT1(NAME, 8, 11) ! 3158: GO TO 20 ! 3159: END ! 3160: C XXXXXSORT.f ! 3161: SUBROUTINE SORT(IPT, L) ! 3162: EXTERNAL EXCH ! 3163: INTEGER HASH, PDSA, DSA ! 3164: COMMON /CHASH/ LHASH, HASH(401) ! 3165: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 3166: C ! 3167: C PUT ALL SUMBOL INDICES IN HASH TABLE TO SORT THEM ! 3168: C ! 3169: L = 0 ! 3170: I = IPT ! 3171: 10 IF (I.EQ.0) GO TO 20 ! 3172: L = L + 1 ! 3173: HASH(L) = I ! 3174: I = DSA(I+3) ! 3175: GO TO 10 ! 3176: C ! 3177: C CALL SORT ROUTINE ! 3178: C UPON RETURN HASH CONTAINS INDICES OF ALL SYMBOLS OR LABELS IN ! 3179: C DSA IN LEXICOGRAPHIC ORDER ! 3180: C ! 3181: 20 CALL SSORT(EXCH, DSA, LDSA, HASH, L, 4) ! 3182: RETURN ! 3183: END ! 3184: C XXXXXSUBS.f ! 3185: SUBROUTINE SUBS(K2, NO) ! 3186: INTEGER STMT, PSTMT ! 3187: LOGICAL ERR, SYSERR, ABORT, TOKPNO ! 3188: COMMON /DETECT/ ERR, SYSERR, ABORT ! 3189: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 3190: C ! 3191: C STMT(PSTMT)-STMT(K2-1) CONTAIN SUBSCRIPT CONSTRUCT ! 3192: C NO IS NUMBER OF SUBSCRIPTS EXPECTED ! 3193: C ROUTINE CHECKS SYNTAX AND NUMBER OF SUBSCRIPTS ! 3194: C IF FLUSH OF CONSTRUCT IS NECESSARY, AND NSTMT IS REACHED ! 3195: C ERR=.TRUE. ! 3196: C ! 3197: ICNT = 0 ! 3198: 10 CALL NEXTOK(PSTMT, K2, K) ! 3199: IF (K.EQ.0) GO TO 70 ! 3200: IF (TOKPNO(PSTMT,K2,LL)) GO TO 60 ! 3201: 20 CALL ERROR1(28H ILLEGAL SYNTAX OF SUBSCRIPT, 28) ! 3202: C ! 3203: C FLUSH TO END OF SUBSCRIPT CONSTRUCTION ! 3204: C ! 3205: 30 IF (STMT(K2).EQ.62) GO TO 40 ! 3206: K2 = K2 + 1 ! 3207: IF (K2.LT.NSTMT) GO TO 30 ! 3208: ERR = .TRUE. ! 3209: GO TO 50 ! 3210: 40 K2 = K2 + 1 ! 3211: 50 RETURN ! 3212: 60 IF (STMT(K2).NE.66) GO TO 130 ! 3213: PSTMT = K2 + 1 ! 3214: IF (PSTMT.GE.NSTMT) GO TO 20 ! 3215: CALL NEXTOK(PSTMT, K2, K) ! 3216: IF (K.NE.0) GO TO 20 ! 3217: C ! 3218: C ACESS SYMBOL TABLE ENTRY FOR VARIABLE TO DETERMINE ! 3219: C USAGE AND TYPE ! 3220: C ! 3221: 70 KQ = LOOKUP(K2,.FALSE.) ! 3222: IF (SYSERR) GO TO 30 ! 3223: I1 = IGATT1(KQ,1) ! 3224: I1 = MOD(I1,8) ! 3225: I2 = IGATT1(KQ,7) ! 3226: I3 = IGATT1(KQ,8) ! 3227: IF (I3.EQ.0) GO TO 90 ! 3228: IF (I3.EQ.10) GO TO 100 ! 3229: 80 CALL ERROR1(43H ILLEGAL VARIABLE IN SUBSCRIPT CONSTRUCTION, 43) ! 3230: GO TO 120 ! 3231: 90 CALL SATT1(KQ, 8, 10) ! 3232: C ! 3233: C IMPLICITLY TYPE VARIABLES FIRST ENCOUNTERED IN SUBSCRIPT ! 3234: C CONSTRUCT ! 3235: C ! 3236: 100 IF (I1.GT.0) GO TO 110 ! 3237: I1 = 1 ! 3238: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2 ! 3239: CALL SATT1(KQ, 1, I1) ! 3240: 110 IF (I2.NE.0 .OR. I1.NE.2) GO TO 80 ! 3241: 120 IF (STMT(K2).NE.60 .AND. STMT(K2).NE.61) GO TO 130 ! 3242: CALL NEXTOK(K2+1, K3, K) ! 3243: IF (K.NE.1) GO TO 20 ! 3244: K2 = K3 ! 3245: 130 ICNT = ICNT + 1 ! 3246: IF (STMT(K2).EQ.68) GO TO 140 ! 3247: IF (STMT(K2).NE.62) GO TO 20 ! 3248: IF (NO.NE.ICNT) CALL ERROR1(34H INCOMPATIBLE NUMBER OF SUBSCRIPTS, ! 3249: * 34) ! 3250: IF (ICNT.GT.3) CALL ERROR1(20H TOO MANY SUBSCRIPTS, 20) ! 3251: GO TO 40 ! 3252: 140 PSTMT = K2 + 1 ! 3253: IF (PSTMT.GE.NSTMT) GO TO 20 ! 3254: GO TO 10 ! 3255: END ! 3256: C XXXXXSUBFCN.f ! 3257: SUBROUTINE SUBFCN(TYPE) ! 3258: C ! 3259: C TYPE IS EXPLICIT TYPE OF FUNCTION, ELSE IS -1 ! 3260: C ALL FCNS GIVEN EXPLICIT TYPE SINCE FCN NAME CANNOT APPEAR IN ! 3261: C NONEXECUTABLE STMT WITHIN FCN SUBPRGM EXCEPT HEAD STMT ! 3262: C ROUTINES DEFINES SUBROUTINE AND FUNCTION NAMES AND CREATES ! 3263: C LINKED LISTS OF POINTERS TO THEIR ARGUMENTS IN DSA. ! 3264: C SETS NAME TO POINT TO CURRENT FUNCN OR SUBRTNE. IN CASE ! 3265: C OF BAD SYNTAX IN NAME CONSTRUCT OR FCN WITHOUT PARAMS., ! 3266: C PROGRAM UNIT BECOMES MAIN PGM BY DEFAULT ! 3267: C ! 3268: INTEGER STMT, PSTMT, DSA, SYMHD, TYPE, BNEXT, S(5), PDSA ! 3269: LOGICAL ERR, SYSERR, ABORT ! 3270: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 3271: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 3272: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 3273: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 3274: COMMON /DETECT/ ERR, SYSERR, ABORT ! 3275: DATA S(1) /66/, S(2) /42/, S(3) /30/, S(4) /38/, S(5) /43/ ! 3276: KCELL = 0 ! 3277: CALL NEXTOK(PSTMT, K2, I1) ! 3278: IF (I1.NE.0) GO TO 120 ! 3279: C ! 3280: C SET FCN OR SUBR USE IN SYMBOL TABLE. TYPE FCN AND RECORD EXPLICIT ! 3281: C OR IMPLICIT TYPE ! 3282: C ! 3283: K = LOOKUP(K2,.FALSE.) ! 3284: IF (SYSERR) GO TO 90 ! 3285: NAME = K ! 3286: L = ITYP - 8 ! 3287: GO TO (10, 20), L ! 3288: 10 CALL SATT1(K, 8, 3) ! 3289: GO TO 40 ! 3290: 20 CALL SATT1(K, 8, 4) ! 3291: IF (TYPE.LT.0) GO TO 30 ! 3292: CALL SATT1(K, 1, TYPE+8) ! 3293: GO TO 40 ! 3294: 30 L = 1 ! 3295: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) L = 2 ! 3296: CALL SATT1(K, 1, L) ! 3297: 40 IF (STMT(K2).NE.65) GO TO 140 ! 3298: 50 PSTMT = K2 + 1 ! 3299: IF (PSTMT.GE.NSTMT) GO TO 120 ! 3300: CALL NEXTOK(PSTMT, K2, L) ! 3301: IF (L.NE.0) GO TO 80 ! 3302: C ! 3303: C ENTER PARAMETER IN SYMBOL TABLE; TYPE IMPLICITLY; ADD ONTO PARAM ! 3304: C LIST HANGING OFF SUBR/FCN NAME; SET DUMMYARG BIT ON; DO NOT SET ! 3305: C USAGE ! 3306: C ! 3307: N = LOOKUP(K2,.FALSE.) ! 3308: IF (SYSERR) GO TO 90 ! 3309: I2 = IGATT1(N,4) ! 3310: I1 = IGATT1(N,8) ! 3311: IF (I1.NE.0 .OR. I2.NE.0) GO TO 80 ! 3312: L = 1 ! 3313: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) L = 2 ! 3314: CALL SATT1(N, 1, L) ! 3315: L = IGATT1(N,4) ! 3316: IF (L.EQ.1) GO TO 80 ! 3317: CALL SATT1(N, 4, 1) ! 3318: IF (NEXT+2.GE.BNEXT) GO TO 150 ! 3319: IF (KCELL.EQ.0) GO TO 60 ! 3320: DSA(KCELL+1) = NEXT ! 3321: GO TO 70 ! 3322: C ! 3323: C START PARAM LIST ! 3324: C ! 3325: 60 DSA(K+2) = NEXT ! 3326: 70 KCELL = NEXT ! 3327: DSA(NEXT) = N ! 3328: DSA(NEXT+1) = 0 ! 3329: NEXT = NEXT + 2 ! 3330: C ! 3331: C SEARCH FOR ")" OR "," ! 3332: C ! 3333: IF (STMT(K2).EQ.62) GO TO 100 ! 3334: IF (STMT(K2).EQ.68) GO TO 50 ! 3335: 80 CALL ERROR1(33H ILLEGAL SYNTAX IN PARAMETER LIST, 33) ! 3336: 90 RETURN ! 3337: 100 K2 = K2 + 1 ! 3338: 110 IF (K2.EQ.NSTMT) GO TO 90 ! 3339: CALL ERROR1(39H ILLEGAL CHARACTERS AFTER SUBR/FCN HEAD, 39) ! 3340: GO TO 90 ! 3341: 120 CALL ERROR1(15H ILLEGAL SYNTAX, 15) ! 3342: PSTMT = 6 ! 3343: DO 130 I1=1,5 ! 3344: STMT(I1+5) = S(I1) ! 3345: 130 CONTINUE ! 3346: NAME = LOOKUP(11,.FALSE.) ! 3347: IF (SYSERR) GO TO 90 ! 3348: CALL SATT1(NAME, 8, 11) ! 3349: GO TO 90 ! 3350: 140 IF (ITYP.EQ.9) GO TO 110 ! 3351: CALL ERROR1(20H NO PARAMS SPECIFIED, 20) ! 3352: GO TO 120 ! 3353: 150 SYSERR = .TRUE. ! 3354: CALL ERROR1(33H IN SUBFCN, TABLE OVERFLOW OF DSA,33) ! 3355: GO TO 90 ! 3356: END ! 3357: C XXXXXTOKCOM.f ! 3358: LOGICAL FUNCTION TOKCOM(K1, K2) ! 3359: C ! 3360: C TOKCOM RETURNS TRUE IS FINDS CONST IN STMT(K1)-STMT(K2-1) ! 3361: C ( (OPTIONAL SIGN) REAL CONST, (OPTIONAL SIGN) REAL CONST ) IS ! 3362: C COMPLEX CONSTRUCT; TOKCOM RESETS K2 ! 3363: C ! 3364: LOGICAL TOKRL ! 3365: INTEGER STMT, PSTMT ! 3366: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 3367: TOKCOM = .FALSE. ! 3368: IF (STMT(K1).NE.65) GO TO 10 ! 3369: K3 = K1 + 1 ! 3370: IF (STMT(K3).EQ.60 .OR. STMT(K3).EQ.61) K3 = K3 + 1 ! 3371: IF (TOKRL(K3,K2,K)) IF (K-1) 10, 20, 10 ! 3372: 10 RETURN ! 3373: 20 IF (STMT(K2).NE.68) GO TO 10 ! 3374: K3 = K2 + 1 ! 3375: IF (STMT(K3).EQ.60 .OR. STMT(K3).EQ.61) K3 = K3 + 1 ! 3376: IF (TOKRL(K3,K2,K)) IF (K-1) 10, 30, 10 ! 3377: GO TO 10 ! 3378: 30 IF (STMT(K2).NE.62) GO TO 10 ! 3379: K2 = K2 + 1 ! 3380: TOKCOM = .TRUE. ! 3381: GO TO 10 ! 3382: END ! 3383: C XXXXXTOKLAB.f ! 3384: LOGICAL FUNCTION TOKLAB(K1, K2, KK, DEF) ! 3385: INTEGER STMT, PSTMT, SYMHD, DSA, PDSA, BNEXT, DOPT, DOLIST ! 3386: LOGICAL DEF, NON0, SYSERR, ABORT, ERR ! 3387: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 3388: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 3389: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 3390: COMMON /DETECT/ ERR, SYSERR, ABORT ! 3391: COMMON /DOS/ DOPT, LDO, DOLIST(192) ! 3392: COMMON /FACTS/ NAME, NOST, ITYPE, IASF ! 3393: C ! 3394: C LOOKS FOR DEFNS OF LABEL IF DEF = .TRUE., ELSE LOOKS FOR ! 3395: C REFS. IF IT FINDS A LABEL TOKLAB=.TRUE. ! 3396: C IN REFERENCE LABEL IS IN STMT(PSTMT)-STMT(K2-1) ! 3397: C IN DEFN LABEL IS IN STMT(1)-STMT(K2-1) ! 3398: C KK IS SYMBOL TABLE INDEX OF LABEL ! 3399: C K1 IS TYPE OF LABEL EXPECTED OR DEFINED--1-EXECUTABLE ! 3400: C 2-NONEXECUTABLE, 3-FORMAT ! 3401: C IN REF, ROUTINE SETS USAGE OF SYMBOL AND CHECKS FOR ! 3402: C COMPATIBLE REFERENCES(I.E. GOTO 5 AND WRITE(6,5) ARE INCOMPAT.) ! 3403: C IN DEF, ROUTINE SETS USAGE OF SYMBOL, CHECKS FOR DUPLICATE ! 3404: C DEFNS, CHECKS FOR COMPATIBLITY BETWEEN DEFN AND PREVIOUS ! 3405: C REFS, CREATES SCOPE AREA FOR LABEL INITIALIZING WORD1 TO ! 3406: C CURRENT HEADING STMT NO ON DOLIST AND WORD2 TO CURRENT LEVEL ! 3407: C IN REFS AND DEFS LABELS MUST BE POSITIVE NUMBERS ! 3408: C ! 3409: TOKLAB = .FALSE. ! 3410: IF (DEF) GO TO 80 ! 3411: NON0 = .FALSE. ! 3412: J = PSTMT + 4 ! 3413: IF (J.GT.NSTMT) J = NSTMT ! 3414: K3 = PSTMT ! 3415: DO 10 K2 = PSTMT,J ! 3416: IF(STMT(K2).GT.9 .OR. STMT(K2).LT.0) GOTO 60 ! 3417: IF(STMT(K2) .GT. 0) NON0 = .TRUE. ! 3418: IF(.NOT.NON0) K3 = K3+1 ! 3419: 10 CONTINUE ! 3420: K2 = J+1 ! 3421: IF(.NOT.NON0) GOTO 70 ! 3422: C NOTE CAN CHANGE PSTMT HERE BECAUSE WE KNOW WE HAVE A LAB ! 3423: 20 PSTMT = K3 ! 3424: KK = LOOKUP(K2,.TRUE.) ! 3425: IF (SYSERR) GO TO 50 ! 3426: IF (ITYPE.EQ.14) DSA(BNEXT+1) = -DSA(BNEXT+1) ! 3427: I = IGATT1(KK,8) ! 3428: IF (I.EQ.0) CALL SATT1(KK, 8, 9) ! 3429: I1 = IGATT1(KK,1) ! 3430: IF (I1.NE.0) GO TO 30 ! 3431: CALL SATT1(KK, 1, K1) ! 3432: GO TO 40 ! 3433: 30 IF (K1.NE.I1) CALL ERROR1(30H INCOMPATIBLE LABEL REFERENCES, 30) ! 3434: 40 TOKLAB = .TRUE. ! 3435: 50 RETURN ! 3436: 60 IF (K2.EQ.PSTMT) GO TO 50 ! 3437: IF (NON0) GO TO 20 ! 3438: 70 CALL ERROR1(30H LABEL MUST BE POSITIVE NUMBER, 30) ! 3439: GO TO 50 ! 3440: C ! 3441: C TAKES DEF OF LABEL; CHECKS FOR DUPLICATE DEFS.; SETS DEFINED ! 3442: C BIT IN SYMBOL TABLE; STORES BEGINNING BINDING STMT NO ! 3443: C ! 3444: 80 K2 = 0 ! 3445: NON0 = .FALSE. ! 3446: DO 90 I=1,5 ! 3447: IF (STMT(I).EQ.69) GO TO 90 ! 3448: IF ((STMT(I).GT.9) .OR. (STMT(I).LT.0)) GO TO 140 ! 3449: IF (STMT(I).GT.0) NON0 = .TRUE. ! 3450: IF (.NOT.NON0) GO TO 90 ! 3451: K2 = K2 + 1 ! 3452: STMT(K2) = STMT(I) ! 3453: 90 CONTINUE ! 3454: IF (K2.EQ.0) GO TO 50 ! 3455: IF (.NOT.NON0) GO TO 70 ! 3456: K2 = K2 + 1 ! 3457: KK = LOOKUP(K2,.TRUE.) ! 3458: IF (SYSERR) GO TO 50 ! 3459: I = IGATT1(KK,2) ! 3460: IF (I.EQ.1) GO TO 120 ! 3461: CALL SATT1(KK, 2, 1) ! 3462: CALL SATT1(KK, 8, 9) ! 3463: I1 = IGATT1(KK,1) ! 3464: IF (I1.EQ.0) GO TO 100 ! 3465: IF (I1.EQ.K1) GO TO 110 ! 3466: CALL ERROR1(44H ILLEGAL REFERENCE TO LABEL IN PREVIOUS CODE, 44) ! 3467: 100 CALL SATT1(KK, 1, K1) ! 3468: 110 IF (K1.NE.1) GO TO 40 ! 3469: IF (NEXT+2.GE.BNEXT) GO TO 130 ! 3470: DSA(KK+2) = NEXT ! 3471: DSA(NEXT) = DOLIST(DOPT) ! 3472: DSA(NEXT+1) = -DOPT/6 ! 3473: NEXT = NEXT + 2 ! 3474: GO TO 40 ! 3475: 120 CALL ERROR1(16H DUPLICATE LABEL, 16) ! 3476: GO TO 50 ! 3477: 130 CALL ERROR1(33H IN TOKLAB, TABLE OVERFLOW OF DSA, 33) ! 3478: SYSERR = .TRUE. ! 3479: GO TO 50 ! 3480: 140 CALL ERROR1(24H ILLEGAL SYMBOL IN LABEL, 24) ! 3481: GO TO 50 ! 3482: END ! 3483: C XXXXXTOKLOG.f ! 3484: LOGICAL FUNCTION TOKLOG(K1, K2) ! 3485: C ! 3486: C ROUTINE RETURNS TRUE IF FINDS .TRUE. OR .FALSE. ! 3487: C IN STMT(K1)-STMT(K2-1) ! 3488: C ! 3489: INTEGER STMT, CONS(13), PSTMT ! 3490: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 3491: DATA CONS(1) /64/, CONS(2) /35/, CONS(3) /30/, CONS(4) /41/, ! 3492: * CONS(5) /48/, CONS(6) /34/, CONS(7) /64/, CONS(8) /64/, ! 3493: * CONS(9) /49/, CONS(10) /47/, CONS(11) /50/, CONS(12) /34/, ! 3494: * CONS(13) /64/ ! 3495: TOKLOG = .FALSE. ! 3496: KCNT = 1 ! 3497: L1 = 1 ! 3498: L2 = 7 ! 3499: K2 = K1 ! 3500: 10 DO 20 I=L1,L2 ! 3501: IF (STMT(K2).NE.CONS(I)) GO TO 30 ! 3502: K2 = K2 + 1 ! 3503: 20 CONTINUE ! 3504: TOKLOG = .TRUE. ! 3505: RETURN ! 3506: 30 KCNT = KCNT + 1 ! 3507: IF (KCNT.GE.3) RETURN ! 3508: K2 = K1 ! 3509: L1 = 8 ! 3510: L2 = 13 ! 3511: GO TO 10 ! 3512: END ! 3513: C XXXXXTOKLOP.f ! 3514: LOGICAL FUNCTION TOKLOP(K1, K2, KCODE) ! 3515: C ! 3516: C ROUTINE RETURNS TRUE IF FINDS LOGICAL OR RELATIONAL ! 3517: C OPERATORS IN STMT(K1)-STMT(K2-1); RETURNS OPERATOR CODE ! 3518: C IN KCODE (SEE EXPR FOR CODES) ! 3519: C ! 3520: INTEGER C(20), CC(9), CODE(9), PSTMT, STMT ! 3521: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 3522: DATA C(1) /30/, C(2) /43/, C(3) /33/, C(4) /43/, C(5) /44/, C(6) ! 3523: * /49/, C(7) /44/, C(8) /47/, C(9) /34/, C(10) /46/, C(11) ! 3524: * /43/, C(12) /34/, C(13) /36/, C(14) /49/, C(15) /36/, C(16) ! 3525: * /34/, C(17) /41/, C(18) /49/, C(19) /41/, C(20) /34/ ! 3526: DATA CC(1), CC(2) /2*3/, CC(3), CC(4), CC(5), CC(6), CC(7), ! 3527: * CC(8), CC(9) /7*2/, CODE(1) /19/, CODE(2) /14/, CODE(3) /20/, ! 3528: * CODE(4), CODE(5), CODE(6), CODE(7), CODE(8), CODE(9) /6*21/ ! 3529: TOKLOP = .FALSE. ! 3530: IF (STMT(K1).NE.64) RETURN ! 3531: J = 1 ! 3532: DO 30 I=1,9 ! 3533: KK = J + CC(I) - 1 ! 3534: K2 = K1 + 1 ! 3535: DO 10 L=J,KK ! 3536: IF (STMT(K2).NE.C(L)) GO TO 20 ! 3537: K2 = K2 + 1 ! 3538: 10 CONTINUE ! 3539: KCODE = CODE(I) ! 3540: IF (STMT(K2).NE.64) RETURN ! 3541: K2 = K2 + 1 ! 3542: TOKLOP = .TRUE. ! 3543: RETURN ! 3544: 20 J = J + CC(I) ! 3545: 30 CONTINUE ! 3546: RETURN ! 3547: END ! 3548: C XXXXXTOKPNO.f ! 3549: LOGICAL FUNCTION TOKPNO(K1, K2, LL) ! 3550: C ! 3551: C ROUTINE RECOGNIZES A POSITIVE INTEGER CONSTANT ! 3552: C IN STMT(K1)-STMT(K2-1), AND RETURNS ITS VALUE IN LL ! 3553: C ! 3554: INTEGER STMT, PSTMT ! 3555: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 3556: TOKPNO = .FALSE. ! 3557: CALL NEXTOK(K1, K2, K) ! 3558: IF (K.NE.1) RETURN ! 3559: K=K2-1 ! 3560: LL = 0 ! 3561: DO 10 KK=K1,K ! 3562: LL = 10 * LL + STMT(KK) ! 3563: 10 CONTINUE ! 3564: IF (LL.GT.0) TOKPNO = .TRUE. ! 3565: RETURN ! 3566: END ! 3567: C XXXXXTOKRL.f ! 3568: LOGICAL FUNCTION TOKRL(K1, K2, CODE) ! 3569: INTEGER STMT, CODE, PSTMT ! 3570: LOGICAL TOKLOP ! 3571: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 3572: C ! 3573: C ROUTINE RETURNS TRUE IF FINDS A REAL CONSTANT IN ! 3574: C STMT(K1)-STMT(K2-1) . ELSE IT RETURNS FALSE. ! 3575: C BASIC CONSTRUCT IS: <INT> . <INT> ! 3576: C <INT> . ! 3577: C . <INT> ! 3578: C EACH OF THESE MAY BE FOLLOWED BY <D,E> <+,-> <INT> ! 3579: C ALSO LEGAL IS IN-CONST FOLLOWED BY EXPONENT CONSTRUCT ! 3580: C ! 3581: TOKRL = .FALSE. ! 3582: CALL NEXTOK(K1, K2, K) ! 3583: IF (K.EQ.3 .AND. STMT(K1).EQ.64) GO TO 10 ! 3584: IF (K.EQ.1 .AND. STMT(K2).EQ.64) GO TO 40 ! 3585: C IF HAVE INT-CONST NEED EXPONENT FOR THIS TO BE A REAL-CONST ! 3586: IF (K-1) 80, 50, 80 ! 3587: C ! 3588: C FIND BASIC REAL CONSTANT ! 3589: C ! 3590: C (. INT-CONST) CONSTRUCT ! 3591: 10 CALL NEXTOK(K2, K3, K) ! 3592: IF (K.NE.1) GO TO 80 ! 3593: 20 K2 = K3 ! 3594: 30 TOKRL = .TRUE. ! 3595: CODE = 1 ! 3596: GO TO 50 ! 3597: C (INT-CONST .) CONSTRUCT; CHECK FOR (INT . INT ) ! 3598: 40 K2 = K2 + 1 ! 3599: CALL NEXTOK(K2, K3, K) ! 3600: IF (K.EQ.1) GO TO 20 ! 3601: IF (TOKLOP(K2-1,K4,K)) GO TO 80 ! 3602: GO TO 30 ! 3603: C ! 3604: C CHECK FOR EXPONENT ! 3605: C ! 3606: 50 IF (STMT(K2).NE.33) GO TO 60 ! 3607: CODE = 0 ! 3608: GO TO 70 ! 3609: 60 IF (STMT(K2).NE.34) GO TO 80 ! 3610: CODE = 1 ! 3611: 70 K3 = K2 + 1 ! 3612: IF (K3.EQ.NSTMT) GO TO 80 ! 3613: IF ((STMT(K3).EQ.60) .OR. (STMT(K3).EQ.61)) K3 = K3 + 1 ! 3614: CALL NEXTOK(K3, K4, K) ! 3615: IF (K.NE.1) GO TO 80 ! 3616: K2 = K4 ! 3617: TOKRL = .TRUE. ! 3618: 80 RETURN ! 3619: END ! 3620: C XXXXXTYPE.f ! 3621: SUBROUTINE TYPE ! 3622: LOGICAL ERR, SYSERR, ARDECL, ABORT ! 3623: INTEGER STMT, PSTMT, DSA, PDSA ! 3624: COMMON /DETECT/ ERR, SYSERR, ABORT ! 3625: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 3626: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 3627: C ! 3628: C PROCESSES TYPE STMT BY FINDING IDS OR ARRAY DECLS ! 3629: C THEY ARE ENTERED INTO SYMBOL TABLE AND TYPED EXPLICITLY ! 3630: C NO USAGE IS SET. ! 3631: C ! 3632: 10 IF (.NOT.ARDECL(K2,INDX)) GO TO 20 ! 3633: IF (SYSERR) GO TO 30 ! 3634: L = IGATT1(INDX,6) ! 3635: IF(L.EQ.1) CALL ERROR1(63 ! 3636: 1H WARNING - SHOULD TYPE ADJUSTABLE DIMENSION VARIABLE BEFORE USE ! 3637: 2, 63) ! 3638: IF (K2.EQ.NSTMT) GO TO 30 ! 3639: IF (STMT(K2).EQ.68 .AND. K2+1.NE.NSTMT) GO TO 40 ! 3640: 20 CALL ERROR1(15H ILLEGAL SYNTAX, 15) ! 3641: 30 RETURN ! 3642: 40 PSTMT = K2 + 1 ! 3643: GO TO 10 ! 3644: END ! 3645: C XXXXXTYPST.f ! 3646: SUBROUTINE TYPST(ITYP, KK, KL) ! 3647: INTEGER PSTMT, K(186), KI(30), STMT, CODE, KT(30) ! 3648: LOGICAL ERR, SYSERR, ASSMT, ABORT ! 3649: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 3650: COMMON /DETECT/ ERR, SYSERR, ABORT ! 3651: COMMON /STS/ K, KI, KT ! 3652: C ! 3653: C*****STS ! 3654: C K(*) (INT) ARRAY CONTAINS A TABLE OF INTERNAL CODES FOR EACH ! 3655: C "KEYWORD" IN FORTRAN STMTS ! 3656: C KI(*) (INT) ARRAY CONTAINING NUMBER OF CHARACTERS IN EACH ! 3657: C KEYWORD IN K ! 3658: C KT(*) (INT) ARRAY CONTAINING CLASS OF EACH STMT IN K ! 3659: C (SEE PU FOR FURTHER DOC OF IGP -CLASS) ! 3660: C TEST IF ITS AN ASSIGNMENT; IF SO ITYP = 30 ! 3661: C ELSE SEARCH K ARRAY FOR STMT; ITYP CONTAINS CODED ! 3662: C TYPE OF STMT; KK CONTAINS GENERAL CLASS OF STMTS IT FALLS IN ! 3663: C KL IS COUNT OF NUMBER OF LETTERS IN FIRST WORD OF STMT ! 3664: C ! 3665: CALL TYPST2(ASSMT) ! 3666: IF (ASSMT) GO TO 40 ! 3667: J = 1 ! 3668: CODE = 0 ! 3669: 10 I = PSTMT ! 3670: CODE = CODE + 1 ! 3671: L = J + KI(CODE) - 1 ! 3672: DO 20 LL=J,L ! 3673: IF (STMT(I).NE.K(LL)) GO TO 30 ! 3674: I = I + 1 ! 3675: 20 CONTINUE ! 3676: ITYP = CODE ! 3677: KK = KT(CODE) ! 3678: KL = KI(CODE) ! 3679: RETURN ! 3680: 30 J = L + 1 ! 3681: IF (CODE.LT.29) GO TO 10 ! 3682: ERR = .TRUE. ! 3683: RETURN ! 3684: 40 ITYP = 30 ! 3685: KK = KT(30) ! 3686: KL = 0 ! 3687: RETURN ! 3688: END ! 3689: C XXXXXTYPST2.f ! 3690: SUBROUTINE TYPST2(ASSMT) ! 3691: INTEGER PSTMT, STMT ! 3692: LOGICAL EQUALS, ASSMT ! 3693: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 3694: C ! 3695: C ALGORITHM FOR IDENTIFYING ASSIGNMENT STMTS: ! 3696: C ! 3697: EQUALS = .FALSE. ! 3698: LEVEL = 0 ! 3699: IGP = 0 ! 3700: C ! 3701: C 62.....) 63.....= 65.....( 68....., ! 3702: C ! 3703: DO 40 I=PSTMT,NSTMT ! 3704: IF (STMT(I).EQ.65) LEVEL = LEVEL + 1 ! 3705: IF (STMT(I).NE.62) GO TO 10 ! 3706: LEVEL = LEVEL - 1 ! 3707: IF (EQUALS) GO TO 40 ! 3708: IF (LEVEL.EQ.0) IGP = IGP + 1 ! 3709: IF (IGP.EQ.1 .AND. LEVEL.EQ.0 .AND. STMT(I+1).NE.63) GO TO 60 ! 3710: GO TO 40 ! 3711: 10 IF (LEVEL) 50, 20, 30 ! 3712: 20 IF (STMT(I).EQ.68) GO TO 60 ! 3713: IF (STMT(I).EQ.63) EQUALS = .TRUE. ! 3714: GO TO 40 ! 3715: 30 IF (STMT(I).EQ.63) GO TO 60 ! 3716: 40 CONTINUE ! 3717: IF (.NOT.EQUALS) GO TO 60 ! 3718: ASSMT = .TRUE. ! 3719: 50 RETURN ! 3720: 60 ASSMT = .FALSE. ! 3721: GO TO 50 ! 3722: END ! 3723: C XXXXXSATT2.f ! 3724: SUBROUTINE SATT2(INDEX, FIELD, ATT) ! 3725: C ! 3726: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 3727: C ! 3728: INTEGER INDEX, FIELD, ATT ! 3729: INTEGER LLAT, PLAT, LAT ! 3730: INTEGER FWTH(8), FPOS(8) ! 3731: C ! 3732: DATA FWTH(1) /16/, FPOS(1) /1/ ! 3733: DATA FWTH(2) /2/, FPOS(2) /16/ ! 3734: DATA FWTH(3) /2/, FPOS(3) /32/ ! 3735: DATA FWTH(4) /2/, FPOS(4) /64/ ! 3736: DATA FWTH(5) /2/, FPOS(5) /128/ ! 3737: DATA FWTH(6) /2/, FPOS(6) /256/ ! 3738: DATA FWTH(7) /4/, FPOS(7) /512/ ! 3739: DATA FWTH(8) /32/, FPOS(8) /2048/ ! 3740: C ! 3741: LAT(INDEX) = LAT(INDEX) + (ATT-MOD(LAT(INDEX)/FPOS(FIELD), ! 3742: * FWTH(FIELD)))*FPOS(FIELD) ! 3743: C ! 3744: RETURN ! 3745: C ! 3746: END ! 3747: C XXXXXIGATT2.f ! 3748: INTEGER FUNCTION IGATT2(INDEX, FIELD) ! 3749: C ! 3750: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 3751: C ! 3752: INTEGER INDEX, FIELD ! 3753: INTEGER LLAT, PLAT, LAT ! 3754: INTEGER FWTH(8), FPOS(8) ! 3755: C ! 3756: DATA FWTH(1) /16/, FPOS(1) /1/ ! 3757: DATA FWTH(2) /2/, FPOS(2) /16/ ! 3758: DATA FWTH(3) /2/, FPOS(3) /32/ ! 3759: DATA FWTH(4) /2/, FPOS(4) /64/ ! 3760: DATA FWTH(5) /2/, FPOS(5) /128/ ! 3761: DATA FWTH(6) /2/, FPOS(6) /256/ ! 3762: DATA FWTH(7) /4/, FPOS(7) /512/ ! 3763: DATA FWTH(8) /32/, FPOS(8) /2048/ ! 3764: C ! 3765: IGATT2 = MOD(LAT(INDEX)/FPOS(FIELD),FWTH(FIELD)) ! 3766: C ! 3767: RETURN ! 3768: C ! 3769: END ! 3770: C XXXXXCALLS.f ! 3771: SUBROUTINE CALLS ! 3772: INTEGER STMT, PSTMT, EXPR, M(3), OUTUT3, OUTUT4 ! 3773: LOGICAL ERR, SYSERR, ABORT ! 3774: LOGICAL OPT, P1ERR ! 3775: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 3776: COMMON /PARAMS/ I1, I2, I6, I4, I5, OUTUT3, OUTUT4 ! 3777: COMMON /DETECT/ ERR, SYSERR, ABORT ! 3778: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 3779: COMMON /OPTNS/ OPT(5), P1ERR ! 3780: DATA M(1) /4/, M(2) /2/, M(3) /0/ ! 3781: C ! 3782: C CHECK FOR LEGAL SUBROUTINE NAME BEFORE CALLING EXPR ! 3783: C TO PROCESS ARGUMENTS ! 3784: C IF NO ARGS, CALLS SAVES PASS 2 DATA ITSELF WITHOUT ! 3785: C CALLING EXPR ! 3786: C ! 3787: IF (PSTMT.GE.NSTMT) GO TO 10 ! 3788: CALL NEXTOK(PSTMT, K2, K) ! 3789: IF (K.NE.0) GO TO 10 ! 3790: IF (K2.EQ.NSTMT) GO TO 40 ! 3791: IF (STMT(K2).EQ.65) GO TO 30 ! 3792: 10 CALL ERROR1(26H MISSING ROUTINE NAME OR (, 26) ! 3793: 20 RETURN ! 3794: C ! 3795: C BY A CALL TO EXPR ! 3796: C ! 3797: 30 I3 = EXPR(K) ! 3798: IF (SYSERR) GO TO 20 ! 3799: IF (PSTMT.NE.NSTMT) CALL ERROR1(18H ILLEGAL CALL STMT, 18) ! 3800: GO TO 20 ! 3801: C ! 3802: C SAVE SUBROUTINE CALL W/O ARGS ! 3803: C ! 3804: 40 K = LOOKUP(K2,.FALSE.) ! 3805: IF (SYSERR) GO TO 20 ! 3806: I3 = IGATT1(K,8) ! 3807: IF (I3.NE.13 .AND. I3.NE.0) GO TO 50 ! 3808: CALL SATT1(K, 8, 6) ! 3809: GO TO 60 ! 3810: C ! 3811: C MAKE SURE EXTERNAL REFERENCED ID IS NOT USED AS ANYTHING ! 3812: C OTHER AS A SUBROUTINE ELSEWHERE IN THIS P-U ! 3813: C ! 3814: 50 IF (I3.EQ.6) GO TO 60 ! 3815: CALL ERROR1(24H ILLEGAL SUBROUTINE NAME, 24) ! 3816: GO TO 20 ! 3817: 60 IF (OPT(3) .AND. .NOT.P1ERR) WRITE (OUTUT3) M, K, NOST, M(3) ! 3818: GO TO 20 ! 3819: END ! 3820: C XXXXXDATA.f ! 3821: SUBROUTINE DATA ! 3822: LOGICAL ERR, SYSERR, ABORT, REPL, ARDECL, SIGN, TOKPNO, ERROR ! 3823: INTEGER DECNT, DATCNT, STMT, PSTMT, GETTOK, STACK, S(10), DSA, ! 3824: * PDSA ! 3825: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 3826: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 3827: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 3828: COMMON /DETECT/ ERR, SYSERR, ABORT ! 3829: COMMON /CEXPRS/ LSTACK, STACK(620) ! 3830: DATA IS /1H*/ ! 3831: C ! 3832: C ROUTINE PROCESSES A DATA STMT ! 3833: C ! 3834: 10 DECNT = 0 ! 3835: 20 IF (ARDECL(K2,KK)) GO TO 30 ! 3836: IF (.NOT.ERR) GO TO 30 ! 3837: CALL ERROR1(19H ILLEGAL DECLARATOR, 19) ! 3838: IF(.NOT.SYSERR) GOTO 260 ! 3839: 30 IF (SYSERR) RETURN ! 3840: C ! 3841: C SET DECLARATOR USAGE AS VARIABLE; CHECK ITS NOT IN BLANK COMMON ! 3842: C CANNOT BE INLABELLED COMMON IF THIS STMT NOT IN BLOCK DATA PGM ! 3843: C FOUND A DECLARATOR ADD IT TO LIST OF ALL DECLS SO CAN CHECK ! 3844: C TYPE OF ITS CORRESPONDING DATA-ITEM; ADD IN COUNT SO CAN ! 3845: C CHECK NUMBER OF DECLS VS. NUMBER OF DATA-ITEMS ! 3846: C KEEP TYPE INFO ON STACK; DECNT IS LENGTH OF STACK ! 3847: C ! 3848: I = IGATT1(KK,8) ! 3849: IF (I.EQ.0) CALL SATT1(KK, 8, 10) ! 3850: I = IGATT1(KK,2) ! 3851: NN = IGATT1(NAME,8) ! 3852: IF (I) 60, 60, 40 ! 3853: C ! 3854: C IF VARIABLE IN COMMON, CHECK TO SEE IF CAN LEGALLY APPEAR ! 3855: C IN DATA STMT ! 3856: C ! 3857: 40 I = DSA(KK+2) ! 3858: I = DSA(I+1) ! 3859: CALL S5UNPK(DSA(I+4), S(1), 6) ! 3860: IF (S(1).EQ.IS) GO TO 50 ! 3861: C ! 3862: C FOUND NO "*" SO ARE IN LABELLED COMMON ! 3863: C ! 3864: IF (NN.EQ.11) GO TO 70 ! 3865: CALL ERROR1( ! 3866: * 55H ILLEGAL TO INITIALIZE VARIABLE IN LABELLED COMMON HERE, ! 3867: * 55) ! 3868: GO TO 260 ! 3869: C ! 3870: C FOUND BLANK COMMON ! 3871: C ! 3872: 50 CALL ERROR1(48H ILLEGAL TO INITIALIZE VARIABLES IN BLANK COMMON, ! 3873: * 48) ! 3874: GO TO 260 ! 3875: 60 IF (NN.NE.11) GO TO 70 ! 3876: CALL ERROR1(33H DATA-ITEM NOT IN LABELLED COMMON, 33) ! 3877: GO TO 260 ! 3878: 70 I = IGATT1(KK,1) ! 3879: CALL SATT1(KK, 5, 1) ! 3880: NN = 1 ! 3881: IF (IGATT1(KK,7).EQ.0) GO TO 75 ! 3882: IF (STMT(K2-1).EQ.62) GO TO 75 ! 3883: N = DSA(KK+2) ! 3884: NN = DSA(N) ! 3885: 75 CONTINUE ! 3886: IF (DECNT+3.LE.LSTACK) GO TO 76 ! 3887: CALL ERROR1(33H IN DATA, TABLE OVERFLOW OF STACK , 33 ) ! 3888: GO TO 260 ! 3889: 76 CONTINUE ! 3890: STACK(DECNT+1) = MOD(I,8) ! 3891: STACK(DECNT+2) = KK ! 3892: STACK(DECNT+3) = NN ! 3893: DECNT = DECNT + 3 ! 3894: IF (STMT(K2).EQ.67) GO TO 100 ! 3895: IF (STMT(K2).NE.68) GO TO 90 ! 3896: PSTMT = K2 + 1 ! 3897: IF (PSTMT.LT.NSTMT) GO TO 20 ! 3898: 80 CALL ERROR1(15H ILLEGAL SYNTAX, 15) ! 3899: RETURN ! 3900: 90 CALL ERROR1(33H ILLEGAL PUNCTUATION IN DATA STMT, 33) ! 3901: GO TO 260 ! 3902: C ! 3903: C FIND DATA-ITEMS; CHECK ITS TYPE VS. CORRESPONDING DECLARATOR ! 3904: C SIGN .TRUE. IF DATA-ITEM PRECEEDED BY A SIGN ! 3905: C REPL .TRUE. IF A REPLICATION FACTOR HAS ALREADY BEEN FOUND ! 3906: C ! 3907: 100 DATCNT = 0 ! 3908: ERROR = .FALSE. ! 3909: PSTMT = K2 + 1 ! 3910: 110 IF (PSTMT.EQ.NSTMT) GO TO 80 ! 3911: SIGN = .FALSE. ! 3912: REPL = .FALSE. ! 3913: NN = 1 ! 3914: 120 IF (STMT(PSTMT).NE.60 .AND. STMT(PSTMT).NE.61) GO TO 130 ! 3915: PSTMT = PSTMT + 1 ! 3916: SIGN = .TRUE. ! 3917: 130 IF (PSTMT.EQ.NSTMT) GO TO 80 ! 3918: KK = GETTOK(PSTMT,K2) ! 3919: IF (ERR) GO TO 80 ! 3920: IF (KK.LT.6) GO TO 150 ! 3921: 140 CALL ERROR1(18H ILLEGAL DATA-ITEM, 18) ! 3922: GO TO 260 ! 3923: 150 KK = KK + 1 ! 3924: GO TO (200, 200, 160, 190, 190, 180), KK ! 3925: C ! 3926: C MUST MAKE SURE THAN AN INTEGER DATA-ITEM ISN'T A REPLICATION FACTO ! 3927: C ! 3928: 160 IF (REPL) GO TO 200 ! 3929: IF(SIGN .OR. STMT(K2).NE.66) GOTO 200 ! 3930: IF(TOKPNO(PSTMT,K2,NN)) GOTO 170 ! 3931: CALL ERROR1(27H ILLEGAL REPLICATION FACTOR ,27) ! 3932: NN = 1 ! 3933: 170 REPL = .TRUE. ! 3934: PSTMT = K2 + 1 ! 3935: GO TO 120 ! 3936: C ! 3937: C CHECK LENGTH OF HOLLERITH DATA-ITEM; MUST FIT INTO INTEGER WORD ! 3938: C ! 3939: 180 IF (STMT(PSTMT)+2048.EQ.1 .OR. ERROR) GO TO 190 ! 3940: CALL ERROR1( ! 3941: * 53H WARNING - NH WITH N.GT.1 IS NOT A PORTABLE CONSTRUCT, 53) ! 3942: ERROR = .TRUE. ! 3943: C ! 3944: C CHECK COMPLEX, HOLLERITH, AND LOGICAL DATA-ITEMS ARE UNSIGNED ! 3945: C ! 3946: 190 IF (SIGN) GO TO 140 ! 3947: C ! 3948: C CHECK COMPATIBLITY OF DATA-ITEMS WITH DECLARATORS ! 3949: C NN IS REPLICATION FACTOR; ! 3950: C ! 3951: 200 IBR=0 ! 3952: DO 220 I = 1,NN ! 3953: IF (STACK(DATCNT+3).EQ.0) DATCNT = DATCNT + 3 ! 3954: IF (DATCNT .GE. DECNT) GO TO 240 ! 3955: STACK(DATCNT+3) = STACK(DATCNT+3) - 1 ! 3956: IF (STACK(DATCNT+1).EQ.KK-1) GO TO 220 ! 3957: IF ((STACK(DATCNT+1).NE.2 .OR. KK.NE.6) .AND. ! 3958: * (STACK(DATCNT+1).NE.5 .OR. KK.NE.3)) GO TO 210 ! 3959: CALL SATT1(STACK(DATCNT+2), 1, 5) ! 3960: GO TO 220 ! 3961: 210 IBR = 1 ! 3962: 220 CONTINUE ! 3963: IF(IBR .EQ. 1) CALL ERROR1(52 ! 3964: 1H WARNING - DATA-ITEM IS INCOMPATIBLE WITH DECLARATOR ,52) ! 3965: C ! 3966: C CHECK FOR "," BETWEEN DATA-ITEMS ! 3967: C ! 3968: IF (STMT(K2).NE.68) GO TO 230 ! 3969: PSTMT = K2 + 1 ! 3970: GO TO 110 ! 3971: C ! 3972: C CHECK FOR ANOTHER SET OF DECLARATORS/DATA-ITEMS ! 3973: C ! 3974: 230 IF (STMT(K2).NE.67) GO TO 90 ! 3975: IF (STACK(DATCNT+3).EQ.0) DATCNT = DATCNT + 3 ! 3976: IF (DATCNT.EQ.DECNT) GO TO 250 ! 3977: 240 CALL ERROR1(34H MISSING DECLARATORS OR DATA-ITEMS, 34) ! 3978: IF (DATCNT.GE.DECNT) GO TO 260 ! 3979: 250 PSTMT = K2 + 1 ! 3980: IF (PSTMT.EQ.NSTMT) RETURN ! 3981: IF (STMT(PSTMT).NE.68) GO TO 90 ! 3982: PSTMT = PSTMT + 1 ! 3983: IF (PSTMT.NE.NSTMT) GO TO 10 ! 3984: GO TO 80 ! 3985: C ! 3986: C FLUSH TO "/," CONSTRUCT OR END OF STATEMEMT ! 3987: C ! 3988: 260 IF (PSTMT+1.GE.NSTMT) RETURN ! 3989: IF (STMT(PSTMT).EQ.67 .AND. STMT(PSTMT+1).EQ.68) GO TO 270 ! 3990: PSTMT = PSTMT + 1 ! 3991: GO TO 260 ! 3992: 270 PSTMT = PSTMT + 2 ! 3993: IF (PSTMT.GE.NSTMT) RETURN ! 3994: GO TO 10 ! 3995: END ! 3996: C XXXXXDOSTMT.f ! 3997: SUBROUTINE DOSTMT ! 3998: LOGICAL TOKLAB, ERR, SYSERR, ABORT ! 3999: INTEGER STMT, PSTMT ! 4000: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 4001: COMMON /DETECT/ ERR, SYSERR, ABORT ! 4002: C ! 4003: C ROUTINE PROCESSES A DO STMT. DOSTMT PEELS OFF THE ! 4004: C LABEL. CALLS DOSPEC TO GET THE <DO-SPECIFICATION> ! 4005: C ! 4006: IF (TOKLAB(1,K2,KK,.FALSE.)) GO TO 10 ! 4007: CALL ERROR1(23H MISSING LABEL AFTER DO, 23) ! 4008: GO TO 20 ! 4009: 10 IF (SYSERR) GO TO 20 ! 4010: PSTMT = K2 ! 4011: CALL DOSPEC(KK, K2, .FALSE.) ! 4012: 20 RETURN ! 4013: END ! 4014: C XXXXXEND.f ! 4015: SUBROUTINE END ! 4016: C ! 4017: C ROUTINE SAVES SYMBOL TABLE FOR 2ND PASS ! 4018: C CHECKS VARIABLE DIMENSIONING IN FCN/SUBR PU'S ! 4019: C CANNOT RESET DUMMY ARGS USED IN VARIABLE DIMENSIONING; ! 4020: C CHECKS SUCH BOUNDS FOR TYPE INTEGER ! 4021: C CALLS OUTSYM TO PRINT SYMBOL TABLE ! 4022: C CHECKS FOR UNDEFINED LABELS,MISSING DO ENDINGS, ! 4023: C PROPER BRANCHING THROUGHOUT PGM, ! 4024: C FIXES UP ALL LABELS WHOSE SCOPE IS NOT YET LIMITED ! 4025: C SETS USAGE OF ALL IDS TO VARIABLE IF USAGE NOT YET SET ! 4026: C RESETS FCN USAGE IN FCN SUBPROGRAM ! 4027: C ! 4028: INTEGER OUTUT, OUTUT2, OUTUT3, OUTUT4 ! 4029: INTEGER PDSA, SYMLEN, BNEXT, SYMHD, STACK, DSA ! 4030: LOGICAL OPT, P1ERR ! 4031: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, ! 4032: * OUTUT4 ! 4033: COMMON /OPTNS/ OPT(5), P1ERR ! 4034: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 4035: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 4036: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 4037: COMMON /CEXPRS/ LSTACK, STACK(620) ! 4038: I = IGATT1(NAME,8) ! 4039: IF((I.NE.3 .AND. I.NE.10) .OR. DSA(NAME+2).EQ.0) GOTO 40 ! 4040: C ! 4041: C ARGUMENT CHECKING- FOR USE IN VARIABLE DIMENSIONING OF ARRAYS ! 4042: C ! 4043: LL = 1 ! 4044: L = DSA(NAME+2) ! 4045: NPAR = 0 ! 4046: 10 IF (L.EQ.0) GO TO 40 ! 4047: NPAR = NPAR + 1 ! 4048: C CHECK FOR PROC ARGS TO ENTER THEIR RELATIVE POSIT ! 4049: C IN ARGLIST IN WD 3 OF THEIR SYMBOL TABLE ENTRY ! 4050: I = IGATT1(DSA(L),8) ! 4051: IF (I.NE.5 .AND. I.NE.6 .AND. I.NE.13) GO TO 20 ! 4052: I = DSA(L) ! 4053: DSA(I+2) = NPAR ! 4054: GO TO 30 ! 4055: 20 I = IGATT1(DSA(L),6) ! 4056: IF (I.EQ.0) GO TO 30 ! 4057: I = IGATT1(DSA(L),7) ! 4058: IF (I.NE.0) GO TO 30 ! 4059: I = IGATT1(DSA(L),5) ! 4060: K = DSA(L) ! 4061: IF (I.GT.0) CALL ERROR2( ! 4062: * 57H ILLEGALLY RESET DUMMY ARG USED IN VARIABLE DIMENSIONING , ! 4063: * 57, DSA(K+4), 1, 1, 1) ! 4064: I = IGATT1(K,1) ! 4065: IF (MOD(I,8).NE.2) CALL ERROR2( ! 4066: * 47H ILLEGAL DATA TYPE USED IN ADJUSTIBLE DIMENSION, 47 ! 4067: * , DSA(K+4), 1, 1, 1) ! 4068: 30 L = DSA(L+1) ! 4069: GO TO 10 ! 4070: C ! 4071: C OUTPUT TABLE ! 4072: C ! 4073: 40 CALL DOCHK(1) ! 4074: C ! 4075: C CHECK LABELS DEFINED AND WITHIN SCOPE ! 4076: C ! 4077: I = LABHD ! 4078: 50 IF (I.EQ.0) GO TO 110 ! 4079: L = IGATT1(I,2) ! 4080: IF (L.EQ.1) GO TO 60 ! 4081: CALL ERROR2(17H UNDEFINED LABEL , 17, DSA(I+4), 1, 1, 1) ! 4082: GO TO 100 ! 4083: 60 L = IGATT1(I,1) ! 4084: IF (L.NE.1) GO TO 100 ! 4085: L = DSA(I+2) ! 4086: L1 = DSA(L) ! 4087: KK = DSA(L+1) ! 4088: L2 = DSA(I+1) ! 4089: C ! 4090: C L3 POINTS TO LAST ELEMENT ON CIRCULAR LIST ! 4091: C ! 4092: L3 = L2 ! 4093: 70 IF (DSA(L2).LE.KK .AND. DSA(L2).GE.L1) GO TO 90 ! 4094: IF (DSA(L2).LT.0) GO TO 80 ! 4095: CALL ERROR2(15H ILLEGAL BRANCH, 15, DSA(L2), -1, 1, 1) ! 4096: GO TO 90 ! 4097: 80 DSA(L2) = IABS(DSA(L2)) ! 4098: 90 L2 = DSA(L2+1) ! 4099: IF (L2.NE.L3) GO TO 70 ! 4100: 100 I = DSA(I+3) ! 4101: GO TO 50 ! 4102: C ! 4103: C SET <ID> USAGE IF NOT YET SET ! 4104: C ! 4105: 110 I = SYMHD ! 4106: 120 IF (I.EQ.0) GO TO 150 ! 4107: K = IGATT1(I,8) ! 4108: IF (K.NE.0) GO TO 130 ! 4109: CALL SATT1(I, 8, 10) ! 4110: GO TO 140 ! 4111: 130 IF (K.NE.6) GO TO 140 ! 4112: IF (IGATT1(I,1)/8.NE.1) GO TO 140 ! 4113: CALL ERROR2(33H SUBROUTINE NAME CANNOT BE TYPED , 33, DSA(I+4), ! 4114: * 1, 1, 1) ! 4115: 140 I = DSA(I+3) ! 4116: GO TO 120 ! 4117: C ! 4118: C RESET FCN USAGE IN FCN PROGRAM UNIT ! 4119: C ! 4120: 150 I = IGATT1(NAME,8) ! 4121: IF (I.NE.10) GO TO 160 ! 4122: CALL SATT1(NAME, 8, 4) ! 4123: I = IGATT1(NAME,5) ! 4124: IF (I.EQ.0) CALL ERROR1(23H FUNCTION VALUE NOT SET, 23) ! 4125: C ! 4126: C SAVE BINARY COPY OF SYMBOL TABLE ! 4127: C ! 4128: 160 IF (OPT(3) .AND. .NOT.P1ERR) GO TO 170 ! 4129: CALL ERROR1(36H P-U NOT SAVED FOR PASS2 PROCESSING , 36) ! 4130: K = 3 ! 4131: L = 1 ! 4132: WRITE(OUTUT2) L,K,L ! 4133: WRITE(OUTUT3) L,K,L ! 4134: GOTO 180 ! 4135: 170 K = 1 ! 4136: L = NEXT - 1 ! 4137: I = L + 3 ! 4138: WRITE (OUTUT2) I, K, (DSA(I),I=1,L), NAME, SYMHD, LABHD ! 4139: L = 3 ! 4140: WRITE (OUTUT3) K, L, K ! 4141: 180 CALL OUTSYM ! 4142: RETURN ! 4143: END ! 4144: C XXXXXEXPR.f ! 4145: INTEGER FUNCTION EXPR(LOGEX) ! 4146: C ! 4147: C LOGEX IS A DUMMY ARG , NEVER USED ! 4148: C FALSE IF AN ARITHMETIC EXPRESSION WAS FOUND ! 4149: C PRE IS PRECEDENCE TABLE, PRE(I,J) GIVES ACTION TAKEN WHEN OP I ! 4150: C IS ON THE STACK, OP J IN THE INPUT ! 4151: C CUROP IS CURRENT TOKEN TYPE ! 4152: C PREVOP IS PREVIOUS TOKEN TYPE (LAST ONE PROCESSED BEFORE CUROP) ! 4153: C STACK IS OPERAND STACK GROWING FROM TOP (1,2 ETC) ! 4154: C OPERATER STACK GROWING FROM BOTTOM UP(100,99 ETC) ! 4155: C PARENS COUNTS NESTING LEVEL OF PARENTHESES AND FUNCTION CALLS ! 4156: C ! 4157: C*****EXPRS ! 4158: C PT (INT) POINTER TO NEXT FREE WORD ON OPERAND STACK (GROWS ! 4159: C FROM STACK(1)) ! 4160: C PB (INT) POINTER TO NEXT FREE WORD ON OPERATOR STACK (GROWS ! 4161: C FROM STACK(LSTACK)) ! 4162: C AO(*,*) (INT) ARRAY GIVES TYPES OF ARITH OPERATIONS ! 4163: C AO(I,J) = TYPE OF (TYPE I <ARITH-OP> TYPE J) ! 4164: C RO(*,*) (INT) ARRAY TELLS LEGALITY OF RELATIONAL OPERATIONS ! 4165: C RO(I,J) = 1 IF TYPE I <RELOP> TYPEJ IS LEGAL; ELSE IS 0 ! 4166: C EX(*,*) (INT) ARRAY GIVES TYPES OF ** OPERATION ! 4167: C EX(I,J) = TYPE OF (TYPE I <**> TYPE J) ! 4168: C ! 4169: INTEGER PRE(12,12), EX(4,4), AO(4,4), CUROP, PREVOP, RO(3,3), ! 4170: * STACK, PARENS, STMT, PSTMT, PT, PB, SYMLEN, PDSA, OUTUT, ! 4171: * GETTOK, IBR(14), JBR(13), ADJ(5,4), OUTUT2, DSA, OUTUT3, ! 4172: * OUTUT4, PREF, REF ! 4173: LOGICAL FLUSH, ERR, SYSERR, CALLST, DOVAR, OPT, ABORT, P1ERR ! 4174: LOGICAL INTEXT ! 4175: COMMON /DETECT/ ERR, SYSERR, ABORT ! 4176: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 4177: COMMON /EXPRS/ PT, PB, AO, RO, EX ! 4178: COMMON /CEXPRS/ LSTACK, STACK(620) ! 4179: COMMON /CREF/ LREF, PREF, REF(100) ! 4180: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, ! 4181: * OUTUT4 ! 4182: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 4183: COMMON /OPTNS/ OPT(5), P1ERR ! 4184: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 4185: DATA K /0/ ! 4186: DATA PRE(1,1) /6/, PRE(1,2) /6/, PRE(1,3) /4/, PRE(1,5) /4/, ! 4187: * PRE(1,6) /2/, PRE(1,7) /4/, PRE(1,8) /6/, PRE(1,9) /6/, ! 4188: * PRE(1,10) /6/, PRE(1,4) /-1/, PRE(1,11) /6/, PRE(2,1) /-1/, ! 4189: * PRE(2,2) /-1/, PRE(2,3) /-1/, PRE(2,5) /-1/, PRE(2,6) /-1/, ! 4190: * PRE(2,7) /-1/, PRE(2,8) /-1/, PRE(2,9) /-1/, PRE(2,10) /-1/, ! 4191: * PRE(2,4) /-1/, PRE(2,11) /-1/, PRE(3,1) /6/, PRE(3,2) /6/, ! 4192: * PRE(3,3) /-1/, PRE(3,5) /4/, PRE(3,6) /2/, PRE(3,7) /6/, ! 4193: * PRE(3,8) /6/, PRE(3,9) /6/, PRE(3,10) /6/, PRE(3,4) /-1/, ! 4194: * PRE(3,11) /6/, PRE(5,1) /5/, PRE(5,2) /7/, PRE(5,3) /4/, ! 4195: * PRE(5,5) /4/, PRE(5,6) /2/, PRE(5,7) /4/, PRE(5,8) /-1/, ! 4196: * PRE(5,9) /4/, PRE(5,10) /4/, PRE(5,4) /4/, PRE(5,11) /4/, ! 4197: * PRE(6,1) /5/, PRE(6,2) /1/, PRE(6,3) /4/, PRE(6,5) /4/, ! 4198: * PRE(6,6) /2/, PRE(6,7) /4/, PRE(6,8) /3/, PRE(6,9) /4/, ! 4199: * PRE(6,10) /4/, PRE(6,4) /4/, PRE(6,11) /4/ ! 4200: DATA PRE(7,1) /6/, PRE(7,2) /6/, PRE(7,3) /4/, PRE(7,5) /4/, ! 4201: * PRE(7,6) /2/, PRE(7,7) /6/, PRE(7,8) /6/, PRE(7,9) /6/, ! 4202: * PRE(7,10) /6/, PRE(7,4) /-1/, PRE(7,11) /6/, PRE(8,1) /-1/, ! 4203: * PRE(8,2) /-1/, PRE(8,3) /-1/, PRE(8,5) /-1/, PRE(8,6) /-1/, ! 4204: * PRE(8,7) /-1/, PRE(8,8) /-1/, PRE(8,9) /-1/, PRE(8,10) /-1/, ! 4205: * PRE(8,4) /-1/, PRE(8,11) /-1/, PRE(9,1) /5/, PRE(9,2) /6/, ! 4206: * PRE(9,3) /4/, PRE(9,5) /4/, PRE(9,6) /2/, PRE(9,7) /4/, ! 4207: * PRE(9,8) /6/, PRE(9,9) /6/, PRE(9,10) /6/, PRE(9,4) /4/, ! 4208: * PRE(9,11) /4/, PRE(10,1) /5/, PRE(10,2) /6/, PRE(10,3) /4/, ! 4209: * PRE(10,5) /4/, PRE(10,6) /2/, PRE(10,7) /4/, PRE(10,8) /6/, ! 4210: * PRE(10,9) /4/, PRE(10,10) /6/, PRE(10,4) /4/, PRE(10,11) /4/, ! 4211: * PRE(4,1) /5/, PRE(4,2) /6/, PRE(4,3) /4/, PRE(4,5) /4/, ! 4212: * PRE(4,6) /2/, PRE(4,7) /4/, PRE(4,8) /6/, PRE(4,9) /6/, ! 4213: * PRE(4,10) /6/, PRE(4,4) /-1/, PRE(4,11) /4/, PRE(11,1) /5/, ! 4214: * PRE(11,2) /6/, PRE(11,3) /4/, PRE(11,5) /4/, PRE(11,6) /2/, ! 4215: * PRE(11,7) /4/, PRE(11,8) /6/, PRE(11,9) /6/, PRE(11,10) /6/, ! 4216: * PRE(11,4) /-1/, PRE(11,11) /6/ ! 4217: DATA PRE(12,1), PRE(12,3), PRE(12,7), PRE(12,11) /4*6/, PRE(12,2) ! 4218: * /6/, PRE(12,5) /4/, PRE(12,6) /2/, PRE(12,8) /6/, PRE(12,4), ! 4219: * PRE(12,9), PRE(12,10) /3*6/, PRE(1,12), PRE(2,12), PRE(3,12), ! 4220: * PRE(7,12), PRE(12,12) /5*-1/, PRE(5,12), PRE(6,12), ! 4221: * PRE(8,12), PRE(9,12), PRE(10,12), PRE(4,12), PRE(11,12) /7*4/ ! 4222: DATA IBR(1), IBR(3), IBR(7), IBR(12) /4*1/, IBR(2) /2/, IBR(4), ! 4223: * IBR(11) /2*3/, IBR(9), IBR(10) /2*5/, IBR(8), IBR(5), IBR(6) ! 4224: * /3*4/, IBR(13) /2/, IBR(14) /4/, JBR(1), JBR(12) /2*1/, ! 4225: * JBR(2), JBR(3), JBR(7), JBR(9), JBR(10), JBR(11), JBR(8) ! 4226: * /7*2/, JBR(4) /3/, JBR(5), JBR(6) /2*4/, JBR(13) /4/ ! 4227: DATA ADJ(1,1), ADJ(1,2), ADJ(1,3) /3*-1/, ADJ(1,4) /0/, ADJ(2,1), ! 4228: * ADJ(2,2) /2*0/, ADJ(2,3), ADJ(2,4) /2*-1/, ADJ(3,1) /1/, ! 4229: * ADJ(3,4) /0/, ADJ(3,2), ADJ(3,3) /2*-1/, ADJ(5,1) /1/, ! 4230: * ADJ(5,3), ADJ(5,4) /2*0/, ADJ(5,2) /-1/, ADJ(4,1), ADJ(4,3), ! 4231: * ADJ(4,4) /3*0/, ADJ(4,2) /-1/ ! 4232: C ! 4233: C CODES IN OPERAND STACK ! 4234: C 0....DOUBLE PRECISION 1....REAL 2....INTEGER ! 4235: C 3....COMPLEX 4....LOGICAL 5....HOLLERITH ! 4236: C 6....PROCEDURE NAME ! 4237: C CODES FOR OPERATORS ! 4238: C 11 +,- 12 ) 13 ** 14 .NOT. 15 ( 16 FCN( ! 4239: C 17 /,* 18 , 19 .AND. 20 .OR. 21 .EQ. 22 UNARY -,+ ! 4240: C ! 4241: PB = LSTACK ! 4242: PT = 1 ! 4243: CALLST = .FALSE. ! 4244: PREVOP = -1 ! 4245: CUROP = 0 ! 4246: PARENS = 0 ! 4247: FLUSH = .FALSE. ! 4248: EXPR = -1 ! 4249: 10 IF (PSTMT.LT.NSTMT .AND. .NOT.CALLST) GO TO 110 ! 4250: C ! 4251: C FINISH RECOGNITION OF EXPRESSION; POP OPERAND STACK AND RETURN ! 4252: C TYPE OF EXPRESSION ! 4253: C ! 4254: 20 IF (PARENS.EQ.0) GO TO 40 ! 4255: 30 CALL ERROR1(37H UNBALANCED PARENTHESES IN EXPRESSION, 37) ! 4256: IF (FLUSH) GO TO 530 ! 4257: GO TO 80 ! 4258: 40 IF (PB.EQ.LSTACK .OR. CALLST) GO TO 60 ! 4259: 50 CALL POP ! 4260: IF (ERR) GO TO 530 ! 4261: IF (PB.LT.LSTACK) GO TO 50 ! 4262: 60 IF (PT.NE.3) GO TO 90 ! 4263: IF (STACK(1).EQ.0) GO TO 70 ! 4264: I = IGATT1(STACK(1),8) ! 4265: IF (I.EQ.0) CALL SATT1(STACK(1), 8, 10) ! 4266: 70 EXPR = STACK(2) ! 4267: 80 PSTMT = K2 ! 4268: ERR = .FALSE. ! 4269: RETURN ! 4270: 90 CALL ERROR1(29H INVALID SYNTAX IN EXPRESSION, 29) ! 4271: IF (FLUSH) GO TO 530 ! 4272: GO TO 80 ! 4273: 100 CALL ERROR1(31H EXPRESSION TOO LONG TO PROCESS, 31) ! 4274: GO TO 530 ! 4275: C ! 4276: C CONTINUING PROCESSING THE EXPRESSION, IDENTIFY NEXT TOKEN, ! 4277: C ! 4278: 110 CUROP = GETTOK(PSTMT,K2) ! 4279: IF (ERR) GO TO 80 ! 4280: C ! 4281: C SEE END OF EXPRESSION: ")" <ID> OR <LABEL>; GETTOK RETURNS ! 4282: C SAME CODES AS THOSE ABOVE EXCEPT 6 IS ID, 16 IS FCN( OR ARRAY ELE ! 4283: C ! 4284: IF (CUROP.NE.6 .AND. CUROP.NE.2 .AND. CUROP.NE.16 .OR. ! 4285: * PREVOP.NE.12) GO TO 120 ! 4286: K2 = PSTMT ! 4287: GO TO 20 ! 4288: C ! 4289: C CHECK FOR ADJACENT OPERATORS OR OPERANDS. ! 4290: C ! 4291: 120 IF (PREVOP.LE.6) GO TO 130 ! 4292: I = IBR(PREVOP-10) ! 4293: GO TO 140 ! 4294: 130 I = IBR(13) ! 4295: IF(PREVOP.EQ.(-1)) I = IBR(14) ! 4296: 140 IF (CUROP.LE.6) GO TO 150 ! 4297: I2 = JBR(CUROP-10) ! 4298: GO TO 160 ! 4299: 150 I2 = JBR(13) ! 4300: 160 IF (I.GE.3 .AND. I2.EQ.1) CUROP = 22 ! 4301: IF (ADJ(I,I2)) 170, 190, 180 ! 4302: 170 CALL ERROR1(44H ADJACENT PLACEMENT OF OPERATORS OR OPERANDS, 44) ! 4303: GO TO 530 ! 4304: 180 CALL ERROR1( ! 4305: * 54H WARNING - ADJACENT PLACEMENT OF OPERATOR AND UNARY -+, 54) ! 4306: 190 IF (CUROP.GT.6 .AND. CUROP.NE.16) GO TO 290 ! 4307: IF (CUROP.LT.6) GO TO 280 ! 4308: C ! 4309: C PROCESS ID OR FCN( OR ARRAY ELEMENT OR ARRAY ! 4310: C LOOKUP SYMBOL TABLE ENTRY TO IDENTIFY ARRAYS AND TO IMPLICITLY ! 4311: C TYPE IDENTIFIERS IF NECESSARY. ! 4312: C ! 4313: IF (CUROP.EQ.6) GO TO 200 ! 4314: K = LOOKUP(K2-1,.FALSE.) ! 4315: GO TO 210 ! 4316: 200 K = LOOKUP(K2,.FALSE.) ! 4317: 210 IF (SYSERR) GO TO 530 ! 4318: I1 = IGATT1(K,1) ! 4319: I2 = IGATT1(K,7) ! 4320: I3 = IGATT1(K,8) ! 4321: C ! 4322: C IMPLICITLY TYPE IDENTIFIERS AND FCNS ! 4323: C ! 4324: IF (I1.GT.0) GO TO 220 ! 4325: I1 = 1 ! 4326: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2 ! 4327: CALL SATT1(K, 1, I1) ! 4328: C ! 4329: C SEPARATE ARRAY ELEMENT, FCN REFERENCE,ASF REF. ! 4330: C ! 4331: 220 I1 = MOD(I1,8) ! 4332: IF (CUROP.NE.16) GO TO 250 ! 4333: IF (I2.EQ.0) GO TO 240 ! 4334: C ! 4335: C ARRAY ELEMENT--CHECK FOR BEING IN ASF DEF AND PEEL OFF ! 4336: C SUBSCRIPTS, CHECKING THEIR NUMBER ! 4337: C ! 4338: IF (ITYP.NE.31) GO TO 230 ! 4339: CALL ERROR1(39H ILLEGAL USE OF ARRAY IN ASF DEFINITION, 39) ! 4340: 230 CUROP = I1 ! 4341: I1 = CUROP + 16 ! 4342: PSTMT = K2 ! 4343: CALL SUBS(K2, I2) ! 4344: IF (ERR .OR. SYSERR) GO TO 80 ! 4345: GO TO 270 ! 4346: C ! 4347: C PROCESS FCN( OR ASF( REFERENCE; CHECK USAGE TO SEE ! 4348: C IF IS A LEGAL FCN OR ASF NAME I.E. IF WAS USED ! 4349: C AS A FCN, SUBR, ASF, OR WAS IN AN EXTERNAL STMT. ! 4350: C ! 4351: 240 IF (I3.EQ.0 .OR. I3.EQ.2 .OR. I3.EQ.5 .OR. I3.EQ.6 .OR. I3.EQ.13 ! 4352: * .OR. I3.EQ.14) GO TO 290 ! 4353: C ! 4354: C ACTUAL USAGE WILL BE DETERMINED BY CODE WHICH ! 4355: C STORES CALL TEMPLATE ! 4356: C ! 4357: CALL ERROR1(18H ILLEGAL USE OF ID, 18) ! 4358: GO TO 530 ! 4359: C ! 4360: C VARIABLE, ARRAY, PROCEDURE NAME ! 4361: C ! 4362: 250 IF (I2.EQ.0) GO TO 260 ! 4363: C ! 4364: C ARRAY ! 4365: C ! 4366: CUROP = I1 ! 4367: I1 = CUROP + 8 ! 4368: IF (I3.EQ.0) CALL SATT1(K, 8, 10) ! 4369: GO TO 270 ! 4370: C ! 4371: C VARIABLE OR PROCEDURE ! 4372: C LEAVE IDS USAGE UNSET ! 4373: C THEY WILL BE SET LATER BY APPEARING AS OPERANDS OR BY BEING ! 4374: C DEFINED AS FCN OR SUBROUTINE REFS BY FOLLOWING PGMS ! 4375: C ! 4376: 260 IF (I3.EQ.0) GO TO 270 ! 4377: IF (I3.EQ.5 .OR. I3.EQ.6 .OR. I3.EQ.13) I1 = 6 ! 4378: IF (I3.EQ.10 .OR. I1.EQ.6) GO TO 270 ! 4379: IF (ITYP.EQ.31 .AND. I3.EQ.1 .AND. DSA(K+2).EQ.IASF) GO TO 270 ! 4380: CALL ERROR1(36H ILLEGAL VARIABLE USED IN EXPRESSION, 36) ! 4381: GO TO 530 ! 4382: C ! 4383: C ENTER ARRAY,ID, PROCEDURE NAME, ARRAY ELEMENT INTO OPERAND STACK ! 4384: C UPDATE PREVOP,PSTMT. ALSO ENTER SYMBOL TABLE INDEX FOR THESE ! 4385: C PREVOP = 0,1,...6 FOR OPERANDS ! 4386: C 11,12,...22 FOR OPERATORS ! 4387: C ! 4388: 270 IF (PT+2.GE.PB) GO TO 100 ! 4389: STACK(PT) = K ! 4390: STACK(PT+1) = I1 ! 4391: PT = PT + 2 ! 4392: PREVOP = CUROP ! 4393: PSTMT = K2 ! 4394: GO TO 10 ! 4395: C ! 4396: C ARE PROCESSING A CONSTANT ! 4397: C ! 4398: 280 I1 = CUROP ! 4399: K = 0 ! 4400: GO TO 270 ! 4401: C ! 4402: C ARE PROCESSING AN OPERATER ! 4403: C PRE(I,J) CONTAINS ACTION TAKEN GIVEN OPERATOR I ON STACK ! 4404: C AND OPERATOR J IN INPUT ! 4405: C ! 4406: 290 KNAME = K ! 4407: IF (CUROP.EQ.15 .OR. CUROP.EQ.16) PARENS = PARENS + 1 ! 4408: IF (CUROP.EQ.12) PARENS = PARENS - 1 ! 4409: IF (PARENS.GE.0) GO TO 300 ! 4410: FLUSH = .TRUE. ! 4411: GO TO 30 ! 4412: C ! 4413: C CHECKS FOR LEADING UNARY +,- IN EXPRESSIONS ! 4414: C ! 4415: 300 IF (PB.EQ.LSTACK) GO TO 460 ! 4416: I = STACK(PB+1) - 10 ! 4417: I2 = CUROP - 10 ! 4418: K = PRE(I,I2) ! 4419: 310 IF (-1.NE.K) GO TO 320 ! 4420: FLUSH = .TRUE. ! 4421: GO TO 90 ! 4422: 320 GO TO (330, 470, 520, 480, 480, 490, 510), K ! 4423: C ! 4424: C CREATE TEMPLATE FROM FCN CALL ! 4425: C ! 4426: 330 IF (ITYP.EQ.18 .AND. PARENS.EQ.0) CALLST = .TRUE. ! 4427: L1 = STACK(PB+2) ! 4428: L2 = PT - 1 ! 4429: C ! 4430: C CHECK FOR NO ARGS ! 4431: C ! 4432: IF (L2.GT.L1) GO TO 340 ! 4433: CALL ERROR1(18H MISSING ARGUMENTS, 18) ! 4434: GO TO 450 ! 4435: C ! 4436: C CHECK FOR NOT CHANGING THROUGH SUBROUTINE CALL THE DO CONTROL ! 4437: C VARIABLE OF A CURRENT LOOP OR ANY ADJUSTIBLE DIMENSION DUMMY ARG ! 4438: C ! 4439: 340 DO 380 I=L1,L2,2 ! 4440: IF (STACK(I)) 350, 380, 350 ! 4441: 350 IF (DOVAR(STACK(I))) STACK(I+1) = STACK(I+1) + 32 ! 4442: I1 = IGATT1(STACK(I),4) ! 4443: IF (I1) 380, 380, 360 ! 4444: 360 I1 = IGATT1(STACK(I),6) ! 4445: IF (I1) 380, 380, 370 ! 4446: 370 STACK(I+1) = STACK(I+1) + 64 ! 4447: 380 CONTINUE ! 4448: C ! 4449: C CHECK FOR USE OF ID AS FCN ONCE AND AS SUBROUTINE LATER ! 4450: C OR VICE VERSA ! 4451: C ! 4452: I = STACK(PB+3) ! 4453: L = IGATT1(I,8) ! 4454: IF (L.EQ.2 .OR. L.EQ.5 .OR. L.EQ.6) GO TO 410 ! 4455: IF (.NOT.INTEXT(I,L1,L2,.TRUE.)) GO TO 390 ! 4456: C ! 4457: C FOUND AN INTRINSIC FCN ! 4458: C CHECK NOT IN A CALL STMT USED AS A SUBROUTINE ! 4459: C ! 4460: IF (CALLST) GO TO 420 ! 4461: GO TO 450 ! 4462: C ! 4463: C DEFINE FCN( USAGE IF UNSET ! 4464: C SET USAGE OF ID USED AS A PROC ! 4465: C ! 4466: 390 IF (CALLST) GO TO 400 ! 4467: CALL SATT1(I, 8, 5) ! 4468: GO TO 430 ! 4469: 400 CALL SATT1(I, 8, 6) ! 4470: GO TO 430 ! 4471: C ! 4472: C CHECK USAGE OF PROC ALREADY USED IN PROGRAM UNIT ! 4473: C ! 4474: 410 IF (CALLST .AND. L.EQ.6 .OR. .NOT.CALLST .AND. (L.EQ.5 .OR. ! 4475: * L.EQ.2)) GO TO 430 ! 4476: 420 CALL ERROR1(18H ILLEGAL REFERENCE, 18) ! 4477: GO TO 450 ! 4478: 430 IF (.NOT.OPT(3) .OR. P1ERR) GO TO 450 ! 4479: C ! 4480: C LOAD INTO STACK COUNT OF WORDS IN DESCRIPTOR, INDEX OF FCN ! 4481: C IN SYMBOL TABLE, STMT NO OF REFERENCE ! 4482: C ! 4483: IF (PT+3.GE.PB) GO TO 100 ! 4484: STACK(PT) = PT - STACK(PB+2) ! 4485: STACK(PT+1) = STACK(PB+3) ! 4486: STACK(PT+2) = NOST ! 4487: STACK(PT+3) = 6 - IGATT1(STACK(PB+3),8) ! 4488: L3 = PT + 3 ! 4489: ICOD = 2 ! 4490: L = L2 - L1 + 5 ! 4491: IF (L.LE.LREF) GO TO 440 ! 4492: CALL ERROR1(44H IN EXPR, TABLE OVERFLOW OF REF, REF IGNORED, 44) ! 4493: GO TO 450 ! 4494: 440 WRITE (OUTUT3) L, ICOD, (STACK(I),I=PT,L3), (STACK(I),I=L1,L2) ! 4495: C ! 4496: C FCN REF POPPED AND PROPER TYPE PUT ON OPERAND STACK ! 4497: C ! 4498: 450 PT = STACK(PB+2) ! 4499: I1 = IGATT1(STACK(PB+3),1) ! 4500: STACK(PT) = 0 ! 4501: STACK(PT+1) = MOD(I1,8) ! 4502: PT = PT + 2 ! 4503: PB = PB + 3 ! 4504: GO TO 520 ! 4505: C ! 4506: C HANDLES FIRST OPERATOR IN EXPRESSION--WILL ALWAYS BE PUSHED ONTO ! 4507: C OPERATOR STACK. FCN( HAS SPECIAL PUSH. ! 4508: C ! 4509: 460 IF (CUROP.NE.16) GO TO 480 ! 4510: C ! 4511: C FOUND "FCN(" CONSTRUCT ; STORE 3 THINGS IN STACK ! 4512: C PTR TO FCN NAME IN SYMBOL TABLE; PTR TO 1ST ARGE IN STACK ; ! 4513: C OPERAND CODE FOR FCN( ! 4514: C ! 4515: 470 IF (PB-3.LE.PT) GO TO 100 ! 4516: STACK(PB) = KNAME ! 4517: STACK(PB-1) = PT ! 4518: STACK(PB-2) = CUROP ! 4519: PB = PB - 3 ! 4520: GO TO 520 ! 4521: C ! 4522: C SIMPLE PUSH ONTO OPERATOR STACK ! 4523: C ! 4524: 480 IF (PB-1.EQ.PT) GO TO 100 ! 4525: STACK(PB) = CUROP ! 4526: PB = PB - 1 ! 4527: GO TO 520 ! 4528: C ! 4529: C POP OPERATOR FROM STACK. IF STACK EMPTY, PUSH CUROP ONTO ! 4530: C STACK. ELSE TAKE ACTION SPECIFIED BY PRE(TOP OPERATOR,CUROP). ! 4531: C ! 4532: 490 CALL POP ! 4533: IF (ERR) GO TO 530 ! 4534: IF (PB.LT.LSTACK) GO TO 500 ! 4535: GO TO 480 ! 4536: 500 I = STACK(PB+1) - 10 ! 4537: K = PRE(I,CUROP-10) ! 4538: GO TO 310 ! 4539: C ! 4540: C POP "(" WHEN HAVE FINISHED A PARENTHESIZED EXPRESSION ! 4541: C ! 4542: 510 CALL POP ! 4543: IF (ERR) GO TO 530 ! 4544: C ! 4545: C UPDATE PREVOP,PSTMT AFTER FINISHING PROCESSING AN OPERATOR ! 4546: C ! 4547: 520 PREVOP = CUROP ! 4548: PSTMT = K2 ! 4549: GO TO 10 ! 4550: C ! 4551: C JOB OF THIS CODE IS TO FLISH TO END OF UNRECOGNIZABLE ! 4552: C EXPRESSION ! 4553: C ! 4554: 530 K2 = PSTMT ! 4555: ERR = .FALSE. ! 4556: 540 IF (K2.GE.NSTMT) GO TO 80 ! 4557: IF (STMT(K2).EQ.65) PARENS = PARENS + 1 ! 4558: IF (STMT(K2).NE.62) GO TO 550 ! 4559: PARENS = PARENS - 1 ! 4560: IF (PARENS.EQ.0) GO TO 560 ! 4561: 550 K2 = K2 + 1 ! 4562: GO TO 540 ! 4563: 560 I = GETTOK(K2,I2) ! 4564: K2 = I2 ! 4565: IF ((I.EQ.1 .OR. I.EQ.6) .OR. ERR) GO TO 80 ! 4566: GO TO 540 ! 4567: END ! 4568: C XXXXXINSTMT.f ! 4569: SUBROUTINE INSTMT(EOF, NCARD) ! 4570: LOGICAL ILLEG, ILHOL, ILCONT ! 4571: LOGICAL NEWRD, EOF, CONT, OPT, P1ERR ! 4572: INTEGER PSTMT, CARD(80), OUTUT, BLK, STATE, HCOUNT, STMT ! 4573: INTEGER SYMLEN, OUTUT2, OUTUT3, OUTUT4 ! 4574: DIMENSION IBR(5) ! 4575: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 4576: COMMON /OPTNS/ OPT(5), P1ERR ! 4577: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, ! 4578: * OUTUT4 ! 4579: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 4580: DATA NEWRD /.TRUE./ ! 4581: DATA IBR(1), IBR(2), IBR(3), IBR(4), IBR(5) /1H*,1HC,1H.,1H0,1H / ! 4582: DATA CARD(1) /1H / ! 4583: C ! 4584: C ROUTINE INPUTS AN ENTIRE FORTRAN STATEMENT. IT IS PASSED 1 CHAR ! 4585: C PER ELEMENT IN THE ARRAY STMT. ! 4586: C IN SHOULD BE CALLED AGAIN IF ERR IS TRUE. ! 4587: C EACH CARD IS WRITTEN OUT BEFORE BEING PARSED. ! 4588: C IN DEBLANKS CARDS USES THE VARIABLE STATE TO FIND ! 4589: C HOLLERITHS: ! 4590: C STATE = 0.....LOOK FOR BREAK CHAR ! 4591: C 1.....HAVE BREAK CHAR AND NEED DIGIT ! 4592: C 2.....HAVE DIGIT AND NEED DIGIT OR "H" ! 4593: C 3....NEED TO SKIP OVER THESE CHARS, PART OF HOLLERITH ! 4594: C NOTE: USE "90" AS AN END OF STMT MARKER ! 4595: C ! 4596: C NEWRD IS TRUE IF A NEW CARD IS NECESSARY; ELSE CARD IN BUFFER ! 4597: C IS USED. EOF IS TRUE WHEN END-OF-FILE CARD ("." IN COL 1) ! 4598: C IS READ NCARD GIVES # OF CARDS READ FOR THIS STMT ! 4599: C ! 4600: 10 NOST = NOST + 1 ! 4601: STATE = 0 ! 4602: NSTMT = 0 ! 4603: ILLEG = .FALSE. ! 4604: ILCONT = .FALSE. ! 4605: ILHOL = .FALSE. ! 4606: NCARD = 0 ! 4607: CONT = .FALSE. ! 4608: 20 IF (NEWRD) CALL IN(CARD, INUT) ! 4609: IF (CARD(1).NE.IBR(2) .OR. CARD(2).NE.IBR(1)) GO TO 40 ! 4610: C ! 4611: C DEAL WITH OPTIONS CARD ! 4612: C ! 4613: IF (CONT) GO TO 50 ! 4614: CALL INOPT(CARD) ! 4615: 30 IF (OPT(4)) WRITE (OUTUT,99999) CARD ! 4616: 99999 FORMAT (11X, 80A1) ! 4617: NEWRD = .TRUE. ! 4618: GO TO 20 ! 4619: 40 IF (CARD(1).NE.IBR(2)) GO TO 70 ! 4620: C ! 4621: C DEAL WITH COMMENT CARD ! 4622: C ! 4623: IF (.NOT.CONT) GO TO 30 ! 4624: C ! 4625: C HAVE COMPLETED STMT ! 4626: C ! 4627: 50 NEWRD = .FALSE. ! 4628: NSTMT = NSTMT + 1 ! 4629: STMT(NSTMT) = 90 ! 4630: 60 IF (ILLEG) CALL ERROR1( ! 4631: * 40H WARNING - NON-FORTRAN CHARACTER IGNORED, 40) ! 4632: IF (ILHOL) CALL ERROR1( ! 4633: * 46H WARNING - NON-FORTRAN CHARACTER IN HOLLERITH , 46) ! 4634: IF (ILCONT) CALL ERROR1( ! 4635: * 45H WARNING - NON-FORTRAN CONTINUATION CHARACTER, 45) ! 4636: RETURN ! 4637: 70 IF (CARD(1).NE.IBR(3)) GO TO 80 ! 4638: C ! 4639: C HAVE EOF ! 4640: C ! 4641: IF (CONT) GO TO 50 ! 4642: EOF = .TRUE. ! 4643: GO TO 60 ! 4644: 80 IF (CARD(6).EQ.IBR(4) .OR. CARD(6).EQ.IBR(5)) GO TO 100 ! 4645: C ! 4646: C DEAL WITH CONTINUATION CARD ! 4647: C ! 4648: II = MAPCHR(CARD(6),ILCONT) ! 4649: IF (CONT) GO TO 110 ! 4650: CALL ERROR1(40H WARNING - CONTINUATION NOT ALLOWED HERE, 40) ! 4651: C ! 4652: C FLUSH TO NEXT NONCONTINUATION CARD ! 4653: C ! 4654: 90 IF (OPT(4)) WRITE (OUTUT,99998) NOST, CARD ! 4655: 99998 FORMAT (1H , I5, 5X, 80A1) ! 4656: CALL IN(CARD, INUT) ! 4657: IF (CARD(1).NE.IBR(1) .AND. CARD(1).NE.IBR(2) .AND. ! 4658: * CARD(1).NE.IBR(3) .AND. CARD(6).NE.IBR(4) .AND. ! 4659: * CARD(6).NE.IBR(5)) GO TO 90 ! 4660: NEWRD = .FALSE. ! 4661: GO TO 10 ! 4662: C ! 4663: C DEAL WITH A NON-CONTINUATION CARD ! 4664: C ! 4665: 100 IF (CONT) GO TO 50 ! 4666: C DEAL WITH A LEGAL CONTIN OR NONCONTIN CARD ! 4667: 110 NCARD = NCARD + 1 ! 4668: IF (NCARD.LT.21) GO TO 120 ! 4669: CALL ERROR1(33H WARNING - TOO MANY CONTINUATIONS, 33) ! 4670: GO TO 90 ! 4671: 120 IF (OPT(4)) WRITE (OUTUT,99998) NOST, CARD ! 4672: NEWRD = .TRUE. ! 4673: BLK = 0 ! 4674: IF (NSTMT.NE.0) GO TO 150 ! 4675: DO 130 I=1,5 ! 4676: NSTMT = NSTMT + 1 ! 4677: STMT(NSTMT) = MAPCHR(CARD(I),ILLEG) ! 4678: 130 CONTINUE ! 4679: 140 I = 7 ! 4680: GO TO 180 ! 4681: 150 DO 160 I=1,5 ! 4682: IF (MAPCHR(CARD(I),ILLEG).NE.69) GO TO 170 ! 4683: 160 CONTINUE ! 4684: GO TO 140 ! 4685: 170 CALL ERROR1(40H WARNING - ILLEGAL LABEL WILL BE IGNORED, 40) ! 4686: GO TO 140 ! 4687: 180 IF (I.LE.72) GO TO 200 ! 4688: C ! 4689: C AFTER TRANSLATE CARD CHECK FOR BLANK CARD ! 4690: C AND GO BACK FOR A CONTINUATION CARD ! 4691: C ! 4692: IF (BLK.NE.66) GO TO 190 ! 4693: CALL ERROR1(33H WARNING - BLANK CARD ENCOUNTERED, 33) ! 4694: GO TO 90 ! 4695: 190 CONT = .TRUE. ! 4696: GO TO 20 ! 4697: 200 IF (STATE.NE.3) GO TO 210 ! 4698: C ! 4699: C STATE 3 --ARE PROCESSING A HOLLERITH ! 4700: C ! 4701: HCOUNT = HCOUNT - 1 ! 4702: KK = MAPCHR(CARD(I),ILHOL) ! 4703: IF (HCOUNT.EQ.0) STATE = 0 ! 4704: GO TO 290 ! 4705: 210 NSTMT = NSTMT + 1 ! 4706: STMT(NSTMT) = MAPCHR(CARD(I),ILLEG) ! 4707: IF (STMT(NSTMT).NE.69) GO TO 220 ! 4708: C ! 4709: C BLANK ENCOUNTERED AND DELETED ! 4710: C ! 4711: BLK = BLK + 1 ! 4712: NSTMT = NSTMT - 1 ! 4713: GO TO 290 ! 4714: 220 KK = STATE + 1 ! 4715: GO TO (280, 260, 230), KK ! 4716: C ! 4717: C STATE 2--SKIP OVER LEADING DIGIT STRING; LOOK FOR H ! 4718: C ! 4719: 230 IF (STMT(NSTMT).LE.9) GO TO 290 ! 4720: IF (STMT(NSTMT).NE.37) GO TO 270 ! 4721: C ! 4722: C PROCESS HOLLERITH COUNT ! 4723: C ! 4724: STMT(NSTMT) = -STMT(NSTMT) ! 4725: STATE = 3 ! 4726: KK = NSTMT - KST ! 4727: I10 = 1 ! 4728: HCOUNT = 0 ! 4729: DO 240 K=1,KK ! 4730: JJ = NSTMT - K ! 4731: HCOUNT = HCOUNT + I10*STMT(JJ) ! 4732: I10 = I10*10 ! 4733: 240 CONTINUE ! 4734: STMT(KST) = HCOUNT - 2048 ! 4735: NSTMT = KST ! 4736: IF (HCOUNT.LE.0) GO TO 250 ! 4737: GO TO 290 ! 4738: C ! 4739: C AVOID THE 0H CONSTRUCTION ! 4740: C ! 4741: 250 CALL ERROR1(44H WARNING - 0H ILLEGAL HOLLERITH CONSTRUCTION, 44) ! 4742: STATE = 0 ! 4743: GO TO 290 ! 4744: C ! 4745: C STATE 1--LOOK FOR START OF DIGIT STRING BEFORE H ! 4746: C ! 4747: 260 IF (STMT(NSTMT).GT.9) GO TO 270 ! 4748: STATE = 2 ! 4749: KST = NSTMT ! 4750: GO TO 290 ! 4751: C ! 4752: C CHECK FOR NESTED SPECIAL HEADING CHARS ! 4753: C ! 4754: 270 STATE = 0 ! 4755: 280 IF ((STMT(NSTMT).LT.65) .OR. (STMT(NSTMT).GT.68)) GO TO 290 ! 4756: STATE = 1 ! 4757: 290 I = I + 1 ! 4758: GO TO 180 ! 4759: END ! 4760: C XXXXXIN.f ! 4761: SUBROUTINE IN(CARD, INUT) ! 4762: C ! 4763: INTEGER CARD(80) ! 4764: LOGICAL EOF ! 4765: C ! 4766: DATA EOF /.FALSE./ ! 4767: DATA IDOT /1H./ ! 4768: C ! 4769: IF (EOF) RETURN ! 4770: C ! 4771: C READ A CARD. PHYSICAL EOF SHOULD TRANSFER TO 100 ! 4772: C ! 4773: READ (INUT,99999) CARD ! 4774: 99999 FORMAT (80A1) ! 4775: IF (CARD(1).NE.IDOT) RETURN ! 4776: C ! 4777: C HERE FOR EOF ! 4778: C ! 4779: 100 CARD(1) = IDOT ! 4780: EOF = .TRUE. ! 4781: C ! 4782: RETURN ! 4783: END ! 4784: C XXXXXINOPT.f ! 4785: SUBROUTINE INOPT(CARD) ! 4786: INTEGER S(8), CARD(80), J(5) ! 4787: LOGICAL OPT, P1ERR ! 4788: COMMON /OPTNS/ OPT(5), P1ERR ! 4789: DATA S(1), S(2), S(3), S(4), S(5), S(6), S(7) /1HS,1HR,1HP,1HL, ! 4790: * 1HC,1H,,1HN/, S(8) /1H / ! 4791: C ! 4792: C OPT(1) IF TRUE, PRINT SYMBOL TABLE ! 4793: C IF FALSE, NOSYMBOL TABLE PRINTED ! 4794: C OPT(2) IF TRUE, PRINT CROSS REFERENCES ! 4795: C IF FALSE, NO REFS PRINTED ! 4796: C OPT(3) IF TRUE, DO PASS 2; ELSE DO NOT ! 4797: C OPT(4) IF TRUE GET LISTING OF PGM; ELSE DO NOT ! 4798: C OPT(5) IF TRUE, COMPILE PGM AFTER PROCESSING; ELSE DO NOT ! 4799: C SET OPTIONS FROM CARD READ IN BY "IN" ! 4800: C P2 IS TURNED OFF ONLY ONCE A RUN; IT CANNOT BE TURNED ON AGAIN ! 4801: C OPTIONS CARD IS ONLY ACCEPTED IF SYNTAX ON CARD IS OK ! 4802: C SYNTAX IS C* FOLLOWED BY AT LEAST ONE OPTION OF THEFORM ! 4803: C OPT BLANKS, OPT N, AT LEAST ONE OF (S,R,P,L,C), OPT BLANKS ! 4804: C WHERE OPTIONS ARE SEPARATEDBY COMMAS ! 4805: C ! 4806: DO 10 I=1,5 ! 4807: J(I) = 0 ! 4808: 10 CONTINUE ! 4809: IP = 2 ! 4810: 20 IP = IP + 1 ! 4811: IF (IP.GE.73) GO TO 60 ! 4812: C DEBLANK LEADING BLANKS ! 4813: IF (CARD(IP).EQ.S(8)) GO TO 20 ! 4814: L = 1 ! 4815: C ! 4816: C CHECK FOR NEGATIVE ! 4817: C ! 4818: IF (CARD(IP).NE.S(7)) GO TO 30 ! 4819: L = -1 ! 4820: IP = IP + 1 ! 4821: IF (IP.GE.73) GO TO 60 ! 4822: 30 DO 40 I=1,5 ! 4823: IF (S(I).NE.CARD(IP)) GO TO 40 ! 4824: J(I) = J(I) + L ! 4825: GO TO 50 ! 4826: 40 CONTINUE ! 4827: GOTO 100 ! 4828: C ! 4829: C FLUSH BLANKS TO NEXT COMMA ! 4830: C ! 4831: 50 IP = IP + 1 ! 4832: IF (IP.GE.73) GO TO 60 ! 4833: IF (CARD(IP).EQ.S(6)) GO TO 20 ! 4834: IF(CARD(IP).NE.S(8)) GOTO 100 ! 4835: GO TO 50 ! 4836: 60 DO 90 K=1,5 ! 4837: IF (J(K)) 70, 90, 80 ! 4838: 70 OPT(K) = .FALSE. ! 4839: GO TO 90 ! 4840: C DO NOT LET USER TURN ON PASS2 AFTER WE TURN IT OFF ! 4841: 80 IF (K.EQ.3 .AND. .NOT.OPT(3)) GO TO 90 ! 4842: OPT(K) = .TRUE. ! 4843: 90 CONTINUE ! 4844: 100 RETURN ! 4845: END ! 4846: C XXXXXLIST.f ! 4847: SUBROUTINE LIST ! 4848: INTEGER STMT, PSTMT ! 4849: LOGICAL ERR, SYSERR, ABORT, IDLIST, IDO, FINDO ! 4850: LOGICAL SIO ! 4851: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 4852: COMMON /DETECT/ ERR, SYSERR, ABORT ! 4853: COMMON /LISTDO/ LPT, LEN, LS(64) ! 4854: C ! 4855: C ROUTINE PROCESSES THE LIST CONSTRUCT, USED IN I-O STMTS ! 4856: C LEV USED TO COUNT PARENTHESES LEVELS ! 4857: C ! 4858: SIO = .FALSE. ! 4859: LPT = LEN + 1 ! 4860: FINDO = .FALSE. ! 4861: ICNT = 0 ! 4862: LEV = 0 ! 4863: 10 IF (STMT(PSTMT).NE.65) GO TO 20 ! 4864: LEV = LEV + 1 ! 4865: IF (LEV.GT.ICNT) ICNT = ICNT + 1 ! 4866: PSTMT = PSTMT + 1 ! 4867: GO TO 10 ! 4868: 20 IF (PSTMT.GE.NSTMT) GO TO 120 ! 4869: C ! 4870: C ALLOW <ID>=ARRAY,ARRAY ELE., VARIABLE ! 4871: C ! 4872: IF (.NOT.IDLIST(IDO)) GO TO 130 ! 4873: C ! 4874: C FALSE RETURN SIGNIFIES ERROR IN IDLIST ! 4875: C TRUE RETURN SIGNIFIES NO ERROR IN IDLIST ! 4876: C IDO = .TRUE. MEANS , <DOSPEC> IS NEXT ! 4877: C IDO = .FALSE. MEANS AT END-OF-STMT, ", (" , OR ")" ! 4878: C ! 4879: C FOUND <DOSPEC> ) ! 4880: C ! 4881: IF (SYSERR) GO TO 130 ! 4882: IF (.NOT.IDO) GO TO 30 ! 4883: PSTMT = PSTMT + 1 ! 4884: GO TO 100 ! 4885: C ! 4886: C FOUND END OF SIMPLE LIST "( <IDLIST> )" ! 4887: C ! 4888: 30 IF (STMT(PSTMT).EQ.62) GO TO 60 ! 4889: 40 IF (PSTMT.NE.NSTMT) GO TO 50 ! 4890: C ! 4891: C AT END OF STMT ! 4892: C ! 4893: IF (FINDO) CALL LDOVAR ! 4894: IF (LEV.NE.0) GO TO 120 ! 4895: GO TO 130 ! 4896: C ! 4897: C NEED "," AND NEW <LIST> CONSTRUCT ! 4898: C ! 4899: 50 IF (STMT(PSTMT).NE.68) GO TO 120 ! 4900: PSTMT = PSTMT + 1 ! 4901: GO TO 10 ! 4902: C ! 4903: C MUST CHECK FOR ILLEGALLY NESTED SIMPLE LISTS ! 4904: C SIMPLE LIST= ( <IDLIST> ) ! 4905: C ICNT COUNTAINS LEVEL OF LAST SIMPLE LIST WITHIN A ! 4906: C PARENTHESIZED EXPRESSION ! 4907: C ! 4908: 60 SIO = .TRUE. ! 4909: IF (LEV.EQ.0) GO TO 120 ! 4910: PSTMT = PSTMT + 1 ! 4911: IF (ICNT.LE.LEV) GO TO 80 ! 4912: 70 CALL ERROR1(28H ILLEGAL PARENTHESES NESTING, 28) ! 4913: GO TO 130 ! 4914: 80 LEV = LEV - 1 ! 4915: IF (LEV) 120, 110, 90 ! 4916: C ! 4917: C CHECK FOR CONSTRUCT FOLLOWING <DOSPEC> ! 4918: C ! 4919: 90 IF (STMT(PSTMT).EQ.62) GO TO 70 ! 4920: IF (STMT(PSTMT).NE.68) GO TO 120 ! 4921: CALL NEXTOK(PSTMT+1, K2, K) ! 4922: IF (K.NE.0 .OR. STMT(K2).NE.63) GO TO 40 ! 4923: PSTMT = PSTMT + 1 ! 4924: C ! 4925: C LOOK FOR DOSPEC ! 4926: C ! 4927: 100 CALL DOSPEC(0, K2, .TRUE.) ! 4928: IF (SYSERR .OR. ERR) GO TO 130 ! 4929: FINDO = .TRUE. ! 4930: IF (STMT(K2).NE.62) GO TO 120 ! 4931: PSTMT = K2 + 1 ! 4932: IF (ICNT.GT.LEV) ICNT = ICNT - 1 ! 4933: GO TO 80 ! 4934: C ! 4935: C CHECK NESTED DOSPECS IN LIST ! 4936: C ! 4937: 110 IF (LEV.NE.0 .OR. .NOT.FINDO) GO TO 40 ! 4938: FINDO = .FALSE. ! 4939: CALL LDOVAR ! 4940: LPT = LEN + 1 ! 4941: GO TO 40 ! 4942: 120 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20) ! 4943: IF (FINDO) CALL LDOVAR ! 4944: 130 IF (SIO) CALL ERROR1(34H REDUNDANT PARENTHESES ARE ILLEGAL, 34) ! 4945: RETURN ! 4946: END ! 4947: C XXXXXLOOKUP.f ! 4948: INTEGER FUNCTION LOOKUP(K1, LABEL) ! 4949: C ! 4950: C STMT(PSTMT)-STMT(K2-1) TO BE ENTERED IN DSA ! 4951: C LABEL IS TRUE IF SYMBOL IS A LABEL. ROUTINE ! 4952: C RETURNS VALUE OF INDEX OF SYMBOL IN DSA, CREATING ! 4953: C A NEW ENTRY ID NESESSARY. IT ENTERS SYMBOL INTO ! 4954: C SYMBOL OR LABEL CHAIN AND CREATES A CROSSREFERENCE ! 4955: C ENTRY FOR THE CURRENT STATMT NUMBER ! 4956: C ! 4957: INTEGER PSTMT, SYMLEN, DSA, HASH, L(6), LL(6) ! 4958: INTEGER BLANK, SYMHD, STMT, OUTUT, BNEXT, Q(70) ! 4959: INTEGER PDSA, OUTUT2, OUTUT3, OUTUT4 ! 4960: LOGICAL LABEL, ERR, P1ERR, OPT, SYSERR, ABORT ! 4961: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, ! 4962: * OUTUT4 ! 4963: COMMON /DETECT/ ERR, SYSERR, ABORT ! 4964: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 4965: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 4966: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 4967: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 4968: COMMON /CHASH/ LHASH, HASH(401) ! 4969: COMMON /TRANS/ Q ! 4970: COMMON /OPTNS/ OPT(5), P1ERR ! 4971: DATA BLANK /1H / ! 4972: K = K1 - PSTMT ! 4973: IF (K.LE.6) GO TO 10 ! 4974: CALL ERROR1(39H IDENTIFIER TOO LONG, WILL BE TRUNCATED, 39) ! 4975: K = 6 ! 4976: 10 KK = K ! 4977: DO 20 I=1,K ! 4978: II = PSTMT + I - 1 ! 4979: J = STMT(II) + 1 ! 4980: LL(I) = Q(J) ! 4981: 20 CONTINUE ! 4982: DO 30 I=1,SYMLEN ! 4983: L(I) = BLANK ! 4984: 30 CONTINUE ! 4985: CALL S5PACK(LL, L, K) ! 4986: C ! 4987: C HAVE PACKED SYMBOL;NOW CALCULATE HASH ! 4988: C HASH IS(PRODUCT OF FIRST AND THIRD LETTERS PLUS SECOND) MOD 257 ! 4989: C ! 4990: IF (KK.LT.3) GO TO 50 ! 4991: IHASHS = STMT(PSTMT)*STMT(PSTMT+2) + STMT(PSTMT+1) ! 4992: 40 IHASHS = MOD(IHASHS,LHASH) ! 4993: ISAVE = IHASHS ! 4994: IHASH = IHASHS + 1 ! 4995: GO TO 80 ! 4996: 50 IHASHS = STMT(PSTMT) ! 4997: GO TO (60, 70), KK ! 4998: 60 IHASHS = IHASHS*69 + 69 ! 4999: GO TO 40 ! 5000: 70 IHASHS = IHASHS*69 + STMT(PSTMT+1) ! 5001: GO TO 40 ! 5002: 80 IF (HASH(IHASH).EQ.0) GO TO 140 ! 5003: C ! 5004: C IF TABLE EMPTY, CREATE ENTRY, SEND BACK INDEX OF FIRST WORD IN DSA ! 5005: C ELSE COMPARE SYMBOL TO ID AND RETURN INDEX OF PROPER ENTRY IN HASH ! 5006: C TABLE AFTER RESOLVING COLLISION ! 5007: C ! 5008: DO 90 J=1,SYMLEN ! 5009: II = HASH(IHASH) + 3 + J ! 5010: IF (L(J).NE.DSA(II)) GO TO 100 ! 5011: 90 CONTINUE ! 5012: LOOKUP = HASH(IHASH) ! 5013: IF (DSA(LOOKUP+1)) 190, 190, 200 ! 5014: C ! 5015: C RESOLVE CONFLICTS BY LINEAR CONGRUENCE ! 5016: C ! 5017: 100 IHASHS = MOD(IHASHS+1,LHASH) ! 5018: IF (IHASHS.EQ.ISAVE) GO TO 110 ! 5019: IHASH = IHASHS + 1 ! 5020: GO TO 80 ! 5021: 110 CALL ERROR1(34H IN LOOKUP, TABLE OVERFLOW OF HASH, 34) ! 5022: 120 SYSERR = .TRUE. ! 5023: RETURN ! 5024: 130 CALL ERROR1(33H IN LOOKUP, TABLE OVERFLOW OF DSA, 33) ! 5025: GO TO 120 ! 5026: C ! 5027: C CREATE NEW SYMBOL TABLE ENTRY; ZERO ITS CROSSREF TAIL PTR ! 5028: C ! 5029: 140 HASH(IHASH) = NEXT ! 5030: IF (NEXT+6+SYMLEN.GE.BNEXT) GO TO 130 ! 5031: LOOKUP = NEXT ! 5032: C ! 5033: C*****DSA ! 5034: C 1ST WORD..... ATTRIBUTE WORD ! 5035: C FIELD 1 ! 5036: C ! 5037: C BITS 0-2*TYPE (FOR SYMBOL) 0 DOUBLE PRECISION, 1 REAL, 2 INT, ! 5038: C 3 COMPLEX,4 LOGICAL, 5 HOLLERITH ! 5039: C TYPE (FOR LABEL) 1 EXECUTABLE STMT, 2 NONEXEC. STMT, ! 5040: C 3 FORMAT STMT ! 5041: C BIT 3****EXPLICITLY TYPED 1, IMPLICITLY 0 ! 5042: C FIELD 2 ! 5043: C BIT 4****(FOR SYMBOL) IN COMMON 1, NOT IN COMMON 0 ! 5044: C (FOR LABEL) DEFINED 1, REFERENCED 0 ! 5045: C (FOR COMMON-NAME) INITIALIZED IN BLOCK DATA SUBPGM ! 5046: C FIELD 3 ! 5047: C BIT 5****EQUIVALENCED 1 ! 5048: C FIELD 4 ! 5049: C BIT 6****DUMMY SUBROUTINE/FUNCTION ARGUMENT 1 ! 5050: C FIELD 5 ! 5051: C BIT 7****VALUE SET BY P.U. 1 ! 5052: C FIELD 6 ! 5053: C BIT 8****VARIABLE USED AS DIMENSION IN VARIABLY DIMENSIONED ARRAY ! 5054: C FIELD 7 ! 5055: C BIT 9-10*SCALAR 0, NUMBER OF ARRAY BOUNDS 1,2,3 ! 5056: C FIELD 8 ! 5057: C BITS 11-15**USAGE--UNSET 0, ASF ARG 1, ASF FCN 2, CURRENT P. U.= ! 5058: C SUBR 3, CURRENT P.U.=FCN 4, EXTERNAL FCN 5, EXTERNAL SUBR 6, ! 5059: C COMMON-NAME 7, ASSIGN/GOTO VARIABLE 8,LABEL 9, VARIABLE 10, ! 5060: C CURRENT P.U.=BLOCK DATA 11, CURRENT P.U.=MAIN 12, EXTERNAL ENTITY ! 5061: C 13, INTRINSIC FCN 14 ! 5062: C BITS 5-8 ARE 0 IF ENTRY CORRESPONDS TO ENTITY WITHOUT THE ! 5063: C ATTRIBUTE MENTIONED ! 5064: C ! 5065: C 2ND WD..... XREF LIST TAIL POINTER ! 5066: C 3D WORD.....EXTRA INFO POINTER ! 5067: C ! 5068: C FOR A VARIABLE, 3D WORD POINTS TO A 2 WORD BLOCK, FIRST WORD ! 5069: C CONTAINING STORAGE UNIT LENGTH OF THE VARIABLE (-1 IF VARIABLY ! 5070: C DIMENSIONED ARRAY); SECOND WORD CONTAINING INDEX OF COMMON ! 5071: C ENTRY IN DSA; ! 5072: C FOR A LABEL, 3D WORD CONTAINS POINTER TO 2 WORD BLOCK ; AFTER ! 5073: C LABEL DEFINED, FIRST WORD CONTAINS STMT NUMBER OF FIRST STMT ! 5074: C IN CURRENT DO NESTING LEVEL; SECOND WORD CONTAINS NEGATIVE THE ! 5075: C NESTING LEVEL; WHEN END OF THIS NESTING LEVEL IS ENCOUNTERED ! 5076: C ALL 2ND WORDS FOR THAT LEVEL ARE UPDATED TO CONTAIN STMT NUMBER ! 5077: C OF LAST STMT AT THAT NESTING LEVEL; ! 5078: C FOR A COMMON-NAME, 3D WORD POINTS TO HEAD OF LINEAR LINKED LIST ! 5079: C OF INDICES OF DSA ENTRIES FOR ORDERED ELEMENTS IN THAT COMMON; ! 5080: C FOR THE CURRENT P.U. IF ITS A SUBR OR FCN, 3D WORD CONTAINS ! 5081: C A LINEAR LINKED LIST OF INDICES IN DSA OF ENTRIES FOR ORDERED ! 5082: C DUMMIES OF THAT SUBPGM; ! 5083: C ! 5084: C 4TH WORD..... CHAIN POINTER TO ENTRY IN DSA FOR LAST SYMBOL ! 5085: C OR LABEL FOR WHICH A NEW ENTRY WAS CREATED ! 5086: C 5-7TH WORD.....PACKED CHARACTERS OF SYMBOL OR LABEL ! 5087: C ! 5088: J = NEXT + 2 ! 5089: DO 150 I=NEXT,J ! 5090: DSA(I) = 0 ! 5091: 150 CONTINUE ! 5092: J = J + 1 ! 5093: DO 160 I=1,SYMLEN ! 5094: II = I + J ! 5095: DSA(II) = L(I) ! 5096: 160 CONTINUE ! 5097: C ! 5098: C SETONE OF THE CHAIN POINTERS TO PUT THIS SYMBOL ON CHAIN ! 5099: C ! 5100: IF (LABEL) GO TO 170 ! 5101: DSA(J) = SYMHD ! 5102: SYMHD = NEXT ! 5103: GO TO 180 ! 5104: 170 DSA(J) = LABHD ! 5105: LABHD = NEXT ! 5106: 180 NEXT = 4 + SYMLEN + NEXT ! 5107: C ! 5108: C BEGINNEW XREF LIST ! 5109: C ! 5110: 190 IF (.NOT.LABEL .AND. .NOT.OPT(2)) GO TO 210 ! 5111: IF (NEXT+2.GE.BNEXT) GO TO 130 ! 5112: DSA(BNEXT-1) = NOST ! 5113: DSA(LOOKUP+1) = BNEXT - 1 ! 5114: DSA(BNEXT) = BNEXT - 1 ! 5115: BNEXT = BNEXT - 2 ! 5116: GO TO 210 ! 5117: C ! 5118: C XREF LIST UPDATE; CHECK TO SEE IF STATEMENT NUMBER IS ALREADY ! 5119: C THERE ! 5120: C ! 5121: 200 IF (.NOT.LABEL .AND. .NOT.OPT(2)) GO TO 210 ! 5122: IF (NEXT+2.GE.BNEXT) GO TO 130 ! 5123: J = DSA(LOOKUP+1) ! 5124: IF (DSA(J).EQ.NOST) GO TO 210 ! 5125: DSA(BNEXT) = DSA(J+1) ! 5126: DSA(J+1) = BNEXT - 1 ! 5127: DSA(LOOKUP+1) = BNEXT - 1 ! 5128: DSA(BNEXT-1) = NOST ! 5129: BNEXT = BNEXT - 2 ! 5130: 210 RETURN ! 5131: END ! 5132: C XXXXXMAPCHR.f ! 5133: INTEGER FUNCTION MAPCHR(CHAR, ERR) ! 5134: C ! 5135: C MAPCHR RETURNS THE INTERNAL CODE OF THE CHARACTER CHAR ! 5136: C ! 5137: INTEGER CHAR ! 5138: INTEGER LET(46), ICODE(46) ! 5139: LOGICAL ERR ! 5140: C ! 5141: DATA LET(7), ICODE(7) /1H0,0/ ! 5142: DATA LET(16), ICODE(16) /1H1,1/ ! 5143: DATA LET(22), ICODE(22) /1H2,2/ ! 5144: DATA LET(24), ICODE(24) /1H3,3/ ! 5145: DATA LET(26), ICODE(26) /1H4,4/ ! 5146: DATA LET(28), ICODE(28) /1H5,5/ ! 5147: DATA LET(25), ICODE(25) /1H6,6/ ! 5148: DATA LET(38), ICODE(38) /1H7,7/ ! 5149: DATA LET(34), ICODE(34) /1H8,8/ ! 5150: DATA LET(32), ICODE(32) /1H9,9/ ! 5151: DATA LET(3), ICODE(3) /1HA,30/ ! 5152: DATA LET(36), ICODE(36) /1HB,31/ ! 5153: DATA LET(14), ICODE(14) /1HC,32/ ! 5154: DATA LET(6), ICODE(6) /1HD,33/ ! 5155: DATA LET(5), ICODE(5) /1HE,34/ ! 5156: DATA LET(33), ICODE(33) /1HF,35/ ! 5157: DATA LET(27), ICODE(27) /1HG,36/ ! 5158: DATA LET(37), ICODE(37) /1HH,37/ ! 5159: DATA LET(8), ICODE(8) /1HI,38/ ! 5160: DATA LET(44), ICODE(44) /1HJ,39/ ! 5161: DATA LET(46), ICODE(46) /1HK,40/ ! 5162: DATA LET(13), ICODE(13) /1HL,41/ ! 5163: DATA LET(12), ICODE(12) /1HM,42/ ! 5164: DATA LET(4), ICODE(4) /1HN,43/ ! 5165: DATA LET(2), ICODE(2) /1HO,44/ ! 5166: DATA LET(18), ICODE(18) /1HP,45/ ! 5167: DATA LET(43), ICODE(43) /1HQ,46/ ! 5168: DATA LET(11), ICODE(11) /1HR,47/ ! 5169: DATA LET(15), ICODE(15) /1HS,48/ ! 5170: DATA LET(10), ICODE(10) /1HT,49/ ! 5171: DATA LET(30), ICODE(30) /1HU,50/ ! 5172: DATA LET(42), ICODE(42) /1HV,51/ ! 5173: DATA LET(45), ICODE(45) /1HW,52/ ! 5174: DATA LET(39), ICODE(39) /1HX,53/ ! 5175: DATA LET(35), ICODE(35) /1HY,54/ ! 5176: DATA LET(41), ICODE(41) /1HZ,55/ ! 5177: DATA LET(31), ICODE(31) /1H+,60/ ! 5178: DATA LET(29), ICODE(29) /1H-,61/ ! 5179: DATA LET(19), ICODE(19) /1H),62/ ! 5180: DATA LET(23), ICODE(23) /1H=,63/ ! 5181: DATA LET(17), ICODE(17) /1H.,64/ ! 5182: DATA LET(20), ICODE(20) /1H(,65/ ! 5183: DATA LET(21), ICODE(21) /1H*,66/ ! 5184: DATA LET(40), ICODE(40) /1H/,67/ ! 5185: DATA LET(9), ICODE(9) /1H,,68/ ! 5186: DATA LET(1), ICODE(1) /1H ,69/ ! 5187: C ! 5188: DO 10 I=1,46 ! 5189: IF (CHAR.EQ.LET(I)) GO TO 20 ! 5190: 10 CONTINUE ! 5191: C ! 5192: C UNKNOWN, RETURN BLANK AND SET ERR = .TRUE. ! 5193: C ! 5194: MAPCHR = 69 ! 5195: ERR = .TRUE. ! 5196: RETURN ! 5197: C ! 5198: C KNOWN, RETURN INTERNAL CODE, LEAVE ERR ALONE ! 5199: C ! 5200: 20 MAPCHR = ICODE(I) ! 5201: RETURN ! 5202: END ! 5203: C XXXXXPU.f ! 5204: SUBROUTINE PU ! 5205: INTEGER STMT, PSTMT, SYMLEN, OUTUT, SYMHD, BNEXT, HASH, DSA ! 5206: INTEGER STACK, DOPT, DOLIST, PDSA, OUTUT2, OUTUT3, OUTUT4 ! 5207: INTEGER Q(70) ! 5208: LOGICAL ERR, BLKD, SYSERR, LOGIF1, LOGIF2, LAB, EOF ! 5209: LOGICAL NEW, TOKLAB, EXECUT, P1ERR, OPT, RET, ABORT ! 5210: LOGICAL P2, QBR ! 5211: COMMON /OPTNS/ OPT(5), P1ERR ! 5212: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327) ! 5213: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, ! 5214: * OUTUT4 ! 5215: COMMON /CEXPRS/ LSTACK, STACK(620) ! 5216: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 5217: COMMON /DETECT/ ERR, SYSERR, ABORT ! 5218: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 5219: COMMON /CHASH/ LHASH, HASH(401) ! 5220: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 5221: COMMON /DOS/ DOPT, LDO, DOLIST(192) ! 5222: COMMON /TRANS/ Q ! 5223: COMMON /PASS/ P2, QBR ! 5224: C ! 5225: C ROUTINE HANDLES CYCLING THROUGH STMTS OF A PGM UNIT. NEW IS ! 5226: C USED TO HANDLE P.U.'S WITHOUT END STMTS. FLUSHING OF STMTS ! 5227: C TO NEXT END OR HEADING STMT IS PROVIDED FOR ILLEGAL SEQUENCING ! 5228: C LOGIF1,LOGIF2 ARE USED TO CYCLE THROUGH LOGICAL IF STMTS ! 5229: C EOF OF INPUT FILE ! 5230: C ERR USED AS ERROR DIAGNOSTIC INDICATOR ! 5231: C NEWRD, NEW USED TO CONTROL INPUT ! 5232: C ! 5233: EOF = .FALSE. ! 5234: NEW = .FALSE. ! 5235: C ! 5236: C INTER-PROGRAM INITIALIZATION ! 5237: C NOST CONTAINS CURRENT STATEMENT NUMBER ! 5238: C ITYP CONTAINS TYPE OF STMT ! 5239: C BLKD IS TRUE FOR BLOCK DATA PGM UNIT, ELSE FALSE ! 5240: C EXECUT IS TRUE FOR AT LEAST ONE EXECUTABLE STMT IN ! 5241: C PROGRAM UNIT EXISTING ! 5242: C NAME CONTAINS INDEX IN DSA OF PGM UNIT NAME ! 5243: C P1ERR USED TO CONTROL WRITING OF SYMBOL TABLE FOR ! 5244: C PASS 2 ! 5245: C RET IS TRUE IF RETURN STMT OCCURS IN P.U. ELSE FALSE ! 5246: C NEXT, BNEXT POINT INTO DSA ! 5247: C LABHD POINTS TO HEAD OF LABELS LIST IN DSA ! 5248: C SYMHD POINTS TO HEAD OF SYMBOLS LIST IN DSA ! 5249: C KGP, IGP USED TO CHECK STMT SEQUENCING ! 5250: C DOPT,DOLIST USED TO CHECK DO LOOP NESTING ! 5251: C ! 5252: 10 NOST = 0 ! 5253: ITYP = 0 ! 5254: LTYP = 0 ! 5255: BLKD = .FALSE. ! 5256: EXECUT = .FALSE. ! 5257: NAME = 0 ! 5258: P1ERR = .FALSE. ! 5259: RET = .FALSE. ! 5260: NEXT = 1 ! 5261: BNEXT = LDSA ! 5262: LABHD = 0 ! 5263: SYMHD = 0 ! 5264: KGP = 0 ! 5265: DOPT = 1 ! 5266: DOLIST(1) = 1 ! 5267: DO 20 I=2,6 ! 5268: DOLIST(I) = 0 ! 5269: 20 CONTINUE ! 5270: DO 30 I=1,LHASH ! 5271: HASH(I) = 0 ! 5272: 30 CONTINUE ! 5273: C ! 5274: C DONT GOTO NEW PAGE IF NOT PRODUCING LISTING ! 5275: C ! 5276: IF (.NOT.OPT(4)) GO TO 40 ! 5277: WRITE (OUTUT,99999) ! 5278: 99999 FORMAT (32H1PFORT VERIFIER 1/12/79 VERSION //) ! 5279: C ! 5280: C INPUT NEW STMT; RETURN WHEN HIT EOF STMT ! 5281: C FIND LABELS ! 5282: C ! 5283: C HEADING STMT INADVERTENTLY READ BECAUSE OF MISSING END ! 5284: C ! 5285: 40 IF (.NOT.NEW) GO TO 70 ! 5286: NEW = .FALSE. ! 5287: NOST = 1 ! 5288: IF (.NOT.OPT(4)) GO TO 80 ! 5289: K = NSTMT - 1 ! 5290: DO 50 I=1,K ! 5291: II = STMT(I) + 1 ! 5292: STACK(I) = Q(II) ! 5293: 50 CONTINUE ! 5294: WRITE (OUTUT,99998) NOST, (STACK(I),I=1,K) ! 5295: 99998 FORMAT (1H , I5, 5X, 80A1) ! 5296: GO TO 80 ! 5297: 60 CALL ERROR1(20H UNRECOGNIZABLE STMT, 20) ! 5298: ERR = .FALSE. ! 5299: 70 CALL INSTMT(EOF, NCARD) ! 5300: IF (EOF) GO TO 400 ! 5301: 80 LAB = .FALSE. ! 5302: C ! 5303: C TYPST TYPES THE CURRENT STAMT ! 5304: C ITYP IS NO 1-30 TELLING STMT WE HAVE ! 5305: C KGP IS LEVEL NO 0-6 OF STMT. ! 5306: C ICNT IS NO OF CHARACTERS IN STMT IE KI(ITYP) ! 5307: C ! 5308: PSTMT = 6 ! 5309: CALL TYPST(ITYP, IGP, ICNT) ! 5310: IF (ERR) GO TO 60 ! 5311: PSTMT = 6 + ICNT ! 5312: IF (ITYP.GE.6) GO TO 100 ! 5313: I = ITYP - 1 ! 5314: CALL TYPST(ITYP, II, K2) ! 5315: IF (ITYP.NE.10) GO TO 90 ! 5316: PSTMT = PSTMT + K2 ! 5317: IGP = II ! 5318: GO TO 110 ! 5319: 90 ITYP = I + 1 ! 5320: 100 I = -1 ! 5321: 110 II = 1 ! 5322: IF (ITYP.LT.14 .OR. ITYP.EQ.28 .OR. ITYP.EQ.31) II = 2 ! 5323: IF (ITYP.EQ.29) II = 3 ! 5324: KEEP = PSTMT ! 5325: PSTMT = 1 ! 5326: IF (TOKLAB(II,K2,KK,.TRUE.)) LAB = .TRUE. ! 5327: IF (SYSERR) GO TO 450 ! 5328: C ! 5329: C CHECK FOR MAIN PROGRAM OR OTHER HEADING STMTS ! 5330: C ! 5331: IF (NAME) 140, 120, 140 ! 5332: 120 IF (IGP) 130, 150, 130 ! 5333: 130 CALL SETNAM(12) ! 5334: GO TO 150 ! 5335: 140 IF (IGP.EQ.0) GO TO 490 ! 5336: C ! 5337: C CHECK SEQUENCING OF STMTS ! 5338: C ! 5339: 150 IF (BLKD .AND. IGP.GT.3 .AND. ITYP.NE.28) GO TO 160 ! 5340: IF (IGP.GE.KGP) GO TO 170 ! 5341: CALL ERROR1(24H ILLEGAL STMT SEQUENCING, 24) ! 5342: GO TO 450 ! 5343: 160 CALL ERROR1(32H ILLEGAL STMTS IN BLOCK DATA PGM, 32) ! 5344: GO TO 450 ! 5345: C ! 5346: C CHECK FOR FIRST ASF DEFN OR EXECUTABLE STMT. ! 5347: C TO RESET USAGE OF FCN SUBPGM NAME IN SYMBOL TABLE ! 5348: C ! 5349: 170 IF (EXECUT .OR. IGP.LT.4) GO TO 180 ! 5350: EXECUT = .TRUE. ! 5351: K = IGATT1(NAME,8) ! 5352: IF (K.EQ.4) CALL SATT1(NAME, 8, 10) ! 5353: 180 PSTMT = KEEP ! 5354: LOGIF2 = .FALSE. ! 5355: C ! 5356: C VALUES OF ITYP ! 5357: C 1-5 TYPE STMTS: 1 DP, 2 REAL, 3 INT, 4 COMP, 5 LOG ! 5358: C 6-8 OTHER SPECIFICATION STMTS: 6 EXTERNAL, 7 DIMENSION ! 5359: C 8 COMMON ! 5360: C 9-11 HEADING STMTS: 9 SUBROUTINE, 10 FUNCTION, 11 BLOCK DATA ! 5361: C 12 EQUIVALENCE ! 5362: C 13 DATA ! 5363: C 14-27,30,32 EXECUTABLE STMTS: 14 ASSIGN, 15 GOTO, 16 RETURN, ! 5364: C 17 CONTINUE, 18 CALL, 19 STOP, 20 IF, 21 DO, 22 PAUSE, ! 5365: C 23 READ, 24 WRITE, 25 REWIND, 26 ENDFILE, 27 BACKSPACE, 30 ! 5366: C ASSIGNMENT, 32 LOGICAL IF ! 5367: C 28 END ! 5368: C 29 FORMAT ! 5369: C 31 ASF DEFN ! 5370: C CLASS CODES ! 5371: C 0-HEADING STMTS ! 5372: C 1-SPECIFICATION STMTS (INCLUDING TYPE STMTS) ! 5373: C 2-EQUIVALENCE ! 5374: C 3-DATA ! 5375: C 4-ASF DEF ! 5376: C 5-EXECUTABLE STMTS AND FORMAT STMTS ! 5377: C 6-END STMT ! 5378: C ! 5379: 190 GO TO (200, 200, 200, 200, 200, 210, 220, 250, 230, 230, 240, ! 5380: * 270, 260, 350, 330, 360, 380, 370, 380, 300, 280, 340, 340, ! 5381: * 340, 340, 340, 340, 410, 390, 290), ITYP ! 5382: C ! 5383: C TYPE STMTS (SYSERR) ! 5384: C ! 5385: 200 CALL TYPE ! 5386: GO TO 430 ! 5387: C ! 5388: C EXTERNAL STMT (SYSERR) ! 5389: C ! 5390: 210 CALL EXTERN ! 5391: GO TO 430 ! 5392: C ! 5393: C DIMENSION STMT(SYSERR) ! 5394: C ! 5395: 220 CALL DIMENS ! 5396: GO TO 430 ! 5397: C ! 5398: C SUBR/FCN DEFNS (SYSERR) ! 5399: C ! 5400: 230 CALL SUBFCN(I) ! 5401: GO TO 430 ! 5402: C ! 5403: C BLOCK DATA STMT (SYSERR) ! 5404: C ! 5405: 240 CALL SETNAM(11) ! 5406: BLKD = .TRUE. ! 5407: GO TO 430 ! 5408: C ! 5409: C COMMON STMT ! 5410: C ! 5411: 250 CALL COMMON ! 5412: GO TO 430 ! 5413: 260 CALL DATA ! 5414: GO TO 430 ! 5415: 270 CALL EQUIV ! 5416: GO TO 430 ! 5417: 280 CALL DOSTMT ! 5418: GO TO 430 ! 5419: 290 CALL ASSASF(IGP) ! 5420: IF (IGP.EQ.4 .AND. LOGIF2) GO TO 320 ! 5421: GO TO 430 ! 5422: C ! 5423: C IF STMTS ! 5424: C ! 5425: 300 CALL IFS(LOGIF1) ! 5426: C ! 5427: C FOUND AN ARITH. IF ! 5428: C ! 5429: IF (.NOT.LOGIF1) GO TO 430 ! 5430: C ! 5431: C FOUND LOGICAL IF WITHIN LOGICAL IF ! 5432: C ! 5433: IF (LOGIF1 .AND. LOGIF2) GO TO 320 ! 5434: C ! 5435: C FOUND A LOGICAL IF; MUS PROCESS REST OFSTMT ! 5436: C ! 5437: LOGIF2 = .TRUE. ! 5438: CALL TYPST(ITYP, K, K2) ! 5439: IF (.NOT.ERR) GO TO 310 ! 5440: CALL ERROR1(20H UNRECOGNIZABLE STMT, 20) ! 5441: GO TO 430 ! 5442: 310 IF (K.NE.4 .AND. K.NE.5 .OR. ITYP.EQ.21 .OR. ITYP.EQ.29) GO TO 320 ! 5443: PSTMT = PSTMT + K2 ! 5444: GO TO 190 ! 5445: 320 CALL ERROR1(27H ILLEGAL STMT IN LOGICAL IF, 27) ! 5446: GO TO 430 ! 5447: C ! 5448: C GOTO STMTS ! 5449: C ! 5450: 330 CALL GOTO ! 5451: GO TO 430 ! 5452: C ! 5453: C I-O STMTS ! 5454: C ! 5455: 340 CALL IO ! 5456: GO TO 430 ! 5457: C ! 5458: C ASSIGN STMT ! 5459: C ! 5460: 350 CALL ASSIGN ! 5461: GO TO 430 ! 5462: C ! 5463: C RETURN CANNOT APPEAR IN MAIN PGM ! 5464: C ! 5465: 360 I = IGATT1(NAME,8) ! 5466: IF (I.EQ.12) CALL ERROR1( ! 5467: * 44H RETURN STATEMENT MAY NOT APPEAR IN MAIN PGM, 44) ! 5468: RET = .TRUE. ! 5469: GO TO 380 ! 5470: C ! 5471: C CALL STMT ! 5472: C ! 5473: 370 CALL CALLS ! 5474: GO TO 430 ! 5475: C ! 5476: C CHECK FOR EXTRANEOUS INFO AFTER STOP AND CONTINUE STMTS ! 5477: C ! 5478: 380 IF (PSTMT.NE.NSTMT) CALL ERROR1( ! 5479: * 34H EXTRANEOUS INFO AFTER END OF STMT, 34) ! 5480: GO TO 430 ! 5481: C ! 5482: C FORMAT ! 5483: C ! 5484: 390 IF (.NOT.LAB) CALL ERROR1(26H MISSING FORMAT STMT LABEL, 26) ! 5485: CALL FORMAT ! 5486: GO TO 430 ! 5487: C ! 5488: C CODE TO HANDLE END-OF-FILE WITHOUT AN END STMT ! 5489: C ! 5490: 400 IF (ITYP.EQ.28 .OR. ITYP.EQ.0) GO TO 500 ! 5491: CALL ERROR1(37H WARNING - MISSING END STMT SIMULATED, 37) ! 5492: LAB = .FALSE. ! 5493: ITYP = 28 ! 5494: 410 CALL END ! 5495: C ! 5496: C CHECK FOR NO CONTINUATION ! 5497: C ! 5498: IF (NCARD.GT.1) CALL ERROR1(34H END LINE CANNOT HAVE CONTINUATION, ! 5499: * 34) ! 5500: C ! 5501: C CHECK FOR ENDING ON A GOTO,ARITH IF, STOP OR RETURN ! 5502: C ! 5503: IF ((LTYP.EQ.16 .OR. LTYP.EQ.15 .OR. LTYP.EQ.19 .OR. LTYP.EQ.20) ! 5504: * .OR. BLKD) GO TO 420 ! 5505: CALL ERROR1(29H ILLEGAL LAST EXECUTABLE STMT, 29) ! 5506: C ! 5507: C CHECK THERE HAVE BEEN EXECUTABLE STMTS ! 5508: C CHECK FOR A RETURN STMT IF NECESSARY ! 5509: C ! 5510: 420 IF (KGP.NE.5 .AND. .NOT.BLKD) CALL ERROR1( ! 5511: * 42H ILLEGAL PROGRAM UNIT, NO EXECUTABLE STMTS, 42) ! 5512: I = IGATT1(NAME,8) ! 5513: IF (I.EQ.11 .OR. I.EQ.12 .OR. RET) GO TO 430 ! 5514: CALL ERROR1(36H MISSING RETURN STMT IN PROGRAM UNIT, 36) ! 5515: C ! 5516: C CHECK STMT LABELS FOR DOENDINGS, UPDATE KGP, CHECK TABLE SIZE ! 5517: C CHECK FOR CANCELLING SAVING OF SYMBOL TABLE FOR PASS2 ! 5518: C DUE TO ERRORS IN THIS PGM UNIT ! 5519: C ! 5520: 430 KGP = IGP ! 5521: IF (ITYP.NE.29) LTYP = ITYP ! 5522: IF (LOGIF2) LTYP = 32 ! 5523: IF (SYSERR) GO TO 450 ! 5524: IF (.NOT.LAB) GO TO 440 ! 5525: CALL DOCHK(KK) ! 5526: IF (ITYP.LT.14 .OR. ITYP.EQ.28 .OR. ITYP.EQ.31) CALL ERROR1( ! 5527: * 37H WARNING - LABELED NONEXECUTABLE STMT, 37) ! 5528: 440 IF (EOF) GO TO 500 ! 5529: ERR = .FALSE. ! 5530: IF (ITYP.EQ.28) GO TO 10 ! 5531: GO TO 70 ! 5532: C ! 5533: C FLUSH CODE TO NEXT HEADR OR END SMT ! 5534: C ! 5535: 450 CALL ERROR1(44H CODE FLUSHED UNTIL NEXT END OR HEADING STMT, 44) ! 5536: P1ERR = .TRUE. ! 5537: IF (SYSERR) SYSERR = .FALSE. ! 5538: LAB = .FALSE. ! 5539: 460 CALL INSTMT(EOF, NCARD) ! 5540: IF (EOF) GO TO 500 ! 5541: PSTMT = 6 ! 5542: CALL TYPST(ITYP, IGP, ICNT) ! 5543: IF (.NOT.ERR) GO TO 470 ! 5544: ERR = .FALSE. ! 5545: GO TO 460 ! 5546: 470 IF (ITYP.EQ.28) GO TO 410 ! 5547: IF (ITYP.GT.5) GO TO 480 ! 5548: PSTMT = PSTMT + ICNT ! 5549: CALL TYPST(ITYP, IGP, ICNT) ! 5550: IF (ERR) ERR = .FALSE. ! 5551: IF (ITYP.EQ.10) GO TO 490 ! 5552: GO TO 460 ! 5553: 480 IF (ITYP.LT.9 .OR. ITYP.GT.11) GO TO 460 ! 5554: C ! 5555: C HAVE FOUND A HEADER STMT; SIMULATE AN END STMT ! 5556: C ! 5557: 490 NEW = .TRUE. ! 5558: CALL ERROR1(37H WARNING - MISSING END STMT SIMULATED, 37) ! 5559: ITYP = 28 ! 5560: LAB = .FALSE. ! 5561: GO TO 410 ! 5562: C ! 5563: C PUT ENDING MARKER ON THE DATA FOR PASS2 ! 5564: C ! 5565: 500 I = 1 ! 5566: II = 4 ! 5567: WRITE (OUTUT3) I, II, I ! 5568: WRITE (OUTUT2) I, II, I ! 5569: RETURN ! 5570: END ! 5571: C XXXXXCOMCHK.f ! 5572: SUBROUTINE COMCHK(MAIN) ! 5573: INTEGER TEMP(1), PLAT, STAR, PCOM, COM, PNODE, SYMLEN ! 5574: INTEGER ZERO(1) ! 5575: COMMON /COMS/ LCOM, PCOM, COM(300) ! 5576: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 5577: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6 ! 5578: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 5579: COMMON /SCR2/ LNN, NN(500) ! 5580: DATA STAR /1H*/ ! 5581: DATA ZERO(1) /0/ ! 5582: C ! 5583: C ALGORITHM TO CHECK FOR LEGAL USE OF COMMON IN PGM UNITS ! 5584: C NODE(MAIN) POINTS TO SUPEROOT ENTRY IN LAT ! 5585: C ! 5586: IF (PCOM.LE.0) GO TO 130 ! 5587: LK = 1 ! 5588: 10 IF (LK.GE.PCOM-1) GO TO 130 ! 5589: C ! 5590: C CHECK COMMON ISNT BLANK COMMON ! 5591: C ! 5592: CALL S5UNPK(COM(LK), TEMP, 1) ! 5593: IF (TEMP(1).EQ.STAR) GO TO 120 ! 5594: C ! 5595: C CHECK THAT COMMON BLOCK NOT IN BLOCK DATA PGM ! 5596: C NEED NOT CHECK THE COMMON ! 5597: C ! 5598: K = LK + SYMLEN + 1 ! 5599: IF (COM(K).EQ.1) GO TO 120 ! 5600: C ! 5601: C NEED ALGORITHM TO CHECK OUT THIS COMMON ! 5602: C ! 5603: L = PNODE - 1 ! 5604: DO 20 K=1,L ! 5605: NN(K) = 0 ! 5606: IF (NODE(K).LT.0) NN(K) = 1 ! 5607: 20 CONTINUE ! 5608: ICNT = 0 ! 5609: NN(MAIN) = 2 ! 5610: C ! 5611: C SEARCH FOR A 2 NODE ! 5612: C ! 5613: 30 L = PNODE - 1 ! 5614: DO 40 K=1,L ! 5615: IF (NN(K).EQ.2) GO TO 50 ! 5616: 40 CONTINUE ! 5617: GO TO 120 ! 5618: C ! 5619: C FOUND A 2 NODE; CHANGE TO 1 TO SHOW HAVE VISITED IT; ! 5620: C IF SUBPGM CONTAINS COMMON IN QUESTION INCREMENT COUNT; ! 5621: C IF COUNT> 1 ERROR IN USAGE ! 5622: C IF SUBPGM DOESN'T CONTAIN COMMON, MARK HIS DESC 2 IF THEY ARE 0. ! 5623: C ! 5624: 50 NN(K) = 1 ! 5625: LBR = NODE(K) ! 5626: L = NODE(K) + SYMLEN + 2 ! 5627: L = LAT(L) ! 5628: 60 IF (L.EQ.0) GO TO 90 ! 5629: IF (LAT(L).NE.LK) GO TO 80 ! 5630: C ! 5631: C FOUND COMMON LK AT THIS NODE ! 5632: C MARK NODE TO A 3 ! 5633: C ! 5634: NN(K) = 3 ! 5635: ICNT = ICNT + 1 ! 5636: IF (ICNT.LE.1) GO TO 30 ! 5637: CALL ERROR2(31H ILLEGAL USAGE OF COMMON BLOCK , 31, COM(LK), ! 5638: * 1, 1, 0) ! 5639: K = PNODE - 1 ! 5640: DO 70 I=1,K ! 5641: L = NODE(I) ! 5642: IF (NN(I).EQ.3) CALL ERROR2(19H WHICH APPEARED IN , 19, LAT(L), ! 5643: * 1, 0, 0) ! 5644: 70 CONTINUE ! 5645: CALL ERROR2( 1H1, 0, ZERO(1), -3, 0, 1) ! 5646: GO TO 120 ! 5647: 80 L = LAT(L+2) ! 5648: GO TO 60 ! 5649: C ! 5650: C ARE DONE SEARCHING FOR COMMON LK AT THIS NODE ! 5651: C ADD DESCENDENTS ONTO LIST TO BE VISITED ! 5652: C ! 5653: 90 L = NODE(K) + SYMLEN + 4 ! 5654: L = LAT(L) ! 5655: 100 IF (L.EQ.0) GO TO 30 ! 5656: K = PNODE - 1 ! 5657: C ! 5658: C FIND DESC OF NODE AND IF NOT VISITED SET TO 2 ! 5659: C ! 5660: DO 110 I=1,K ! 5661: IF (NODE(I).NE.LAT(L)) GO TO 110 ! 5662: IF (NN(I).EQ.0) NN(I) = 2 ! 5663: 110 CONTINUE ! 5664: L = LAT(L+1) ! 5665: GO TO 100 ! 5666: 120 LK = LK + SYMLEN + 5 ! 5667: GO TO 10 ! 5668: 130 RETURN ! 5669: END ! 5670: C XXXXXCOMPAR.f ! 5671: LOGICAL FUNCTION COMPAR(A, B) ! 5672: INTEGER SYMLEN, A(2), B(2) ! 5673: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4 ! 5674: C ! 5675: C ROUTINE TESTS TWO IDENTIFIERS FOR SAMENESS; RETURNS TRUE IF ! 5676: C SAME, ELSE FALSE ! 5677: C ! 5678: DO 10 I=1,SYMLEN ! 5679: IF (A(I).NE.B(I)) GO TO 30 ! 5680: 10 CONTINUE ! 5681: COMPAR = .TRUE. ! 5682: 20 RETURN ! 5683: 30 COMPAR = .FALSE. ! 5684: GO TO 20 ! 5685: END ! 5686: C XXXXXFINDND.f ! 5687: INTEGER FUNCTION FINDND(K1, K2) ! 5688: INTEGER K1(2) ! 5689: INTEGER PLAT, PNODE ! 5690: LOGICAL COMPAR ! 5691: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 5692: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 5693: C ! 5694: C FINDS SUBPROGRAM WHOSE PACKED NAME IS IN K1(2) AND ! 5695: C RETURNS INDEX OF ITS LAT ENTRY AS VALUE OF FINFND ! 5696: C RETURNS IN K2 INDEX IN NODE OF LAT INDEX ! 5697: C IGNORES ASF NODES IN LAT BY IGNORING NEGATIVE NODE ! 5698: C ENTRIES ! 5699: C ! 5700: IF (PNODE-1) 40, 40, 10 ! 5701: 10 K = PNODE - 1 ! 5702: DO 30 I=1,K ! 5703: IF (NODE(I)) 30, 30, 20 ! 5704: 20 FINDND = NODE(I) ! 5705: K2 = I ! 5706: IF (COMPAR(LAT(FINDND),K1)) GO TO 50 ! 5707: 30 CONTINUE ! 5708: 40 FINDND = 0 ! 5709: 50 RETURN ! 5710: END ! 5711: C XXXXXFINDCM.f ! 5712: INTEGER FUNCTION FINDCM(K1) ! 5713: INTEGER K1(2) ! 5714: INTEGER PCOM, COM, SYMLEN ! 5715: LOGICAL COMPAR ! 5716: COMMON /COMS/ LCOM, PCOM, COM(300) ! 5717: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4 ! 5718: C ! 5719: C ROUTINE FINDS COMMON BLOCK WHOSE NAME IS AT K1 IN COM ! 5720: C RETURNS INDEX IN COM OR 0 IF CANNOT FIND IT ! 5721: C ! 5722: IF (PCOM-1) 30, 30, 10 ! 5723: 10 K = PCOM - 1 ! 5724: KK = SYMLEN + 5 ! 5725: DO 20 I=1,K,KK ! 5726: FINDCM = I ! 5727: IF (COMPAR(COM(I),K1)) GO TO 40 ! 5728: 20 CONTINUE ! 5729: 30 FINDCM = 0 ! 5730: 40 RETURN ! 5731: END ! 5732: C XXXXXINREF.f ! 5733: INTEGER FUNCTION INREF(IDUM) ! 5734: INTEGER REF, PREF ! 5735: COMMON /CREF/ LREF, PREF, REF(100) ! 5736: C ! 5737: C ROUTINE TO INPUT CALL TEMPLATES, RETURNS -1 FOR EOF, 0 FOR END ! 5738: C OF REFS FOR THIS PGM UNIT, AND 1 FOR REF RETRIEVED ! 5739: C ! 5740: READ (IDUM) PREF, K, (REF(L),L=1,PREF) ! 5741: IF (K-3) 10, 30, 40 ! 5742: 10 INREF = 1 ! 5743: 20 RETURN ! 5744: 30 INREF = 0 ! 5745: GO TO 20 ! 5746: 40 INREF = -1 ! 5747: GO TO 20 ! 5748: END ! 5749: C XXXXXINSYM.f ! 5750: LOGICAL FUNCTION INSYM(IDUM,II) ! 5751: INTEGER OUTUT, OUTUT2, OUTUT3, SYMHD, PDSA, SYMLEN, DSA, BNEXT ! 5752: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, I1 ! 5753: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT ! 5754: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 5755: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 5756: C ! 5757: C ROUTINE TO INPUT SYMBOL TABLE; RETURNS TRUE FOR SUCCESSFUL, ELSE ! 5758: C FALSE. KCODE=1 FOR TABLE, 3 FOR DUMMY TABLE, 4 FOR EOF ! 5759: C DUMMY TABLE CAUSES REFS FOR THIS PU TO BE FLUSHED IF ! 5760: C IDUM NE 0 ! 5761: C ! 5762: 5 READ(OUTUT2) PDSA, KCODE, (DSA(I),I=1,PDSA) ! 5763: IF (KCODE-3) 10, 40, 30 ! 5764: 10 NAME = DSA(PDSA-2) ! 5765: SYMHD = DSA(PDSA-1) ! 5766: LABHD = DSA(PDSA) ! 5767: PDSA = PDSA - 3 ! 5768: INSYM = .TRUE. ! 5769: 20 RETURN ! 5770: 30 INSYM = .FALSE. ! 5771: GO TO 20 ! 5772: C FLUSH REFS FOR DUMMY TABLE IF IDUM NONZERO ! 5773: 40 IF(IDUM.EQ.0) GOTO 5 ! 5774: 50 IF(INREF(IDUM)) 60, 60, 50 ! 5775: C WRITE END OF REFS FOR DUMMY REFS IF II NE 0; ELSE GOT TO ! 5776: C NEXT SYMBOL TABLE ! 5777: 60 IF(II.EQ.0) GOTO 5 ! 5778: L = 1 ! 5779: K = 3 ! 5780: WRITE(II) L,K,L ! 5781: GOTO 5 ! 5782: END ! 5783: C XXXXXMATCH.f ! 5784: INTEGER FUNCTION MATCH(HEAD, INCR, N) ! 5785: INTEGER PLAT, HEAD ! 5786: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 5787: C ! 5788: C ROUTINE READS DOEN A LINEAR LINKED LIST IN LAT TO FIND ENTRY ! 5789: C WHOSE FIRST WORD CONTAINS N; EACH LIST ELEMENT IS INCR+1 LONG; ! 5790: C HEAD IS POINTER TO FIRST LIST ELEMENT ! 5791: C RETURNS 0 FOR NO MATCH ON LIST OR THE EMPTY LIST ! 5792: C ! 5793: IF (HEAD) 40, 40, 10 ! 5794: 10 MATCH = HEAD ! 5795: 20 IF (LAT(MATCH).EQ.N) GO TO 50 ! 5796: MATCH = MATCH + INCR ! 5797: IF (LAT(MATCH)) 40, 40, 30 ! 5798: 30 MATCH = LAT(MATCH) ! 5799: GO TO 20 ! 5800: 40 MATCH = 0 ! 5801: 50 RETURN ! 5802: END ! 5803: C XXXXXMKCOM.f ! 5804: SUBROUTINE MKCOM(PP, K) ! 5805: INTEGER PLAT, PDSA, FINDCM, DSA, SYMLEN, PP, PCOM, COM ! 5806: LOGICAL SYSERR, ERR, ABORT ! 5807: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 5808: COMMON /COMS/ LCOM, PCOM, COM(300) ! 5809: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 5810: COMMON /DETECT/ ERR, SYSERR, ABORT ! 5811: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4 ! 5812: C ! 5813: C WANT TO MARK COMMONLIST ENTRY SET FOR SUBPGM PP; MAY HAVE TO ! 5814: C CREATE ENTRY ! 5815: C ! 5816: N = FINDCM(DSA(K+4)) ! 5817: L = SYMLEN + 2 + PP ! 5818: KK = -K ! 5819: IF (N.NE.0) KK = N ! 5820: C ! 5821: C LOOK FOR DSA ENTRY ON LIST ! 5822: C ! 5823: I = MATCH(LAT(L),2,KK) ! 5824: IF (I) 30, 30, 10 ! 5825: 10 LAT(I+1) = 1 ! 5826: 20 RETURN ! 5827: C ! 5828: C CREATE NEW ENTRY ! 5829: C ! 5830: 30 IF (PLAT+3.GT.LLAT) GO TO 40 ! 5831: LAT(PLAT+1) = 1 ! 5832: LAT(PLAT+2) = LAT(L) ! 5833: LAT(L) = PLAT ! 5834: LAT(PLAT) = KK ! 5835: PLAT = PLAT + 3 ! 5836: GO TO 20 ! 5837: 40 SYSERR = .TRUE. ! 5838: CALL ERROR1(32H IN MKCOM, TABLE OVERFLOW OF LAT, 32) ! 5839: GO TO 20 ! 5840: END ! 5841: C XXXXXOUTCOM.f ! 5842: INTEGER FUNCTION OUTCOM(IH, L) ! 5843: INTEGER STACK,PLAT ! 5844: LOGICAL ERR, SYSERR, ABORT ! 5845: COMMON /DETECT/ ERR, SYSERR, ABORT ! 5846: COMMON /CEXPRS/ LSTACK, STACK(620) ! 5847: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 5848: C ! 5849: C READS DOWN COM LIST OF PU NODE, PUTS INDICES OF ENTRIES ! 5850: C IN STACK. IH IS HEAD OF LIST, L RETURNS NO OF ENTRIES ! 5851: C ! 5852: OUTCOM = 0 ! 5853: IF (IH) 40, 40, 10 ! 5854: 10 L = 1 ! 5855: K = IH ! 5856: 20 IF (L+1.GT.LSTACK) GOTO 50 ! 5857: STACK(L) = LAT(K) ! 5858: IF (LAT(K+1).EQ.1) STACK(L) = -STACK(L) ! 5859: L = L + 1 ! 5860: K = LAT(K+2) ! 5861: IF (K) 30, 30, 20 ! 5862: 30 L = L - 1 ! 5863: IF(L.GT.0) OUTCOM=1 ! 5864: 40 RETURN ! 5865: 50 SYSERR = .TRUE. ! 5866: CALL ERROR1(35H IN OUTCOM, TABLE OVERFLOW OF STACK, 35) ! 5867: GO TO 40 ! 5868: END ! 5869: C XXXXXOUTLAT.f ! 5870: INTEGER FUNCTION OUTLAT(IH, L, ISR) ! 5871: INTEGER STACK, PLAT ! 5872: LOGICAL ERR, SYSERR, ABORT ! 5873: COMMON /DETECT/ ERR, SYSERR, ABORT ! 5874: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 5875: COMMON /CEXPRS/ LSTACK, STACK(620) ! 5876: INTEGER SYMLEN ! 5877: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6 ! 5878: C ! 5879: C IH POINTS TO A PARENTS OR DESCS LIST IN LAT; L IS NUM ! 5880: C OF ELEMENTS FOUND ON LIST; ISR IS ENTRY IN LAT OF ! 5881: C SUPERROOT ! 5882: C ! 5883: C ! 5884: OUTLAT = 0 ! 5885: IF (IH) 50, 50, 10 ! 5886: 10 K = IH ! 5887: L = 1 ! 5888: 20 M = LAT(K) ! 5889: C SKIP OVER CALLS TO ASFS AND OVER SUPEROOT ! 5890: IF(MOD(IGATT2(M+SYMLEN+6,1),8).EQ.4 .OR. M.EQ.ISR) GOTO 30 ! 5891: IF(L+1.GT.LSTACK) GOTO 60 ! 5892: STACK(L) = M ! 5893: L = L + 1 ! 5894: 30 K = LAT(K+1) ! 5895: IF (K) 40, 40, 20 ! 5896: 40 L = L - 1 ! 5897: IF (L.GT.0) OUTLAT = 1 ! 5898: 50 RETURN ! 5899: 60 CALL ERROR1(35H IN OUTLAT, TABLE OVERFLOW OF STACK, 35) ! 5900: SYSERR = .TRUE. ! 5901: GO TO 50 ! 5902: END ! 5903: C XXXXXOUT2A.f ! 5904: SUBROUTINE OUT2A( IT, JJ, N, ISW ) ! 5905: C ! 5906: C IT CONTINAS TITLE FOR FIRST LINE OF OUTPUT ! 5907: C JJ CONTAINS NUMBER OF CHARS IN TITLE, J<=25 ! 5908: C N CONTAINS NUMBER OF ELEMENTS TO BE PRINTED ! 5909: C ISW TELLS IF THESE ARE COMMON NAMES OR PROC NAMES ! 5910: C ! 5911: INTEGER IT(25), II(25), BL, PLAT, PCOM, COM, STACK, OUTUT, S ! 5912: INTEGER BUF(54) ! 5913: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 5914: COMMON /PARAMS/ II1, OUTUT, II2, II3, II4, II5, II6 ! 5915: COMMON /CEXPRS/ LSTACK, STACK(620) ! 5916: COMMON /COMS/ LCOM, PCOM, COM(300) ! 5917: DATA BL/1H /,S/1HS/ ! 5918: C ! 5919: C UNPACK TITLE ! 5920: C ! 5921: NN = JJ ! 5922: IF(JJ.GT.25) NN=25 ! 5923: CALL S5UNPK( IT(1), II(1), NN) ! 5924: K1 = NN + 1 ! 5925: IF(K1.GT.25) GOTO 15 ! 5926: DO 10 K =K1, 25 ! 5927: II(K) = BL ! 5928: 10 CONTINUE ! 5929: C ! 5930: C SETUP FIRST LINE OF ELEMENTS ! 5931: C ! 5932: 15 K = 6 ! 5933: IF (K.GT.N) K = N ! 5934: IB = 1 ! 5935: DO 50 I = 1, K ! 5936: IL = STACK(I) ! 5937: GOTO (20, 30),ISW ! 5938: C FOR PARE OR DESC LISTS ! 5939: 20 CALL S5UNPK( LAT(IL), BUF(IB), 6 ) ! 5940: BUF(IB + 7) = BL ! 5941: GOTO 40 ! 5942: C FOR COMMON LISTS- INDEX TO ELEMENTS IS NEGATIVE ! 5943: C IF COMMON IS SET BY PGM UNIT ! 5944: 30 BUF(IB + 7) = BL ! 5945: IF(IL.LT.0) BUF(IB + 7) = S ! 5946: IL = IABS(IL) ! 5947: CALL S5UNPK( COM(IL), BUF(IB), 6 ) ! 5948: 40 BUF(IB + 6) = BL ! 5949: BUF(IB + 8) = BL ! 5950: IB = IB + 9 ! 5951: 50 CONTINUE ! 5952: IB = IB - 1 ! 5953: WRITE(OUTUT,99999) (II(L),L=1,25), (BUF(I),I=1,IB) ! 5954: 99999 FORMAT(80A1) ! 5955: IF(K.EQ.N) GOTO 110 ! 5956: C WRITE SUBSEQUENT LINES ! 5957: 60 IB = 1 ! 5958: K1 = K + 1 ! 5959: K = K + 6 ! 5960: IF (K.GT.N) K = N ! 5961: DO 100 I = K1, K ! 5962: IL = STACK(I) ! 5963: GOTO (70, 80), ISW ! 5964: C FOR PAR OR DESC LISTS ! 5965: 70 CALL S5UNPK( LAT(IL), BUF(IB), 6 ) ! 5966: BUF(IB + 7) = BL ! 5967: GOTO 90 ! 5968: C FOR COMMON LISTS ! 5969: 80 BUF(IB + 7) = BL ! 5970: IF(IL.LT.0) BUF(IB + 7) = S ! 5971: IL = IABS(IL) ! 5972: CALL S5UNPK( COM(IL), BUF(IB), 6 ) ! 5973: 90 BUF(IB + 6) = BL ! 5974: BUF(IB +8) = BL ! 5975: IB = IB + 9 ! 5976: 100 CONTINUE ! 5977: IB = IB - 1 ! 5978: WRITE(OUTUT,99998) (BUF(I),I =1,IB) ! 5979: 99998 FORMAT(25X,55A1) ! 5980: IF(K.LT.N) GOTO 60 ! 5981: 110 RETURN ! 5982: END ! 5983: C XXXXXOUT2C.f ! 5984: SUBROUTINE OUT2C ! 5985: INTEGER COM, PCOM, STACK, BL, SYMLEN, OUTUT, S, PLAT ! 5986: EXTERNAL EXCH ! 5987: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, I1, I2, I3 ! 5988: COMMON /COMS/ LCOM, PCOM, COM(300) ! 5989: COMMON /CEXPRS/ LSTACK, STACK(620) ! 5990: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 5991: COMMON /SCR2/ LICOM, ICOM(500) ! 5992: DATA BL /1H /, S /1HS/ ! 5993: C ! 5994: C PRINTS COM ARRAY ! 5995: C ! 5996: IF (PCOM-1) 80, 80, 10 ! 5997: 10 K1 = SYMLEN + 5 ! 5998: K = 1 ! 5999: LCOMS = (PCOM-1)/(SYMLEN+5) ! 6000: DO 20 I=1,LCOMS ! 6001: ICOM(I) = K ! 6002: K = K + K1 ! 6003: 20 CONTINUE ! 6004: CALL SSORT(EXCH, COM, LCOM, ICOM, LCOMS, 0) ! 6005: WRITE (OUTUT,99999) ! 6006: 99999 FORMAT (///14H1COMMON BLOCKS///1X, 4HNAME, 3X, 3HSET, 1X, ! 6007: * 18H DP,COM INT,RL,LOG//) ! 6008: DO 70 IBR=1,LCOMS ! 6009: I = ICOM(IBR) ! 6010: CALL S5UNPK(COM(I), STACK(1), 6) ! 6011: DO 30 L=1,3 ! 6012: II = I + SYMLEN + L ! 6013: KK = 7 + L ! 6014: STACK(KK) = COM(II) ! 6015: 30 CONTINUE ! 6016: IF (STACK(8)) 40, 40, 50 ! 6017: 40 STACK(8) = BL ! 6018: GO TO 60 ! 6019: 50 STACK(8) = S ! 6020: 60 WRITE (OUTUT,99998) (STACK(II),II=1,6), STACK(8), ! 6021: * (STACK(II),II=9,10) ! 6022: 99998 FORMAT (1X, 6A1, 3X, A1, I8, 3X, I8) ! 6023: 70 CONTINUE ! 6024: 80 RETURN ! 6025: END ! 6026: C XXXXXSCAN.f ! 6027: SUBROUTINE SCAN(MAINND) ! 6028: INTEGER PLAT, SYMLEN, PNODE, STACK ! 6029: LOGICAL ERR, SYSERR, ABORT ! 6030: COMMON /DETECT/ ERR, SYSERR, ABORT ! 6031: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 6032: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6 ! 6033: COMMON /CEXPRS/ LSTACK, STACK(620) ! 6034: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 6035: COMMON/ SCR1/ LINODE, INODE(500) ! 6036: COMMON /SCR2/ LICOM, ICOM(500) ! 6037: C ! 6038: C SUBROUTINE PERCOLATES SETTING INFO ABOUT ARGUMENTS AND COMMON ! 6039: C UP THE LATTICE---IN ORDER THAT UNSAFE REFS CAN BE CHECKED ! 6040: C ! 6041: C ! 6042: C STACK(1)-(LSTACK) KEEPS TRACK OF PATH FROM CURRENT TERMINAL NODE ! 6043: C TO SUPEROOT NODE ! 6044: C INODE(J) IS 0 IF A NODE IS UNVISITED SO FAR ON ALL PATHS ! 6045: C 1 IF A NODE HAS BEEN VISITED ON AT LEAST ONE PATH ! 6046: C SYSERR IS SET BY SCAN ! 6047: C ! 6048: DO 10 I=1,PNODE ! 6049: INODE(I) = 0 ! 6050: 10 CONTINUE ! 6051: INODE(MAINND) = 1 ! 6052: MAIN = NODE(MAINND) ! 6053: NUM = 0 ! 6054: C ! 6055: C CYCLE THROUGH ALL TERMINAL NODES ! 6056: C ! 6057: 20 NUM = NUM + 1 ! 6058: IF (NUM.GT.PNODE-1) GO TO 240 ! 6059: C ! 6060: C CHECK IF AN NODE IS ASF OR IF IT HAS DESC ! 6061: C OR IF IT HAS NO PARENTS ! 6062: C ! 6063: IF (NODE(NUM).LE.0) GO TO 20 ! 6064: I = NODE(NUM) + SYMLEN + 4 ! 6065: C ! 6066: C NO PARENTS ! 6067: C ! 6068: IF (LAT(I-1).EQ.0) GO TO 20 ! 6069: C ! 6070: C TEST DESC FOR BEING ALL ASFS ! 6071: C ! 6072: IF (LAT(I).EQ.0) GO TO 40 ! 6073: L = LAT(I) ! 6074: 30 K = LAT(L) + SYMLEN + 6 ! 6075: IF (MOD(LAT(K),8).NE.4) GO TO 20 ! 6076: L = LAT(I+1) ! 6077: IF (L) 40, 40, 30 ! 6078: C ! 6079: C HAVE A TERMINAL NODE;NOW CAN START RECURSIVE TRAVERSE OF ALL ! 6080: C PATHS UPWARDS FROM IT TO ROOT ! 6081: C ILEN--POINTER TO TOP OF CURRENT PATH ! 6082: C JNODE--CURRENT NODE ! 6083: C ! 6084: 40 INODE(NUM) = 1 ! 6085: ILEN = 2 ! 6086: STACK(2) = NODE(NUM) ! 6087: STACK(1) = 0 ! 6088: C ! 6089: C STACK ENTRY IS 1ST WORD-POINTER TO NODE ON LIST OF PARS OFPREV ! 6090: C NODE; 2ND WORD-NODE INDEX ! 6091: C PROCESS NODE ! 6092: C 1. CHECK EACH ARG. IF NOT SET OR IF PARENTS ARGLINKS NONEXISTANT ! 6093: C SKIP TO NEXT ARG (IF NO ARGS GOTO 2); ELSE MARK EACH PARENT ! 6094: C ARGLIST ENTRY AS SET FOR A SET ARG. ! 6095: C 2. ADD EACH COMMON REGION TO PARENTS' LIST OF COMMON REGIONS ! 6096: C 3. GET NEW NODE ! 6097: C ! 6098: 50 J = STACK(ILEN) + SYMLEN + 1 ! 6099: C ! 6100: C ARG PROCESSING ! 6101: C ! 6102: J = LAT(J) ! 6103: 60 IF (J.EQ.0) GO TO 90 ! 6104: I = IGATT2(J,5) ! 6105: IF (I.NE.1 .OR. LAT(J+2).EQ.0) GO TO 80 ! 6106: L = LAT(J+2) ! 6107: 70 IF (L.EQ.0) GO TO 80 ! 6108: C ! 6109: C SET PARENT ARGS ! 6110: C ! 6111: CALL SATT2(LAT(L), 5, 1) ! 6112: L = LAT(L+1) ! 6113: GO TO 70 ! 6114: C ! 6115: C GO ON TO NEXT ARG ! 6116: C ! 6117: 80 J = LAT(J+3) ! 6118: GO TO 60 ! 6119: C ! 6120: C COMMON PROCESSING ! 6121: C ! 6122: 90 J = STACK(ILEN) + SYMLEN + 2 ! 6123: II = 0 ! 6124: J = LAT(J) ! 6125: C ! 6126: C ACCUMULATE COMMON REGIONS ! 6127: C ! 6128: 100 IF (J.EQ.0) GO TO 110 ! 6129: ICOM(II+1) = LAT(J) ! 6130: IF (LAT(J+1).NE.0) ICOM(II+1) = -ICOM(II+1) ! 6131: II = II + 1 ! 6132: J = LAT(J+2) ! 6133: GO TO 100 ! 6134: 110 IF (II.EQ.0) GO TO 150 ! 6135: C ! 6136: C GET PARENT NODE AND ADD COMMON REGIONS TO IT ! 6137: C ! 6138: K = STACK(ILEN) + SYMLEN + 3 ! 6139: K = LAT(K) ! 6140: 120 L = LAT(K) + SYMLEN + 2 ! 6141: DO 140 I=1,II ! 6142: LL = MATCH(LAT(L),2,IABS(ICOM(I))) ! 6143: IF (LL.EQ.0) GO TO 130 ! 6144: IF (ICOM(I).LT.0) LAT(LL+1) = 1 ! 6145: GO TO 140 ! 6146: C ! 6147: C COPY COMMONNODE ENTRIES ONTO PARENTS LIST ! 6148: C ! 6149: 130 IF (PLAT+3.GT.LLAT) GO TO 270 ! 6150: LAT(PLAT+2) = LAT(L) ! 6151: LAT(PLAT+1) = 0 ! 6152: LAT(PLAT) = IABS(ICOM(I)) ! 6153: IF (ICOM(I).LT.0) LAT(PLAT+1) = 1 ! 6154: LAT(L) = PLAT ! 6155: PLAT = PLAT + 3 ! 6156: 140 CONTINUE ! 6157: C ! 6158: C GOONTO NEW PARENT ! 6159: C ! 6160: K = LAT(K+1) ! 6161: IF (K.NE.0) GO TO 120 ! 6162: C ! 6163: C FIND A PARENT OF THIS NODE AND TRY TO VISIT IT NEXT ! 6164: C I CONTAINS POINTER TO PARENT LIST POSITION OF THE PARENT; ! 6165: C J CONTAINS PARENTS INDEX IN LAT ! 6166: C IF NO MORE PARENTS, MUST BACKUP A LEVEL ! 6167: C ! 6168: 150 I = STACK(ILEN) + SYMLEN + 3 ! 6169: 160 IF (LAT(I).EQ.0) GO TO 200 ! 6170: I = LAT(I) ! 6171: 170 J = LAT(I) ! 6172: C ! 6173: C CHECK THAT NEW ENTRY HAS PARENTS ! 6174: C AND THAT IT IS NOT THE SUPEROOT ! 6175: C ! 6176: K = J + SYMLEN + 3 ! 6177: IF (LAT(K).GT.0) GO TO 210 ! 6178: C ! 6179: C IF THIS PARENT UNACCEPTIBLE GO ONTO NEXT PARENT ! 6180: C MARK UNACCEPTIBLE AS VISITED SO WONT BE RECURSIVE ! 6181: C ! 6182: LL = PNODE - 1 ! 6183: DO 180 L=1,LL ! 6184: IF (J.NE.NODE(L)) GO TO 180 ! 6185: INODE(L) = 1 ! 6186: GO TO 190 ! 6187: 180 CONTINUE ! 6188: 190 I = I + 1 ! 6189: GO TO 160 ! 6190: C ! 6191: C MUST BACK DOWN THE PATH TO THE NEXT JUNCTURE WITH ! 6192: C AN UNTRIED PATH; CHECK FIRST FOR DONE WITH ENTIRE PATH ! 6193: C ! 6194: 200 IF (STACK(ILEN-1).EQ.0) GO TO 20 ! 6195: ILEN = ILEN - 2 ! 6196: J = STACK(ILEN+1) ! 6197: IF (LAT(J+1).EQ.0) GO TO 200 ! 6198: C ! 6199: C FOUND AN UNTRIED PATH ON THE STACK ! 6200: C ! 6201: I = LAT(J+1) ! 6202: GO TO 170 ! 6203: C ! 6204: C MARK ENTRY AS VISITED ! 6205: C ! 6206: 210 LL = PNODE - 1 ! 6207: DO 220 L=1,LL ! 6208: IF (J.NE.NODE(L)) GO TO 220 ! 6209: INODE(L) = 1 ! 6210: GO TO 230 ! 6211: 220 CONTINUE ! 6212: C ! 6213: C ENTER ON STACK ! 6214: C ! 6215: 230 IF (ILEN+2.GT.LSTACK) GO TO 260 ! 6216: STACK(ILEN+1) = I ! 6217: STACK(ILEN+2) = J ! 6218: ILEN = ILEN + 2 ! 6219: GO TO 50 ! 6220: 240 RETURN ! 6221: 250 SYSERR = .TRUE. ! 6222: GO TO 240 ! 6223: 260 CALL ERROR1(33H IN SCAN, TABLE OVERFLOW OF STACK, 33) ! 6224: GO TO 250 ! 6225: 270 CALL ERROR1(31H IN SCAN, TABLE OVERFLOW OF LAT, 31) ! 6226: GO TO 250 ! 6227: END ! 6228: C XXXXXSETARG.f ! 6229: INTEGER FUNCTION SETARG(PP, N) ! 6230: INTEGER PLAT, DSA, PP, SYMLEN, PDSA ! 6231: LOGICAL ERR, SYSERR, ABORT ! 6232: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 6233: COMMON /DETECT/ ERR, SYSERR, ABORT ! 6234: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 6235: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4 ! 6236: C ! 6237: C SETS UP LIST OF ARGUMENTS , HANGING OFF NODE AT LAT(PP) ! 6238: C ARGES ARE KEPT IN ORDERED LINEAR LINKED LIST ! 6239: C ORDERING CORRESPONDS TO LEFT TO RIGHT APPEARENCE IN DEFN ! 6240: C N-SUBPRGM ENTRY IN DSA ! 6241: C PP- CURRENT RTNE NODE IN LAT ! 6242: C ARGUMENT NODE ! 6243: C WD 1 ATTRIBUTES ! 6244: C WD2 LENGTH WITH -1 FOR VARIABLEY DIMENSIONED ARRAYS ! 6245: C WD3 HEAD OF PARENT REFS LIST ! 6246: C WD4 HEAD OF DESCENDENTS REFS LIST ! 6247: C WD5 PTR TO NEXT ARG ! 6248: C ! 6249: C FIND FIRST ARGUMENT & ZERO COUNT ! 6250: C ! 6251: J = DSA(N+2) ! 6252: SETARG = 0 ! 6253: IPROC = 0 ! 6254: C ! 6255: C FIND FIRST ENTRY ON DSA ARGLIST; ! 6256: C KK HEAD OF TO BE CREATED ARGLIST IN LAT ! 6257: C ! 6258: I = DSA(J) ! 6259: KK = PP + SYMLEN + 1 ! 6260: C ! 6261: C SETUP STORAGE FOR ARG ENTRY ! 6262: C ! 6263: 10 IF (PLAT+4.GE.LLAT) GO TO 80 ! 6264: C ! 6265: C ENTER ATTRIBUTE WORD AND ZERO REST OF ENTRY ! 6266: C ! 6267: LAT(PLAT) = DSA(I) ! 6268: LAT(KK) = PLAT ! 6269: KK = PLAT + 3 ! 6270: DO 20 IA=1,3 ! 6271: L = IA + PLAT ! 6272: LAT(L) = 0 ! 6273: 20 CONTINUE ! 6274: K = IGATT1(I,8) ! 6275: IF (K.NE.10) GO TO 50 ! 6276: C ! 6277: C GET STRUCTURE OF ARG ! 6278: C ! 6279: K = IGATT1(I,7) ! 6280: IF (K) 40, 40, 30 ! 6281: C ! 6282: C ARRAY ! 6283: C ! 6284: 30 K = DSA(I+2) ! 6285: LAT(PLAT+1) = DSA(K) ! 6286: GO TO 60 ! 6287: C ! 6288: C SCALAR ! 6289: C ! 6290: 40 LAT(PLAT+1) = 1 ! 6291: GO TO 60 ! 6292: C SET RELATIVE ORDER OF PROC ARGS IN ITS 2ND WORD ! 6293: 50 IPROC = IPROC + 1 ! 6294: LAT(PLAT+1) = IPROC ! 6295: C ! 6296: C CHECK FOR MORE ARGS; ADVANCE PLAT ! 6297: C ! 6298: 60 PLAT = PLAT + 4 ! 6299: SETARG = SETARG + 1 ! 6300: IF (DSA(J+1)) 90, 90, 70 ! 6301: 70 J = DSA(J+1) ! 6302: I = DSA(J) ! 6303: GO TO 10 ! 6304: 80 SYSERR = .TRUE. ! 6305: CALL ERROR1(33H IN SETARG, TABLE OVERFLOW OF LAT, 33) ! 6306: 90 RETURN ! 6307: END ! 6308: C XXXXXSETASF.f ! 6309: SUBROUTINE SETASF(PP, K) ! 6310: INTEGER PP, SYMLEN, PLAT, PDSA, SETARG, PNODE, DSA ! 6311: LOGICAL ERR, SYSERR, ABORT ! 6312: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 6313: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 6314: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 6315: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4 ! 6316: COMMON /DETECT/ ERR, SYSERR, ABORT ! 6317: C ! 6318: C SETUP ASF NODE; IT HAS A NODE JUST LIKE A RTNE ! 6319: C EXCEPT ITS INDEX IN NODE IS NEGATIVE ! 6320: C PP-COM ADDRESS OF PARENT SUBPGM ! 6321: C K-DSA ADDRESS OF ASF ENTRY ! 6322: C ! 6323: IF (PNODE+1.GT.LNODE) GO TO 40 ! 6324: IF (PLAT+SYMLEN+11.GT.LLAT) GO TO 60 ! 6325: C ! 6326: C CREATE NEW NODE ENTRY ! 6327: C ! 6328: NODE(PNODE) = -PLAT ! 6329: PNODE = PNODE + 1 ! 6330: C ! 6331: C ENTER NAME AND ZERO REST OF NODE ! 6332: C ! 6333: DO 10 I=1,SYMLEN ! 6334: L = K + 3 + I ! 6335: LL = PLAT + I - 1 ! 6336: LAT(LL) = DSA(L) ! 6337: 10 CONTINUE ! 6338: DO 20 I=1,6 ! 6339: L = LL + I ! 6340: LAT(L) = 0 ! 6341: 20 CONTINUE ! 6342: C ! 6343: C SET LAST ELEMENT TO TYPE OF PGM UNIT ! 6344: C STORE IN SAME WORD ASF TYPE ! 6345: C ! 6346: I = IGATT1(K,1) ! 6347: LAT(L+1) = 4 + 8*MOD(I,8) ! 6348: C ! 6349: C SETUP PARENT'S LIST TO POINT TO PP IN ASF NODE ! 6350: C ! 6351: L = PLAT + SYMLEN + 3 ! 6352: LAT(L) = L + 4 ! 6353: LAT(L+4) = PP ! 6354: LAT(L+5) = 0 ! 6355: KQ = PLAT ! 6356: PLAT = L + 6 ! 6357: C ! 6358: C SETUP REFERENCE IN PP'S DESCENDENTS LIST ! 6359: C ! 6360: II = PP + SYMLEN + 4 ! 6361: LAT(PLAT) = KQ ! 6362: LAT(PLAT+1) = LAT(II) ! 6363: LAT(II) = PLAT ! 6364: PLAT = PLAT + 2 ! 6365: C ! 6366: C SETUP ARGUMENTS ! 6367: C ! 6368: L = KQ + SYMLEN ! 6369: LAT(L) = SETARG(KQ,K) ! 6370: 30 RETURN ! 6371: 40 CALL ERROR1(34H IN SETASF, TABLE OVERFLOW OF NODE, 34) ! 6372: 50 SYSERR = .TRUE. ! 6373: GO TO 30 ! 6374: 60 CALL ERROR1(33H IN SETASF, TABLE OVERFLOW OF LAT, 33) ! 6375: GO TO 50 ! 6376: END ! 6377: C XXXXXSETCOM.f ! 6378: SUBROUTINE SETCOM(PP, K) ! 6379: LOGICAL SYSERR, ERR, ABORT, BLANK ! 6380: INTEGER PLAT, DSA, SYMLEN, PP, PDSA, COM, PCOM, R(5), S(3), ! 6381: * FINDND, ST, SS(1), FINDCM ! 6382: INTEGER ZERO(1) ! 6383: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 6384: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 6385: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 6386: COMMON /DETECT/ ERR, SYSERR, ABORT ! 6387: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4 ! 6388: COMMON /COMS/ LCOM, PCOM, COM(300) ! 6389: C ! 6390: C COM ENTRY ! 6391: C WORD 1.....PACKED CHARACTERS OF COMMON-NAME ! 6392: C WORD 2....TOTAL LENGTH OF COMMON BLOCK ! 6393: C WORD 3.....1 IF COMMON INITIALIZED BY BLOCK DATA SUBPGM ! 6394: C 0 IF NOT ! 6395: C WORDS 4-8...TOTAL LENGTHS OF COMPLEX, DOUBLE PRECIS, ! 6396: C REAL, INTEGER, LOGICAL DATA TYPES RESPECTIVELY ! 6397: C WORD 9.....INDEX IN LAT OF ENTRY OF P.U. WHICH CONTAINS ! 6398: C THIS DEFN OF THE COMMON BLOCK ! 6399: C ! 6400: C FINDS COMMON BLOCK ENTRY IN COM- ELSE CREATES AND INITIALIZES NEW ! 6401: C ENTRY. CHECKS NEW ENTRY BLOCK NOT ALREADY A SUBPGM NAME. ! 6402: C GATHERS INFO ON ORDER, TYPE, LENGTH OF ENTRIES IN THE COMMON- ! 6403: C CHECKS FOR VARIABLY DIMENSIONED ARRAYS. ! 6404: C FORMS COMMONLIST ENTRY FOR BLOCK OFF SUBPGM AT LAT(PP) ! 6405: C IF FOUND COMMON IN COM, COMPARES OLD DEFN TO NEW FOR ORDER, LEN, ! 6406: C TYPE OF ENTRIES; FLAGS INCONSISTENCIES; NOTES IF COMMON IN ! 6407: C TWO BLOCK DATA PGMS. COMMON IS AT DSA(K) ! 6408: C ! 6409: DATA R(1), R(4) /2*1/, R(2), R(3), R(5) /3*2/, ST /1H*/ ! 6410: DATA ZERO(1) /0/ ! 6411: C ! 6412: C CHECK ISNT IN NODE AS PROCEDURE NAME ! 6413: C ! 6414: IF (FINDND(DSA(K+4),KK)) 20, 20, 10 ! 6415: 10 CALL ERROR2(41H COMMON BLOCK HAS SAME NAME AS SUBPROGRAM, 41, ! 6416: * DSA(K+4), 1, 1, 1) ! 6417: C ! 6418: C CHECK IF IN COM ALREADY ! 6419: C ! 6420: 20 KK = FINDCM(DSA(K+4)) ! 6421: IF (KK) 30, 30, 60 ! 6422: C ! 6423: C CREATE NEW ENTRY ! 6424: C ! 6425: 30 IF (PCOM+SYMLEN+5.GT.LCOM) GO TO 260 ! 6426: DO 40 I=1,SYMLEN ! 6427: L = PCOM + I - 1 ! 6428: LL = K + I + 3 ! 6429: COM(L) = DSA(LL) ! 6430: 40 CONTINUE ! 6431: C ! 6432: C MARK COMMON SET WHEN IT IS CREATED BY A BLOCK-DATA ! 6433: C SUBPROGRAM WHICH SET IT ! 6434: C ! 6435: DO 50 I=1,4 ! 6436: LL = L + I ! 6437: COM(LL) = 0 ! 6438: 50 CONTINUE ! 6439: COM(LL+1) = PP ! 6440: IF (IGATT1(NAME,8).EQ.11 .AND. IGATT1(K,2).EQ.1) COM(L+2) = 1 ! 6441: KK = PCOM ! 6442: PCOM = PCOM + SYMLEN + 5 ! 6443: C ! 6444: C GATHER INFO ABT LENGTH,TYPE,ORDER OF ELEMENTS ! 6445: C ! 6446: 60 L = 0 ! 6447: S(1) = 0 ! 6448: S(2) = 0 ! 6449: S(3) = 0 ! 6450: I = DSA(K+2) ! 6451: 70 IF (I) 130, 130, 80 ! 6452: C ! 6453: C READING LIST OF ELEMENTS IN COMMON-CHECK TYPE,STRUCTURE ! 6454: C ! 6455: 80 K1 = IGATT1(DSA(I),1) ! 6456: K2 = IGATT1(DSA(I),7) ! 6457: K1 = MOD(K1,8) ! 6458: IF (K1.EQ.5) K1 = 2 ! 6459: C ! 6460: C R(I) CONTAINS PROPER ORDER OF TYPE I IN DEFN OF COMMON ! 6461: C ! 6462: LL = R(K1+1) ! 6463: IF (LL.LT.L) GO TO 120 ! 6464: IF (K2) 90, 90, 100 ! 6465: 90 S(LL) = S(LL) + 1 ! 6466: GO TO 110 ! 6467: 100 K2 = DSA(I) ! 6468: K2 = DSA(K2+2) ! 6469: S(LL) = S(LL) + DSA(K2) ! 6470: 110 I = DSA(I+1) ! 6471: L = LL ! 6472: GO TO 70 ! 6473: C ! 6474: C ACCUMULATE COUNTS OF TYPES-NOTE TYPES OUT OF ORDER CAUSES ! 6475: C TRUNCATION OF THE DEFINITION ! 6476: C ! 6477: 120 CALL ERROR2(41H ILLEGAL ORDERING OF DATA-TYPES IN COMMON, 41, ! 6478: * COM(KK), 1, 1, 0) ! 6479: CALL ERROR2(1H1, 0, ZERO(1), -1, 0, 1) ! 6480: 130 S(3) = S(1) + S(2) ! 6481: C ! 6482: C HANG COMMONLIST ENTRY OFF PP NODE, IF NOT ALREADY THERE FROM SET ! 6483: C ! 6484: L = PP + SYMLEN + 2 ! 6485: I = MATCH(LAT(L),2,-K) ! 6486: IF (I.GT.0) GO TO 140 ! 6487: I = MATCH(LAT(L),2,KK) ! 6488: IF (I.LE.0) GO TO 150 ! 6489: 140 LAT(I) = KK ! 6490: GO TO 160 ! 6491: C ! 6492: C CREATE NEW ENTRY ! 6493: C ! 6494: 150 IF (PLAT+3.GT.LLAT) GO TO 280 ! 6495: LAT(PLAT) = KK ! 6496: LAT(PLAT+1) = 0 ! 6497: LAT(PLAT+2) = LAT(L) ! 6498: LAT(L) = PLAT ! 6499: PLAT = PLAT + 3 ! 6500: 160 I = KK + SYMLEN ! 6501: IF (COM(I)) 170, 170, 190 ! 6502: C ! 6503: C NEW DEFN ! 6504: C ! 6505: 170 COM(I) = S(3) ! 6506: COM(I+2) = S(1) ! 6507: COM(I+3) = S(2) ! 6508: 180 RETURN ! 6509: C ! 6510: C COMPARE LENGTHS OF EACH TYPE ! 6511: C ! 6512: 190 L = KK + SYMLEN + 2 ! 6513: BLANK = .FALSE. ! 6514: CALL S5UNPK(COM(KK), SS(1), 1) ! 6515: IF (SS(1).EQ.ST) BLANK = .TRUE. ! 6516: IBR = 0 ! 6517: IF (COM(L+1).NE.S(2)) IBR = 1 ! 6518: IF (COM(L).NE.S(1)) IBR = -1 ! 6519: C BLANK COMMON DEFNS MATCH ! 6520: IF (IBR.EQ.0 .AND. BLANK) GO TO 180 ! 6521: C NAMED COMMON DEFNS MATCH ! 6522: IF (IBR.EQ.0 .AND. .NOT.BLANK) GO TO 210 ! 6523: C BLANK COMMON DONT MATCH ! 6524: IF (IBR.NE.0 .AND. BLANK) GO TO 230 ! 6525: C NAMED COMMONS DONT MATCH -- ERROR ! 6526: 200 CALL ERROR2(25H INCOMPATIBLE COMMON DEFN, 25, COM(KK), 1, 1, ! 6527: * 0) ! 6528: K1 = KK + SYMLEN + 4 ! 6529: K1 = COM(K1) ! 6530: CALL ERROR2(3H IN, 3, LAT(K1), 1, 0, 0) ! 6531: CALL ERROR2(4H AND, 4, LAT(PP), 1, 0, 1) ! 6532: IF (BLANK) GO TO 180 ! 6533: C ! 6534: C CHECK DOUBLE SETTING OF BLOCK ! 6535: C ! 6536: 210 IF (IGATT1(K,2).NE.1 .OR. IGATT1(NAME,8).NE.11) GO TO 180 ! 6537: IF (COM(L-1).NE.1) GO TO 220 ! 6538: CALL ERROR2( ! 6539: * 53H COMMON BLOCK INITIALIZED IN TWO BLOCK DATA SUBPGMS , 53, ! 6540: * COM(KK), 1, 1, 1) ! 6541: GO TO 180 ! 6542: 220 COM(L-1) = 1 ! 6543: GO TO 180 ! 6544: C ! 6545: C CHECK ARE LENGTHENING BLANK COMMON OFF THE END ! 6546: C ! 6547: 230 IF(IBR.EQ.(-1)) GOTO 250 ! 6548: C ARE LENGTHENING OFF END ! 6549: C KEEP LONGEST DEFN ! 6550: IF (COM(L+1).GT.S(2)) GO TO 180 ! 6551: 240 COM(L+1) = S(2) ! 6552: LL = SYMLEN + KK ! 6553: COM(LL) = S(3) ! 6554: COM(LL+4) = PP ! 6555: GO TO 180 ! 6556: C SEE ARE REALLY LENGTHENING OFF END IF ! 6557: C DEFNS DIFFER IN FIRST DATA TYPE AREAS ! 6558: 250 IF (S(1).LT.COM(L) .AND. S(2).EQ.0) GO TO 180 ! 6559: IF (.NOT.(S(1).GT.COM(L) .AND. COM(L+1).EQ.0)) GO TO 200 ! 6560: COM(L) = S(1) ! 6561: GO TO 240 ! 6562: 260 CALL ERROR1(33H IN SETCOM, TABLE OVERFLOW OF COM, 33) ! 6563: 270 SYSERR = .TRUE. ! 6564: GO TO 180 ! 6565: 280 CALL ERROR1(33H IN SETCOM, TABLE OVERFLOW OF LAT, 33) ! 6566: GO TO 270 ! 6567: END ! 6568: C XXXXXSETEXT.f ! 6569: SUBROUTINE SETEXT ! 6570: INTEGER Z, FINDND, PLAT, PNODE, PP, SS(3), SYMLEN ! 6571: INTEGER BLANK ! 6572: LOGICAL ERR, SYSERR, ABORT ! 6573: COMMON /SCR1/ LINODE, INODE(500) ! 6574: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 6575: COMMON /INTS/ Z(346) ! 6576: COMMON /DETECT/ ERR, SYSERR, ABORT ! 6577: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 6578: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6 ! 6579: DATA BLANK /1H / ! 6580: C ! 6581: C SUBROUTINE SETS UP DEFNS FOR BASIC EXTERNAL FCNS USED IN PASS 1 ! 6582: C FLUSH PAST INTRINSICS IN TABLE ! 6583: C ! 6584: K = 1 ! 6585: DO 10 I=1,31 ! 6586: K = K + Z(K) + 2 ! 6587: 10 CONTINUE ! 6588: C ! 6589: C SEARCH EXTERNAL ENTRIES IN TABLE TO SEE WHICH HAVE BEEN USED ! 6590: C ! 6591: DO 90 I=1,24 ! 6592: N = K + Z(K) + 1 ! 6593: L = Z(N)/1024 ! 6594: IF (L) 80, 80, 20 ! 6595: C ! 6596: C SEE IF THIS EXTERNAL FCN HAS BEEN USER DEFINED ! 6597: C ! 6598: 20 L = Z(K) ! 6599: DO 30 J=1,SYMLEN ! 6600: SS(J) = BLANK ! 6601: 30 CONTINUE ! 6602: CALL S5PACK(Z(K+1), SS, L) ! 6603: LL = FINDND(SS(1),J) ! 6604: IF (LL.NE.0) GO TO 80 ! 6605: C ! 6606: C SETUP LATTICE ENTRY FOR THIS EXERNAL FCN ! 6607: C ! 6608: IF (PNODE+1.GE.LNODE) GO TO 120 ! 6609: IF (PLAT+SYMLEN+8.GE.LLAT) GO TO 110 ! 6610: C SET LEVEL OF BASIC EXTERNAL FUNCTION TO -2 ! 6611: INODE(PNODE) = -2 ! 6612: NODE(PNODE) = PLAT ! 6613: PNODE = PNODE + 1 ! 6614: DO 40 J=1,SYMLEN ! 6615: L = PLAT + J - 1 ! 6616: LAT(L) = SS(J) ! 6617: 40 CONTINUE ! 6618: PP = PLAT ! 6619: PLAT = PLAT + SYMLEN ! 6620: LAT(PLAT) = MOD(Z(N),512)/128 ! 6621: L = PLAT + 1 ! 6622: LL = PLAT + 5 ! 6623: DO 50 NN=L,LL ! 6624: LAT(NN) = 0 ! 6625: 50 CONTINUE ! 6626: LAT(PLAT+6) = 6 + 8*MOD(Z(N),8) ! 6627: NO = LAT(PLAT) ! 6628: PLAT = PLAT + 7 ! 6629: C ! 6630: C FILL IN ARG ENTRIES ! 6631: C NO CONTAINS NUMBER OF ARGS ! 6632: C ! 6633: IF ((PLAT+4)*NO.GE.LLAT) GO TO 110 ! 6634: L = PP + SYMLEN + 1 ! 6635: 60 LL = PLAT + 3 ! 6636: DO 70 NN=PLAT,LL ! 6637: LAT(NN) = 0 ! 6638: 70 CONTINUE ! 6639: CALL SATT2(PLAT, 1, MOD(Z(N),64)/8) ! 6640: CALL SATT2(PLAT, 4, 1) ! 6641: CALL SATT2(PLAT, 8, 10) ! 6642: LAT(L) = PLAT ! 6643: LAT(PLAT+1) = 1 ! 6644: L = PLAT + 3 ! 6645: PLAT = PLAT + 4 ! 6646: IF (NO.EQ.1) GO TO 80 ! 6647: NO = NO - 1 ! 6648: GO TO 60 ! 6649: 80 K = N + 1 ! 6650: 90 CONTINUE ! 6651: 100 RETURN ! 6652: 110 CALL ERROR1(33H IN SETEXT, TABLE OVERFLOW OF LAT, 33) ! 6653: GO TO 130 ! 6654: 120 CALL ERROR1(34H IN SETEXT, TABLE OVERFLOW OF NODE, 34) ! 6655: 130 SYSERR = .TRUE. ! 6656: GO TO 100 ! 6657: END ! 6658: C XXXXXSETPD.f ! 6659: SUBROUTINE SETPD(I, K2) ! 6660: INTEGER PDSA, DSA, PLAT, SYMLEN ! 6661: LOGICAL ERR, SYSERR, ABORT ! 6662: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6 ! 6663: COMMON /DETECT/ ERR, SYSERR, ABORT ! 6664: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 6665: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 6666: C ! 6667: C SUBROUTINE ADDS PGM UNIT AT LAT(I) ONTO K2 DESC-LIST ! 6668: C ADDS K2 ONTO I PARENTS LIST ! 6669: C ! 6670: IF (PLAT+4.GT.LLAT) GO TO 20 ! 6671: C ! 6672: C SEE THAT K2 IS NOT ALREADY ON I PARENTS LIST ! 6673: C 0 RETURN INDICATES EMPTY LIST OR NO MATCH ! 6674: C ! 6675: J = I + SYMLEN + 3 ! 6676: IF (MATCH(LAT(J),1,K2).NE.0) GO TO 10 ! 6677: LAT(PLAT+1) = LAT(J) ! 6678: LAT(PLAT) = K2 ! 6679: LAT(J) = PLAT ! 6680: J = K2 + SYMLEN + 4 ! 6681: LAT(PLAT+3) = LAT(J) ! 6682: LAT(PLAT+2) = I ! 6683: LAT(J) = PLAT + 2 ! 6684: PLAT = PLAT + 4 ! 6685: 10 RETURN ! 6686: C ! 6687: C ERROR RETURNS ! 6688: C ! 6689: 20 SYSERR = .TRUE. ! 6690: CALL ERROR1(32H IN SETPD, TABLE OVERFLOW OF LAT, 32) ! 6691: GO TO 10 ! 6692: END ! 6693: C XXXXXSETREF.f ! 6694: SUBROUTINE SETREF(GREEN,INDIR) ! 6695: INTEGER CHK1, KBR(1) ! 6696: INTEGER REF, PREF, PDSA, DSA, PLAT, PNODE, FINDND, SYMLEN ! 6697: LOGICAL ERR, SYSERR, ABORT, COMPAR, GREEN, INDIR ! 6698: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 6699: COMMON/ SCR1/ LINODE, INODE(500) ! 6700: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 6701: COMMON /CREF/ LREF, PREF, REF(100) ! 6702: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 6703: COMMON /DETECT/ ERR, SYSERR, ABORT ! 6704: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 6705: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6 ! 6706: COMMON /TABL/ NEXT, LABHD, ISYM, IBNEXT ! 6707: DATA IBR /1/, JBR /3/, KBR(1) /0/ ! 6708: C ! 6709: C GREEN = T IF ENCOUNTER EXTERNAL ENTITIES AT ALL ! 6710: C INDIR = T IF ENCOUNTER ANY INDIRECT REFS ! 6711: C READS IN ALL REFS FOR A PROGRAM UNIT; FINDS MISSING ! 6712: C SUBPROGRAM REFS AND DISCARDS THEM; CHECKS ASF REFS AND ! 6713: C DISCARDS THEM; WRITES INDIRECT REFS OUT ON I6 WITHOUT ! 6714: C PROCESSING; DOES MINIMAL CHECKING OF DIRECT REFS ! 6715: C CREATING PAR/DESC LINKS AND WRITING GOOD ! 6716: C REFS OUT ON I6, AFTER DONE WITH REFS, SEARCHES ! 6717: C FOR EXTERNAL ENTITIES (USAGE 13) TO FIX UP LEVELS ! 6718: C ! 6719: IJK = FINDND(DSA(NAME+4),IIJK) ! 6720: C READ IN A NEW REF; IF HIT END OF REFS RECORD ! 6721: C END OF REFS ON I6 AND RETURN ! 6722: 10 IF (INREF(I5)) 20, 20, 80 ! 6723: C WRITE END OF REFS ! 6724: 20 WRITE (I6) IBR, JBR, IBR ! 6725: C CHECK FOR NON DUMMY EXTERNALS IN SYMBOL TABLE WHICH ! 6726: C C AUSE CHANGES IN LEVEL CALCS ! 6727: K = ISYM ! 6728: 30 IF (K) 40, 40, 50 ! 6729: 150 SYSERR=.TRUE. ! 6730: CALL ERROR1(33H IN SETREF, TABLE OVERFLOW OF LAT,33) ! 6731: 40 RETURN ! 6732: 50 IF (IGATT1(K,8).NE.13 .OR. IGATT1(K,4).EQ.1) GO TO 70 ! 6733: L = FINDND(DSA(K+4),IL) ! 6734: IF (L.NE.0) GO TO 60 ! 6735: CALL ERROR2(18H MISSING EXTERNAL , 18, DSA(K+4), 1, 1, 0) ! 6736: CALL ERROR2(1H1,0,KBR(1),-1, 0, 1) ! 6737: GO TO 70 ! 6738: C FOUND AN EXTERNAL ENTITY ! 6739: 60 GREEN = .TRUE. ! 6740: C ENTER ONTO GREEN LINKS LIST AT NODE ! 6741: N = IJK + SYMLEN + 3 ! 6742: C J IS HEAD OF GREEN LINKS LIST (SEE SETPD) ! 6743: 160 IF(LAT(N+1).LE.0) GOTO 170 ! 6744: N = LAT(N+1) ! 6745: GOTO 160 ! 6746: 170 J = N+1 ! 6747: IF(PLAT+2.GT.LLAT) GOTO 150 ! 6748: LAT(PLAT) = -L ! 6749: LAT(PLAT+1) = LAT(J) ! 6750: LAT(J) = -PLAT ! 6751: PLAT = PLAT+2 ! 6752: IF(-2.EQ.INODE(IL).OR.INODE(IL).GT.INODE(IIJK)) GOTO 70 ! 6753: INODE(IL) = INODE(IIJK) + 1 ! 6754: CALL ASLEV(-IL) ! 6755: IF (ABORT .OR. SYSERR) GO TO 40 ! 6756: 70 K = DSA(K+3) ! 6757: GO TO 30 ! 6758: C ! 6759: C REF IS WD1--NUMBER OF ARGS(2 WD ENTRIES) ! 6760: C WD2--PTR TO PGM UNIT CALLED IN DSA ! 6761: C WD3--STMT NO OF CALL ! 6762: C WD4--CODE, 0 FOR SUBR REFS; 1 FOR FCN REFS ! 6763: C WD5+-ARG ENTRIES (WD1-SYMBOL TABLE INDEX OR 0 ! 6764: C WD2-TYPE/STRUCTURE INFO) ! 6765: C ! 6766: 80 IF (REF(4).LT.4) GO TO 100 ! 6767: C ! 6768: C ASF REFERENCE; CHECKED AND THEN DISCARDED ! 6769: C ! 6770: K1 = PNODE - 1 ! 6771: DO 90 I=1,K1 ! 6772: IF (NODE(I).GE.0) GO TO 90 ! 6773: IJR = IABS(NODE(I)) ! 6774: L = IJR + SYMLEN + 3 ! 6775: L = LAT(L) ! 6776: K = REF(2) ! 6777: C ! 6778: C IF HAVE ASF REF, FIND ASF BY NAME AND PAR CHECKS ! 6779: C ! 6780: IF (COMPAR(DSA(K+4),LAT(IJR)) .AND. LAT(L).EQ.IJK) GO TO 110 ! 6781: 90 CONTINUE ! 6782: L = REF(2) + 4 ! 6783: CALL ERROR2(18H MISSING ASF DEFN , 18, DSA(L), 1, 1, 0) ! 6784: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1) ! 6785: GO TO 10 ! 6786: C ! 6787: C WRITE INDIRECT REF OUT ON I6 ! 6788: C ! 6789: 100 K2 = IGATT1(REF(2),4) ! 6790: IF(K2.EQ.0) GOTO 140 ! 6791: INDIR = .TRUE. ! 6792: GOTO 130 ! 6793: C CHECK FOR MISSING SUBPROGRAM ! 6794: 140 K1 = REF(2) ! 6795: IJR = FINDND(DSA(K1+4),IIJR) ! 6796: IF (IJR.NE.0) GO TO 110 ! 6797: CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(K1+4), 1 ! 6798: * ,1, 0) ! 6799: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1) ! 6800: GO TO 10 ! 6801: C CHECK DIRECT REFS AND ASF REFS ! 6802: C 1 MEANS OK 0 MEANS N.G. ! 6803: 110 IF (CHK1(IJK,IJR)) 10, 10, 120 ! 6804: 120 IF (REF(4).EQ.4) GO TO 10 ! 6805: C GOOD DIRECT REF; CREATE PAR/DES LINKS ! 6806: CALL SETPD(IJR, IJK) ! 6807: IF (SYSERR) GO TO 40 ! 6808: IF (-2.EQ.INODE(IIJR) .OR. INODE(IIJR).GT.INODE(IIJK)) GO TO 130 ! 6809: C FIX UP LEVELS ! 6810: INODE(IIJR) = INODE(IIJK) + 1 ! 6811: CALL ASLEV(IIJR) ! 6812: IF (SYSERR .OR. ABORT) GO TO 40 ! 6813: 130 WRITE (I6) PREF, IBR, (REF(L),L=1,PREF) ! 6814: GO TO 10 ! 6815: END ! 6816: C XXXXXUNSAFE.f ! 6817: SUBROUTINE UNSAFE ! 6818: C ! 6819: C ROUTINE READS IN ALL DIRECT AND INDIRECT REFS FOR THE CURRENT ! 6820: C PGM-UNIT; CHECKS FOR THE 3 UNSAFE REFS ! 6821: C ! 6822: LOGICAL IBR ! 6823: INTEGER PLAT, PDSA, DSA, SYMLEN, PREF, REF, INREF, FINDCM ! 6824: COMMON /CREF/ LREF, PREF, REF(100) ! 6825: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 6826: COMMON /FACTS/ NAME, I1, I2, IASF ! 6827: COMMON /PARAMS/ I3, I4, I5, SYMLEN, I6, I7, I8 ! 6828: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 6829: 10 IF (INREF(I7).LE.0) RETURN ! 6830: C CHECK FOR REF WITHOUT ARGS ! 6831: I = REF(1) ! 6832: IF (I.EQ.0) GO TO 10 ! 6833: LL = REF(2) ! 6834: L = LL + SYMLEN + 1 ! 6835: L = LAT(L) ! 6836: C ! 6837: C LPOINTS TO DUMMY ARGUMENT IN LAT ! 6838: C ! 6839: DO 70 K=1,I,2 ! 6840: J = 4 + K ! 6841: IF (REF(J).EQ.0) GO TO 20 ! 6842: N = IGATT1(REF(J),8) ! 6843: IF (N.EQ.10 .OR. N.EQ.4) GO TO 30 ! 6844: GO TO 60 ! 6845: C ! 6846: C LOOK FOR EXPRESSION BEING MATCHED TO AN ARG WHICH ! 6847: C IS SET; TYPE 1 UNSAFE REF ! 6848: C ! 6849: 20 IF (IGATT2(L,5).EQ.0) GO TO 60 ! 6850: CALL ERROR2( ! 6851: * 56H EXPRESSION MATCHED TO POSSIBLY SET ARG IN REFERENCE TO , ! 6852: * 56, LAT(LL), 1, 1, 0) ! 6853: CALL ERROR2(24H TYPE 1 UNSAFE REFERENCE, 24, REF(3), -1, 0, 1) ! 6854: GO TO 60 ! 6855: C ! 6856: C CHECK FOR ACTUAL ARG IN COMMON BEING SENT DOWN WHERE RTNE ! 6857: C BENEATH CHANGES ARG OR COMMON REGION ! 6858: C TYPE 3 UNSAFE REFERENCE ! 6859: C ! 6860: 30 N = IGATT1(REF(J),2) ! 6861: IF (N.NE.1) GO TO 40 ! 6862: C ! 6863: C SEE IF ACTUAL IS AN ARRAY ! 6864: C ! 6865: N = IGATT2(L,7) ! 6866: IF (N.NE.0) GO TO 40 ! 6867: N = REF(J) + 2 ! 6868: N = DSA(N) ! 6869: N = DSA(N+1) + 4 ! 6870: N = FINDCM(DSA(N)) ! 6871: NN = LL + SYMLEN + 2 ! 6872: NN = MATCH(LAT(NN),2,N) ! 6873: IF (NN.EQ.0) GO TO 40 ! 6874: N = IGATT2(L,5) ! 6875: IF (N.EQ.0 .AND. LAT(NN+1).EQ.0) GO TO 40 ! 6876: CALL ERROR2(42H ARG OR COMMON MAY BE SET BY REFERENCE TO , 42, ! 6877: * LAT(LL), 1, 1, 0) ! 6878: CALL ERROR2(24H TYPE 3 UNSAFE REFERENCE, 24, REF(3), -1, 0, 1) ! 6879: C ! 6880: C CHECK FOR DO CONTROL VAR OR LIMIT MATCHED ! 6881: C TO DUMMY ARG POSSIBLY SET ! 6882: C ! 6883: 40 NN = IGATT2(L,5) ! 6884: IF (NN.EQ.0) GO TO 60 ! 6885: NN = REF(J+1)/32 ! 6886: IF (NN.NE.1) GO TO 50 ! 6887: CALL ERROR2( ! 6888: * 51H DO CONTROL VARIABLE OR LIMIT CAN BE SET IN REF TO , 51, ! 6889: * LAT(LL), 1, 1, 0) ! 6890: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1) ! 6891: C ! 6892: C CHECK FOR ADJUSTIBLE DIMENSION VARIABLE MATCHED TO DUMMY ! 6893: C ARG POSSIBLY SET ! 6894: C ! 6895: 50 NN = REF(J+1)/64 ! 6896: IF (NN.NE.1) GO TO 60 ! 6897: CALL ERROR2( ! 6898: * 52H ADJUSTIBLE DIMENSION VARIABLE CAN BE SET IN REF TO , ! 6899: * 52, LAT(LL), 1, 1, 0) ! 6900: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1) ! 6901: 60 L = LAT(L+3) ! 6902: 70 CONTINUE ! 6903: C ! 6904: C CHECK FOR SAME ACTUAL ARG SENT DOWN FOR DIFFERENT DUMMY-ARGS ! 6905: C AND ONE OF DUMMIES MAY BE SET ! 6906: C ! 6907: C TYPE 2 UNSAFE REFERENCE ! 6908: IF (REF(1).LE.2) GO TO 130 ! 6909: LR = LL + SYMLEN + 1 ! 6910: LR = LAT(LR) ! 6911: C ! 6912: C OUTER LOOP GOES TO NEXT TO LAST ARG ! 6913: C ! 6914: I = REF(1) + 3 ! 6915: II = I - 2 ! 6916: DO 120 K=5,II,2 ! 6917: J = REF(K) ! 6918: IF (J.EQ.0) GO TO 110 ! 6919: JBR = IGATT1(J,8) ! 6920: IF (JBR.NE.10 .AND. JBR.NE.4) GO TO 110 ! 6921: L = LAT(LR+3) ! 6922: MM = K + 2 ! 6923: DO 100 M=MM,I,2 ! 6924: IF (REF(M).NE.J) GO TO 90 ! 6925: C ! 6926: C HAVE TWO ACTUALS MAPPED ONTO DIFFERENT DUMMIES ! 6927: C ! 6928: C IF BOTH DUMMIES ARE ARRAYS OR BOTH ARE UNSET, NO UNSAFE ! 6929: IF( IGATT2(L,7).NE.0 .AND. IGATT2(LR,7).NE.0 ) GOTO 90 ! 6930: IF( IGATT2(L,5).EQ.0 .AND. IGATT2(LR,5).EQ.0 ) GOTO 90 ! 6931: 80 CALL ERROR2(64 ! 6932: *H ACTUAL ARG ASSOCIATED WITH 2 DUMMY ARGS POSSIBLY SET IN REF TO ! 6933: *, 64, LAT(LL), 1, 1, 0) ! 6934: CALL ERROR2(24H TYPE 2 UNSAFE REFERENCE, 24, REF(3), -1, 0, 1) ! 6935: 90 L = LAT(L+3) ! 6936: 100 CONTINUE ! 6937: 110 LR = LAT(LR+3) ! 6938: 120 CONTINUE ! 6939: C ! 6940: C CHECK FOR EXTERNAL FCNS WITHIN ASF-DEFS WHICH CONTAIN ! 6941: C ASF-DUMMIES AND WHICH SET THEIR ARGS ! 6942: C ! 6943: 130 IF (REF(4).NE.1) GO TO 10 ! 6944: II = REF(1) + 3 ! 6945: IBR = .FALSE. ! 6946: DO 140 K=5,II,2 ! 6947: J = REF(K) ! 6948: IF (J.EQ.0) GO TO 140 ! 6949: IF (IGATT1(J,8).EQ.1) IBR = .TRUE. ! 6950: 140 CONTINUE ! 6951: IF (.NOT.IBR) GO TO 10 ! 6952: C ! 6953: C SEE IF EXTERNAL FCN SETS ANY OF ITS ARGS ! 6954: C ! 6955: K = LL + SYMLEN + 1 ! 6956: K = LAT(K) ! 6957: II = REF(1)/2 ! 6958: DO 150 L=1,II ! 6959: IF (IGATT2(K,8).EQ.10 .AND. IGATT2(K,5).EQ.1) IBR = .FALSE. ! 6960: 150 CONTINUE ! 6961: IF (IBR) GO TO 10 ! 6962: CALL ERROR2(37H ILLEGAL USAGE OF ASF-DUMMY IN REF TO, 37, ! 6963: * LAT(LL), 1, 1, 0) ! 6964: CALL ERROR2(1H , 0, REF(3), -1 ,0, 1) ! 6965: GO TO 10 ! 6966: END ! 6967: C XXXXXCHECKS.f ! 6968: SUBROUTINE CHECKS(IROOT) ! 6969: C ! 6970: C MAIN IS INDEX IN NODE OF SUPEROOT IN LAT ! 6971: C ! 6972: LOGICAL ERR, SYSERR, ABORT, INSYM ! 6973: COMMON /PARAMS/ I1, I2, I3, I4, I5, I6, I7 ! 6974: COMMON /DETECT/ ERR, SYSERR, ABORT ! 6975: CALL COMCHK(IROOT) ! 6976: CALL SCAN(IROOT) ! 6977: IF (SYSERR) GO TO 20 ! 6978: 10 IF(.NOT.INSYM(I6,0)) GOTO 30 ! 6979: CALL UNSAFE ! 6980: GO TO 10 ! 6981: 20 WRITE (I2,99999) ! 6982: 99999 FORMAT (31H1UNSAFE REFERENCES NOT VERIFIED) ! 6983: 30 RETURN ! 6984: END ! 6985: C XXXXXCONSTR.f ! 6986: SUBROUTINE CONSTR(MAINND) ! 6987: LOGICAL SYSERR, ERR, ABORT, INSYM, GREEN, INDIR ! 6988: LOGICAL OVER ! 6989: C NOTE SETNOD SETS ABORT FOR 2 P.U. WITH SAME NAME ! 6990: C CONSTR SETS ABORT IF IT FINDS NO SYMBOL TABLES FROM PASS1 ! 6991: C ASLEV SETS ABORT IF IT FINDS RECURSION IN CALLING GRAPH ! 6992: INTEGER OUTUT2, OUTUT3, OUTUT4, SYMLEN ! 6993: INTEGER PNODE, PLAT, LS(2) ! 6994: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 6995: COMMON /SCR1/ LINODE, INODE(500) ! 6996: COMMON /PARAMS/ I1, I2, I3, SYMLEN, OUTUT2, OUTUT3, OUTUT4 ! 6997: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 6998: COMMON /DETECT/ ERR, SYSERR, ABORT ! 6999: DATA IBR /1/, JBR /4/ ! 7000: DATA LS(1) /1H,/, LS(2) /1H / ! 7001: C ! 7002: C CONSTR DIRECTS THE FIRST PORTION OF PASS2 ! 7003: C CALLS SETNOD TO CONSTRUCT THE LAT NODES FOR EACH P.U.. ! 7004: C CALLS SETEXT TO SETUP BASIC EXERNALS NODES ! 7005: C AS NEEDED. ! 7006: C CALLS SETREF TO MAKE CONNECTS BETWEEN THE NODES ! 7007: C CALLS INVOKE TO CALCULATE LEVELS AND ASSIMILATE ! 7008: C ALL PROC INFO NECESSARY ! 7009: C CALLS ERASE TO GET RID OF NON-REFERENCE LINKS IN ! 7010: C CALLING GRAPH ! 7011: C CALLS CHKALL TO DO FINAL CHECKS OF ALL REFS AND TO ! 7012: C WRITE ALL GOOD REFS OUT FOR FUTURE PROCESSING ! 7013: C FORMS SUPERROOT IN GRAPH ! 7014: C CALLS OUTPUT ROUTINES WHENEVER CAN, TO GIVE PARTIAL ! 7015: C LISTINGS OF CURRENT DATA STRUCTURE ! 7016: C ! 7017: C USE INSYM TO POSSIBLY SKIP OVER BAD REFS WITH DUMMY SYM TBL ! 7018: C SETREF READS REFS FROM OUTUT3, WRITES ON OUTUT4 ! 7019: C INVOKE READS FROM OUTUT4 ! 7020: C CHKALL READS FROM OUTUT4, WRITES OUTUT3 ! 7021: C UNSAFE READS FROM OUTUT3 ! 7022: C INITIALIZE LEVEL ARRAY AND ISR ! 7023: ISR = 0 ! 7024: DO 10 I=1,LNODE ! 7025: INODE(I) = 0 ! 7026: 10 CONTINUE ! 7027: C INITIALIZE LOGICAL FLAGS FOR DETECTION OF PRESENCE OF ! 7028: C EXTERNAL ENTITIES (GREEN) AND INDIRECT REFS(INDIR) ! 7029: GREEN = .FALSE. ! 7030: INDIR = .FALSE. ! 7031: 20 IF(.NOT.INSYM(0,0)) GOTO 30 ! 7032: C ! 7033: C SUCCESSFULLY READ SYMBOL TABLE ! 7034: C ! 7035: CALL SETNOD ! 7036: IF (SYSERR .OR. ABORT) GO TO 130 ! 7037: GO TO 20 ! 7038: 30 REWIND OUTUT2 ! 7039: IF (PNODE.EQ.1) GO TO 150 ! 7040: C CHANGE LEVEL ON ASFS SO DONT PROCESS THEM ! 7041: L = PNODE - 1 ! 7042: DO 40 I=1,L ! 7043: IF (NODE(I).LT.0) INODE(I) = -2 ! 7044: 40 CONTINUE ! 7045: C ! 7046: C SETUP BASIC EXTERNAL DEFNS AS NEEDED ! 7047: C ! 7048: CALL SETEXT ! 7049: IF (SYSERR) GO TO 130 ! 7050: C ! 7051: C READ IN SYMBOL TABLES ! 7052: C SETREF WILL READ IN REFS ! 7053: C ! 7054: 50 IF(.NOT.INSYM(OUTUT3, OUTUT4)) GOTO 60 ! 7055: CALL SETREF ( GREEN, INDIR ) ! 7056: IF (SYSERR .OR. ABORT) GO TO 130 ! 7057: GO TO 50 ! 7058: 60 REWIND OUTUT2 ! 7059: REWIND OUTUT3 ! 7060: WRITE (OUTUT4) IBR, JBR, IBR ! 7061: REWIND OUTUT4 ! 7062: IF(.NOT.INDIR) GOTO 70 ! 7063: C ! 7064: C CALL LEVEL ALG ! 7065: C ! 7066: CALL INVOKE ! 7067: IF (ABORT .OR. SYSERR) GO TO 130 ! 7068: REWIND OUTUT2 ! 7069: REWIND OUTUT4 ! 7070: C ! 7071: C CHECK AND EXPAND REFS AND SAVE ALL GOOD ONES FOR LATER ! 7072: C ! 7073: 70 IF(.NOT.INSYM(OUTUT4,OUTUT3)) GOTO 80 ! 7074: CALL CHKALL ! 7075: IF (SYSERR) GO TO 130 ! 7076: GO TO 70 ! 7077: 80 WRITE (OUTUT3) IBR, JBR, IBR ! 7078: C ! 7079: C CONSTRUCT SUPEROOT IN LAT ! 7080: C ! 7081: IF (PNODE+1.GT.LNODE) GO TO 180 ! 7082: IF (PLAT+SYMLEN+7.GT.LLAT) GO TO 160 ! 7083: NODE(PNODE) = PLAT ! 7084: C MAINND IS SUPEROOT INDEX IN NODE ! 7085: C ISR IS SUPEROOT INDEX IN LAT ! 7086: MAINND = PNODE ! 7087: ISR = PLAT ! 7088: PNODE = PNODE + 1 ! 7089: LAT(PLAT) = LS(1) ! 7090: PLAT = PLAT + 1 ! 7091: IF (SYMLEN.EQ.1) GO TO 100 ! 7092: DO 90 I=2,SYMLEN ! 7093: L = PLAT + I - 2 ! 7094: LAT(L) = LS(2) ! 7095: 90 CONTINUE ! 7096: PLAT = L + 1 ! 7097: 100 L = PLAT + 5 ! 7098: DO 110 I=PLAT,L ! 7099: LAT(I) = 0 ! 7100: 110 CONTINUE ! 7101: LAT(L+1) = 5 ! 7102: PLAT = L + 2 ! 7103: C ! 7104: C LOOK FOR CALLABLE PGM UNITS WITHOUT PARENTS ! 7105: C ! 7106: L = PNODE - 2 ! 7107: DO 120 I=1,L ! 7108: K = SYMLEN + 3 + IABS(NODE(I)) ! 7109: IF (LAT(K).EQ.0) CALL SETPD(IABS(NODE(I)), ISR) ! 7110: IF (SYSERR) GO TO 130 ! 7111: 120 CONTINUE ! 7112: 130 IF(.NOT.GREEN) GOTO 190 ! 7113: C ERASE GREEN LINKS ! 7114: L = PNODE - 2 ! 7115: DO 210 I = 1,L ! 7116: C SKIP ASF NODES ! 7117: IF(NODE(I) .LT. 0) GOTO 210 ! 7118: C FIND HEAD OF GREEN LINKS ! 7119: N = NODE(I) + SYMLEN + 3 ! 7120: 220 IF(LAT(N+1) .LE. 0) GOTO 230 ! 7121: N = LAT(N+1) ! 7122: GOTO 220 ! 7123: 230 LAT(N+1) = 0 ! 7124: 210 CONTINUE ! 7125: 190 OVER = SYSERR ! 7126: SYSERR = .FALSE. ! 7127: CALL OUT2 (ISR) ! 7128: SYSERR = SYSERR.OR.OVER ! 7129: IF(SYSERR) CALL ERROR1( ! 7130: * 56H ILLEGAL COMMON USAGE AND UNSAFE REFERENCES NOT VERIFIED, ! 7131: * 56) ! 7132: CALL OUT2C ! 7133: 140 RETURN ! 7134: 150 ABORT = .TRUE. ! 7135: GO TO 140 ! 7136: 160 CALL ERROR1(33H IN CONSTR, TABLE OVERFLOW OF LAT, 33) ! 7137: 170 SYSERR = .TRUE. ! 7138: GO TO 130 ! 7139: 180 CALL ERROR1(34H IN CONSTR, TABLE OVERFLOW OF NODE, 34) ! 7140: GO TO 170 ! 7141: END ! 7142: C XXXXXOUT2.f ! 7143: SUBROUTINE OUT2(ISR) ! 7144: INTEGER SYMLEN, PNODE, BL, PLAT, STACK, Q(3), C(12), ! 7145: * OUTLAT, OUTCOM, OUTUT ! 7146: LOGICAL ERR, SYSERR, ABORT ! 7147: EXTERNAL EXCH ! 7148: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, I1, I2, II1 ! 7149: COMMON /DETECT/ ERR, SYSERR, ABORT ! 7150: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 7151: COMMON /CEXPRS/ LSTACK, STACK(620) ! 7152: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 7153: COMMON /SCR1/ LINODE, INODE(500) ! 7154: DATA C(1) /1HE/, C(2) /1HD/, C(3) /1HR/, C(4) /1HI/, C(5) /1HC/, ! 7155: * C(6) /1HL/, C(7) /1HS/, C(8) /1HA/, C(9) /1HF/, IP /1HP/, IBL ! 7156: * /1H-/, C(12) /1HU/, C(10) /1HB/, C(11) /1HN/ ! 7157: DATA BL /1H / ! 7158: C ! 7159: C ROUTINE PRINTS CALLING GRAPH ! 7160: C ! 7161: IF (PNODE.LE.2) GO TO 110 ! 7162: C ! 7163: C GRAPH ! 7164: C ! 7165: I3 = PNODE - 1 ! 7166: IF (ISR.NE.0) I3 = I3 - 1 ! 7167: C ! 7168: C SORT LATTICE ! 7169: C ! 7170: DO 10 I=1,I3 ! 7171: INODE(I) = IABS(NODE(I)) ! 7172: 10 CONTINUE ! 7173: CALL SSORT(EXCH, LAT, LLAT, INODE, I3, 0) ! 7174: DO 100 IA=1,I3 ! 7175: I = INODE(IA) ! 7176: L = I + SYMLEN + 6 ! 7177: IF (MOD(LAT(L),8).EQ.4) GO TO 100 ! 7178: CALL S5UNPK(LAT(I), STACK(1), 6) ! 7179: WRITE (OUTUT,99999) (STACK(L),L=1,6) ! 7180: 99999 FORMAT (///1X, 6A1//) ! 7181: C ! 7182: C GET ARGS IF ANY ! 7183: C ! 7184: IS = 1 ! 7185: K = SYMLEN + I ! 7186: L = LAT(K) ! 7187: IF (L) 70, 70, 20 ! 7188: 20 K = K + 1 ! 7189: K = LAT(K) ! 7190: IF (L*8.GT.LSTACK) GO TO 120 ! 7191: DO 60 LL=1,L ! 7192: Q(1) = IGATT2(K,8) ! 7193: IF (Q(1).EQ.5 .OR. Q(1).EQ.6 .OR. Q(1).EQ.13) GO TO 30 ! 7194: Q(1) = IGATT2(K,1) ! 7195: Q(2) = IGATT2(K,5) ! 7196: Q(3) = IGATT2(K,7) ! 7197: STACK(IS) = IBL ! 7198: STACK(IS+2) = IBL ! 7199: IF (Q(1).GE.8) STACK(IS) = C(1) ! 7200: L1 = MOD(Q(1),8) + 2 ! 7201: STACK(IS+1) = C(L1) ! 7202: IF (Q(2).EQ.1) STACK(IS+2) = C(7) ! 7203: STACK(IS+3) = C(7) ! 7204: IF (Q(3).NE.0) STACK(IS+3) = C(8) ! 7205: GO TO 40 ! 7206: 30 STACK(IS) = IP ! 7207: STACK(IS+1) = IBL ! 7208: STACK(IS+2) = IBL ! 7209: STACK(IS+3) = IBL ! 7210: 40 DO 50 LK=4,7 ! 7211: L1 = LK + IS ! 7212: STACK(L1) = BL ! 7213: 50 CONTINUE ! 7214: IS = IS + 8 ! 7215: K = LAT(K+3) ! 7216: 60 CONTINUE ! 7217: IS = IS - 1 ! 7218: C PRINT ARGUMENTS ! 7219: K = 48 ! 7220: IF (K.GT.IS) K = IS ! 7221: WRITE(OUTUT,99998)(STACK(LK), LK=1,K) ! 7222: 99998 FORMAT(20H ARGUMENT ATTRIBUTES ,5X,6(8A1,1X)) ! 7223: IF( K.EQ.IS ) GOTO 70 ! 7224: 65 LK = K + 1 ! 7225: K = LK + 47 ! 7226: IF(K.GT.IS) K = IS ! 7227: WRITE(OUTUT,99997) (STACK(L1),L1=LK,K) ! 7228: 99997 FORMAT(25X,6(8A1,1X)) ! 7229: IF(K.LT.IS) GOTO 65 ! 7230: C ! 7231: C GET COMMON NAMES ! 7232: C ! 7233: 70 K = I + SYMLEN + 2 ! 7234: K = OUTCOM(LAT(K),IS) ! 7235: IF (SYSERR) GO TO 110 ! 7236: IF (K.EQ.0) GO TO 80 ! 7237: CALL OUT2A(14H COMMON BLOCKS, 14, IS, 2) ! 7238: C ! 7239: C FIND PARENTS ! 7240: C ! 7241: 80 K = I + SYMLEN + 3 ! 7242: K = OUTLAT(LAT(K),IS,ISR) ! 7243: IF (SYSERR) GO TO 110 ! 7244: IF (K.EQ.0) GO TO 90 ! 7245: CALL OUT2A(22H CALLED BY SUBPROGRAMS, 22, IS, 1) ! 7246: C ! 7247: C FIND DESCENDENTS ! 7248: C ! 7249: 90 K = I + SYMLEN + 4 ! 7250: K = OUTLAT(LAT(K),IS,ISR) ! 7251: IF (SYSERR) GO TO 110 ! 7252: IF (K.EQ.0) GO TO 100 ! 7253: CALL OUT2A(18H CALLS SUBPROGRAMS, 18, IS, 1) ! 7254: 100 CONTINUE ! 7255: 110 RETURN ! 7256: 120 SYSERR = .TRUE. ! 7257: CALL ERROR1(33H IN OUT2, TABLE OVERFLOW OF STACK, 33) ! 7258: GO TO 110 ! 7259: END ! 7260: C XXXXXSETNOD.f ! 7261: SUBROUTINE SETNOD ! 7262: INTEGER PLAT, COM, PNODE, PDSA, DSA, SYMLEN, PP, SYMHD, PCOM, ! 7263: * SETARG, FINDND, FINDCM ! 7264: LOGICAL ERR, SYSERR, ABORT ! 7265: COMMON /COMS/ LCOM, PCOM, COM(300) ! 7266: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 7267: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 7268: COMMON /DETECT/ ERR, SYSERR, ABORT ! 7269: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 7270: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4 ! 7271: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 7272: COMMON /TABL/ NEXT, LABHD, SYMHD, IBNEXT ! 7273: COMMON /SCR1/ LINODE, INODE(500) ! 7274: C ! 7275: C LAT-IS THE CALLING GRAPH PLUS AUXILIARY NODES ! 7276: C PLAT-IS NEXT FREE WORD IN LAT ! 7277: C LLAT-IS LENGTH OF LAT ! 7278: C NODE-IS LIST OF ALL CALLING NODES INDICES IN LAT ! 7279: C (WILL BE IN ALPHABETIC ORDER BEFORE CHECKING COMMENCES) ! 7280: C PNODE-IS NEXT FREE WORD IN NODE ! 7281: C LNODE-IS LENGTH OF NODE ! 7282: C ! 7283: C P.U. NODE IN LAT ! 7284: C WD 1.....PACKED CHARACTERS OF NAME OF SUBPGM ! 7285: C WD2.....NUMBER OF ARGS ! 7286: C WD3.....PTR TO HEAD OF LINEAR LINKED ORDERED LIST OF ! 7287: C ARGUMENT NODES IN LAT ! 7288: C WD4.....PTR TO HEAD OF LINEAR LINKED LIST OF COMMON NODES ! 7289: C IN LAT ! 7290: C WD5.....PTR TO HEAD OF LINEAR LINKED LIST OF INDICES IN ! 7291: C LAT OF ENTRIES FOR PARENT NODES ! 7292: C WD6.....PTR TO HEAD OF LINEAR LINKED LIST OF INDICES IN ! 7293: C LAT OF ENTRIES FOR DESCENDENT NODES ! 7294: C WD7.....PTR TO HEAD OF LINEAR LINKED LIST OF SEQUENCE NOS OF ! 7295: C BAD REFERENCES; INCONSISTANT TYPE OF FCN/SUBR REFERENCE, INCORR ! 7296: C NUMBER OF ARGS, AND RECURSIVE CALL OF SELF ARE THE THREE ! 7297: C TYPES OF BAD REFS ! 7298: C WD8.....BITS 0-2 TYPE OF SUBPGM: 0 SUBR, 1 FCN, 2 BLOCK DATA, ! 7299: C 3 MAIN, 4 ASF, 5 SUPEROOT ! 7300: C BITS 3-5 (IF FCN OR ASF) CONTAIN TYPE OF FCN: 0 DP, 1 RL, ! 7301: C 2 INT, 3 COMP, 4 LOG ! 7302: C ! 7303: C ARGUMENT NODE IN LAT ! 7304: C WD1.....ATTRIBUTES (SAME AS IN DSA, SEE LOOKUP) ! 7305: C WD2.....LENGTH (IN PROCEDURE ARGS THIS WORD POINTS TO ! 7306: C HEAD OF LINEAR LINKED LIST OF ACTUAL SUBPGM NAMES ASSOCIATED ! 7307: C WITH THIS ARG IN THE PROGRAM; ALSO HAVE INDEX IN LAT OF ! 7308: C SUBPRGM IN WHICH THE ASSOC OCCURS ! 7309: C WD 3.....PTR TO HEAD OF LINEAR LINKED LIST OF PARENT ARGS ! 7310: C (ARGS FROM PARENT RTNES SENT DOWN TO BE ASSOC. WITH THIS ARG) ! 7311: C WD 4.....PTR TO HEAD OF LINEAR LINKED LIST OF DESC. ARGS ! 7312: C (ARGS FROM DESC RTNES WHICH THIS ARG IS ASSOC. WITH) ! 7313: C WD 5.....PTR TO NEXT ARG NODE OR 0 ! 7314: C ! 7315: C COMMON NODE IN LAT ! 7316: C WD 1.....INDEX OF ENTRY FOR THIS COMMON IN COM ! 7317: C WD 2.....1 IF COMMON STORED INTO BY THIS P.U. ELSE 0 ! 7318: C WD 3.....PTR TO NEXT COMMON NODE ! 7319: C CREATE NODE PTR TO NEW NODE IN LAT ! 7320: C ! 7321: IF (PNODE.GT.LNODE) GO TO 170 ! 7322: IF (PLAT+SYMLEN+7.GT.LLAT) GO TO 190 ! 7323: C ! 7324: C CHECK IF SUBPROGRAM HAS NAME SAME AS ANOTHER SUBPROGRAM ! 7325: C OR A COMMON BLOCK ! 7326: C ! 7327: II = IGATT1(NAME,8) ! 7328: IF (II.EQ.11) GO TO 10 ! 7329: IF (FINDND(DSA(NAME+4),IROOT)) 10, 10, 20 ! 7330: 10 IF (FINDCM(DSA(NAME+4))) 40, 40, 30 ! 7331: 20 ERR = .TRUE. ! 7332: 30 CALL ERROR2(45H SUBPROGRAM AND/OR COMMON BLOCK NAME CONFLICT, 45, ! 7333: * DSA(NAME+4), 1, 1, 1) ! 7334: IF (.NOT.ERR) GO TO 40 ! 7335: ERR = .FALSE. ! 7336: ABORT = .TRUE. ! 7337: GO TO 160 ! 7338: 40 NODE(PNODE) = PLAT ! 7339: IROOT = PNODE ! 7340: PNODE = PNODE + 1 ! 7341: C ! 7342: C ENTER NAME INTO NODE ! 7343: C ! 7344: DO 50 I=1,SYMLEN ! 7345: L = NAME + 3 + I ! 7346: LL = PLAT - 1 + I ! 7347: LAT(LL) = DSA(L) ! 7348: 50 CONTINUE ! 7349: C ! 7350: C PP POINTS TO CURRENT RTNE NODE IN LAT ! 7351: C ! 7352: PP = PLAT ! 7353: PLAT = LL + 6 ! 7354: LL = LL + 1 ! 7355: DO 60 I=LL,PLAT ! 7356: LAT(I) = 0 ! 7357: 60 CONTINUE ! 7358: C ! 7359: C 0 SUBR, 1 FCN, 2 BLOCK DATA, 3 MAIN, 4 ASF, 5 SUPEROOT ! 7360: C ! 7361: LAT(PLAT+1) = II/4 ! 7362: C INITIALIZE LEVEL OF BLOCK DATA TO -2 ! 7363: IF (LAT(PLAT+1).EQ.2) INODE(IROOT) = -2 ! 7364: IF (LAT(PLAT+1).NE.1) GO TO 70 ! 7365: L = IGATT1(NAME,1) ! 7366: LAT(PLAT+1) = LAT(PLAT+1) + 8*MOD(L,8) ! 7367: 70 PLAT = PLAT + 2 ! 7368: C ! 7369: C HAVING INITIALIZED NODE TO 0, LOOK FOR ARGS ! 7370: C ! 7371: IF (DSA(NAME+2)) 80, 90, 80 ! 7372: 80 L = PP + SYMLEN ! 7373: LAT(L) = SETARG(PP,NAME) ! 7374: IF (SYSERR) GO TO 160 ! 7375: C ! 7376: C READ THROUGH SYMBOL TABLE FOR COMMON BLOCK DEFNS AND ASF DEFS ! 7377: C AND SETTING OF COMMON REGION ! 7378: C ! 7379: 90 K = SYMHD ! 7380: 100 IF (K) 110, 160, 110 ! 7381: 110 LL = IGATT1(K,8) ! 7382: C ! 7383: C CHECK FOR ASF AND COMMON DEFNS OR COMMON ! 7384: C SETTING INFO ! 7385: C ! 7386: GO TO (140, 120, 140, 140, 140, 140, 130, 150, 140, 150, 140, ! 7387: * 140, 140, 140), LL ! 7388: C ! 7389: C CREATE ASF NODE ! 7390: C ! 7391: 120 CALL SETASF(PP, K) ! 7392: IF (SYSERR) GO TO 160 ! 7393: GO TO 140 ! 7394: C ! 7395: C CREATE COM ENTRY ! 7396: C ! 7397: 130 CALL SETCOM(PP, K) ! 7398: IF (SYSERR) GO TO 160 ! 7399: 140 K = DSA(K+3) ! 7400: GO TO 100 ! 7401: C ! 7402: C CHECK IF ELEMENT IN COMMON ! 7403: C ! 7404: 150 LL = IGATT1(K,2) ! 7405: L = IGATT1(K,5) ! 7406: IF (L.NE.1 .OR. LL.NE.1) GO TO 140 ! 7407: L = DSA(K+2) ! 7408: L = DSA(L+1) ! 7409: CALL MKCOM(PP, L) ! 7410: IF (SYSERR) GO TO 160 ! 7411: GO TO 140 ! 7412: 160 RETURN ! 7413: 170 CALL ERROR1(34H IN SETNOD, TABLE OVERFLOW OF NODE, 34) ! 7414: 180 SYSERR = .TRUE. ! 7415: GO TO 160 ! 7416: 190 CALL ERROR1(33H IN SETNOD, TABLE OVERFLOW OF LAT, 33) ! 7417: GO TO 180 ! 7418: END ! 7419: C XXXXXCHK1.f ! 7420: INTEGER FUNCTION CHK1(IR, IE) ! 7421: C ! 7422: C PROGRAM UNIT AT LAT(IR) CALLS PROGRAM UNIT AT LAT(IE) ! 7423: C CHK1 RETURNS 1 IF REF OK ELSE 0 ! 7424: C CHECKS FOR INCONSISTENT SYBPGM USAGE, CORRECT NO. OF ! 7425: C ARGS, CORRECT USAGE MATCH UP OF ARGS ! 7426: C ! 7427: INTEGER PREF, REF, PDSA, DSA, PLAT, SYMLEN, IBR(1) ! 7428: COMMON /CREF/ LREF, PREF, REF(100) ! 7429: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 7430: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 7431: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6 ! 7432: CHK1 = 0 ! 7433: C CHECKS FOR SELF RECURSION ! 7434: IF (IE.NE.IR) GO TO 10 ! 7435: CALL ERROR2(24H RECURSIVE CALL OF SELF , 24, REF(3), -1, 1, 1) ! 7436: GO TO 100 ! 7437: C CHECKS FOR USAGE OF SUBPGM CONSISTENT WITH DEF ! 7438: 10 I = IE + SYMLEN + 6 ! 7439: N = MOD(LAT(I),8) ! 7440: IF (N.EQ.REF(4) .OR. N.EQ.6 .AND. REF(4).EQ.1) GO TO 20 ! 7441: CALL ERROR2(38H INCONSISTENT REFERENCE TO SUBPROGRAM , 38, ! 7442: * LAT(IE), 1, 1, 0) ! 7443: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1) ! 7444: GO TO 100 ! 7445: C CHECKS FOR CORRECT NO. ARGS ! 7446: 20 I = IE + SYMLEN ! 7447: IF (LAT(I).EQ.REF(1)/2) GO TO 30 ! 7448: CALL ERROR2(42H INCORRECT NUMBER OF ARGS IN REFERENCE TO , 42, ! 7449: * LAT(IE), 1, 1, 0) ! 7450: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1) ! 7451: GO TO 100 ! 7452: C ARE DONE WITH REF IF IT HAS NO ARGS ! 7453: 30 CHK1 = 1 ! 7454: IF(LAT(I)) 100, 100, 40 ! 7455: C CHECK USAGES OF ARGS IN CALL VS USAGES OF ARGS IN DEF ! 7456: C N POINTS TO DUMMY ARG ENTRY ! 7457: 40 I = LAT(I) ! 7458: N = IE + SYMLEN + 1 ! 7459: L = 5 ! 7460: DO 80 K=1,I ! 7461: MD = IGATT2(LAT(N),8) ! 7462: IF (MD.NE.13 .AND. MD.NE.5 .AND. MD.NE.6) GO TO 60 ! 7463: C HAVE A PROC ARG IN DEF ! 7464: C NEED A PROC ARG IN REF ! 7465: IF (REF(L).EQ.0) GO TO 50 ! 7466: MR = IGATT1(REF(L),8) ! 7467: IF (MR.EQ.13 .OR. MR.EQ.6 .OR. MR.EQ.5) GO TO 70 ! 7468: 50 IBR(1) = K ! 7469: CALL ERROR2(36H INCOMPATIBLE USAGE ASSOCIATED WITH ,36,IBR,-2,1,0) ! 7470: CALL ERROR2(17H IN REFERENCE TO ,17,LAT(IE), 1, 0, 0) ! 7471: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1) ! 7472: CHK1 = 0 ! 7473: GOTO 70 ! 7474: C HAVE VARIABLE OR ARRAY AS ARG IN DEF ! 7475: C NEED SAME IN REF ! 7476: 60 IF (REF(L).EQ.0) GO TO 70 ! 7477: MR = IGATT1(REF(L),8) ! 7478: IF (MR.EQ.13 .OR. MR.EQ.5 .OR. MR.EQ.6) GO TO 50 ! 7479: 70 N = LAT(N) + 3 ! 7480: L = L + 2 ! 7481: 80 CONTINUE ! 7482: 100 RETURN ! 7483: END ! 7484: C XXXXXCHK2.f ! 7485: INTEGER FUNCTION CHK2(IR, IE) ! 7486: C ! 7487: C PROGRAM UNIT AT LAT(IR) CALLS PROGRAM UNIT AT LAT(IE) ! 7488: C CHK2 RETURNS 1 IF REF IS OK, ELSE 0 ! 7489: C CHECKS TYPE OF FCN IF FCN IS REFERENCED, ! 7490: C CHECKS PROC PARAMETERF FOR COMPATIBLE USAGE AND TYPE ! 7491: C TYPE AND STRUCTURE OF VARIABLE ! 7492: C AND ARRAY ARGS, BUILDS UPWARD LINKS BETWEEN ! 7493: C DUMMIES FOR SETTING INFO TRANSFER IN SCAN ! 7494: C BAD STRUCTURE MATCHING MAKES REF BAD ! 7495: C NO DUMMY LINKS CREATED IN THIS CASE ! 7496: C ! 7497: INTEGER REF, PREF, PDSA, DSA, PLAT, SYMLEN, FINDND, AER(1) ! 7498: LOGICAL ERR, SYSERR, ABORT ! 7499: COMMON /DETECT/ ERR, SYSERR, ABORT ! 7500: COMMON /CREF/ LREF, PREF, REF(100) ! 7501: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 7502: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 7503: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6 ! 7504: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 7505: CHK2 = 1 ! 7506: C CHECK TYPE OF FCN CALLED IF A FCN ! 7507: IF (REF(4).NE.1) GO TO 10 ! 7508: I = IE + SYMLEN + 6 ! 7509: IF (MOD(IGATT1(REF(2),1),8).EQ.LAT(I)/8) GO TO 10 ! 7510: IF (MOD(LAT(I),8).EQ.6 .AND. IGATT1(REF(2),1)/8.NE.1) GO TO 10 ! 7511: CALL ERROR2(39H INCOMPATIBLE FCN TYPE IN REFERENCE TO , 39, ! 7512: * LAT(IE), 1, 1, 0) ! 7513: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1) ! 7514: C CYCLE THROUGH ARGS IF ANY ! 7515: 10 I = IE + SYMLEN ! 7516: IF (LAT(I).EQ.0) GO TO 170 ! 7517: I = LAT(I) ! 7518: N = IE + SYMLEN + 1 ! 7519: L = 5 ! 7520: DO 160 K=1,I ! 7521: AER(1) = K ! 7522: L1 = IGATT2(LAT(N),8) ! 7523: IF (L1.EQ.13 .OR. L1.EQ.6 .OR. L1.EQ.5) GO TO 90 ! 7524: C CHECK STRUCTURE AND TYPE OF VARIABLES ! 7525: C AND ARRAY ARGUMENTS ! 7526: K1 = MOD(IGATT2(LAT(N),1),8) ! 7527: K2 = IGATT2(LAT(N),7) ! 7528: IF (K2.GT.1) K2 = 1 ! 7529: L1 = MOD(REF(L+1),8) ! 7530: L2 = MOD(REF(L+1),32)/8 ! 7531: C ! 7532: C CHECK TYPE, CHECK HOLLERITH CONSTANTS MATCHED ! 7533: C ALWAYS TO INTEGER ARRAYS ! 7534: C ! 7535: IF (L1.NE.5 .OR. REF(L).NE.0) GO TO 20 ! 7536: IF (REF(4).EQ.0 .AND. K2.NE.0 .AND. K1.EQ.2) GO TO 40 ! 7537: CALL ERROR2(33H HOLLERITH CONST ASSOCIATED WITH ,33,AER,-2,1,0) ! 7538: CALL ERROR2(17H IN REFERENCE TO , 17,LAT(IE),1, 0, 0) ! 7539: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1) ! 7540: CHK2 = 0 ! 7541: GO TO 150 ! 7542: 20 IF (K1.EQ.L1 .OR. K1.EQ.2 .AND. L1.EQ.5) GO TO 30 ! 7543: CALL ERROR2(33H MISMATCHED TYPE ASSOCIATED WITH ,33,AER,-2,1,0) ! 7544: CALL ERROR2(17H IN REFERENCE TO ,17,LAT(IE),1, 0, 0) ! 7545: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1) ! 7546: C ! 7547: C CHECK STRUCTURE L2 = 0 SCALAR, 1 ARRAY, 2 ARRAY ELE ! 7548: C ! 7549: 30 IF (K2.EQ.1 .AND. L2.GT.0 .OR. K2.EQ.0 .AND. (L2.EQ.2 .OR. ! 7550: * L2.EQ.0)) GO TO 40 ! 7551: CALL ERROR2(38H MISMATCHED STRUCTURE ASSOCIATED WITH ,38,AER,-2, ! 7552: * 1, 0) ! 7553: CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE),1, 0, 0) ! 7554: CALL ERROR2(1H1, 0, REF(3), -1,0,1) ! 7555: CHK2 = 0 ! 7556: GO TO 150 ! 7557: C ! 7558: C CHECK IF ACTUAL ARG IS NON-PROC DUMMY ARG IN CURRENT PGM UNIT ! 7559: C IF SO CREATE ARGLINK. ! 7560: C NO ARGLINK CREATED IF FCN CALLED IS AN ASF ! 7561: C ! 7562: 40 IF (REF(L).LE.0 .OR. REF(4).EQ.4) GO TO 150 ! 7563: K1 = IGATT1(REF(L),4) ! 7564: IF (K1.EQ.0) GO TO 150 ! 7565: C ! 7566: C FIND REL. POSITION OF CALLING PGM ! 7567: C DUMMY , L1 PTS TO IT IN LAT ! 7568: L3 = DSA(NAME+2) ! 7569: KK = 0 ! 7570: 50 KK = KK + 1 ! 7571: IF (DSA(L3).EQ.REF(L)) GO TO 60 ! 7572: L3 = DSA(L3+1) ! 7573: GO TO 50 ! 7574: 60 K2 = 0 ! 7575: L1 = IR + SYMLEN - 2 ! 7576: 70 L1 = LAT(L1+3) ! 7577: K2 = K2 + 1 ! 7578: IF (K2.LT.KK) GO TO 70 ! 7579: C FIND REL POSITION OF CALLED DUMMY ARG ! 7580: C L2 PTS TO IT IN LAT ! 7581: K1 = 0 ! 7582: L2 = IE + SYMLEN - 2 ! 7583: 80 L2 = LAT(L2+3) ! 7584: K1 = K1 + 1 ! 7585: IF (K1.LT.K) GO TO 80 ! 7586: IF (MATCH(LAT(L2+2),1,L1).NE.0) GO TO 150 ! 7587: IF (PLAT+2.GT.LLAT) GO TO 180 ! 7588: LAT(PLAT) = L1 ! 7589: LAT(PLAT+1) = LAT(L2+2) ! 7590: LAT(L2+2) = PLAT ! 7591: PLAT = PLAT + 2 ! 7592: GO TO 150 ! 7593: C CHECK PROC ARGUMENTS TO SEE THEY ARE CORRECT USAGE AND TYPE ! 7594: C LAT(N) PTS TO DUMMY ARG ENTRY IN LAT ! 7595: C REF(L) PTS TO CORRESP REF ARG IN DSA ! 7596: 90 IF (IGATT1(REF(L),4).EQ.1) GO TO 110 ! 7597: C REFERENCE CONTAINS AN AACTUAL PROC NAME ! 7598: C CHECK FOR MISSING SUBPROGRAM ! 7599: L3 = REF(L) ! 7600: L2 = FINDND(DSA(L3+4),L3) ! 7601: IF (L2.NE.0) GO TO 100 ! 7602: L3 = REF(L) + 4 ! 7603: CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(L3), 1, 1, 0) ! 7604: CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE), 1, 0, 0) ! 7605: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1) ! 7606: GO TO 150 ! 7607: C CALL CHK3 TO PREFORM CHECKS ! 7608: 100 L5 = L2 + SYMLEN + 6 ! 7609: CALL CHK3(LAT(N), L2, L1, MOD(LAT(L5),8), IE, REF(3), AER) ! 7610: GO TO 150 ! 7611: C REFERENCE CONTAINS A DUMMY ARGUMENT MUST CHECK ALL ACTUALS ! 7612: C WHICH CAN CORRESPOND TO THAT DUMMY ! 7613: C FIRST FIND ITS CORRESP ACTUAL, IF ANY ! 7614: 110 L2 = REF(L) ! 7615: L2 = DSA(L2+2) ! 7616: C L2 IS OFFSET AMONG ALL DUMMIES OF LAT(IR) ! 7617: C OF THE DUMMY ARG AT REF(L) ! 7618: L3 = IR + SYMLEN + 1 ! 7619: L3 = LAT(L3) ! 7620: IF (L2.EQ.1) GO TO 130 ! 7621: DO 120 L4=2,L2 ! 7622: L3 = LAT(L3+3) ! 7623: 120 CONTINUE ! 7624: C L3 PTS TO DUMMY ARG IN CALLING RTNE ! 7625: 130 L3 = LAT(L3+1) ! 7626: C L3 CONTAINS OFFSET FOR PROC ACTUALS ! 7627: C MATCHED TO THIS DUMMY ARG ! 7628: C IN TEMPLATED OFF LAT(IR) ! 7629: L2 = IR + SYMLEN + 5 ! 7630: IF (LAT(L2).NE.0) GO TO 140 ! 7631: L3 = REF(L) + 4 ! 7632: CALL ERROR2(35H NO ACTUAL PROCS SUBSTITUTABLE FOR , 35, ! 7633: * DSA(L3), 1, 1, 0) ! 7634: CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE), 1, 0, 0) ! 7635: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1) ! 7636: GO TO 150 ! 7637: C L2 PTS TO ACTUALS TEMPLATE ! 7638: 140 L2 = LAT(L2) ! 7639: L4 = L2 + L3 ! 7640: C LAT(L4) IS ACTUAL PAIRED TO REF(L) ! 7641: L5 = LAT(L4) + SYMLEN + 6 ! 7642: CALL CHK3(LAT(N), LAT(L4), L1, MOD(LAT(L5),8), IE, REF(3), AER) ! 7643: C CYCLE TO NEXT ACTUAL ! 7644: L2 = LAT(L2) + L2 ! 7645: IF (LAT(L2)) 150, 150, 140 ! 7646: 150 L = L + 2 ! 7647: N = LAT(N) + 3 ! 7648: 160 CONTINUE ! 7649: 170 RETURN ! 7650: 180 SYSERR = .TRUE. ! 7651: CHK2 = 0 ! 7652: CALL ERROR1(31H IN CHK2, TABLE OVERFLOW OF LAT, 31) ! 7653: GO TO 170 ! 7654: END ! 7655: C XXXXXFIND.f ! 7656: INTEGER FUNCTION FIND(K) ! 7657: C ! 7658: C FIND HAS TO FIND THE INDEX IN NODE ! 7659: C OF THE LATTICE ENTRY AT K, DOES A ! 7660: C LINEAR SEARCH ON NODE ARRAY ! 7661: C P.U. ASSUMES NODE ARRAY SET UP PROPERLY ! 7662: C AND THAT NODES ITS ASKED TO FIND ARE ALWAYS IN THE ! 7663: C ARRAY SOMEWHERE. CAN BE ASKED TO FIND INDEX OF ! 7664: C ANY NODE IN LATTICE, EVEN ASFS ! 7665: C ! 7666: INTEGER PNODE ! 7667: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 7668: L = PNODE - 1 ! 7669: DO 10 I=1,L ! 7670: IF (K.NE.IABS(NODE(I))) GO TO 10 ! 7671: FIND = I ! 7672: GO TO 20 ! 7673: 10 CONTINUE ! 7674: 20 RETURN ! 7675: END ! 7676: C XXXXXASLEV.f ! 7677: SUBROUTINE ASLEV(IPT) ! 7678: C ! 7679: C ASLEV TAKES A SUBLATTICE WITH ITS ROOT AT NODE(IABS(IPT))) ! 7680: C AND READJUSTS THE LEVELS IN THE SUBLATTICE ! 7681: C IN ACCORDANCE WITH NEW LEVEL AT ROOT ! 7682: C NOTE, IPT LT 0 FROM CALL IN SETREF (EXT) AND FROM ACTUALS ! 7683: C PASSED DOWN IN PROC ! 7684: C ! 7685: INTEGER PNODE, STACK, PLAT, FIND, SYMLEN ! 7686: INTEGER ZERO(1) ! 7687: LOGICAL SYSERR, ERR, ABORT, GR ! 7688: COMMON /DETECT/ ERR, SYSERR, ABORT ! 7689: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 7690: COMMON /SCR1/ LINODE, INODE(500) ! 7691: COMMON /SCR2/ LSTACK, STACK(500) ! 7692: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 7693: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6 ! 7694: DATA ZERO(1) /0/ ! 7695: C ! 7696: C STACK (IS) IS SIGNED NODE INDEX OF SUBPGM ! 7697: C IF GT 0, NODE IS ALONG A RED LINK TO PARENT ! 7698: C IF LT 0, NODE IS ALONG A GREEN LINK TO PARENT ! 7699: C ! 7700: C STACK(IS+1) IS PTR TO TWO WORD DESC ENTRY FOR THIS ! 7701: C SUBPGM, OR 0 FOR END OF DESC LIST ! 7702: C ! 7703: K = IABS (IPT ) ! 7704: K = SYMLEN + NODE(K) + 4 ! 7705: STACK(2) = IPT ! 7706: STACK (1) = IABS ( LAT(K) ) ! 7707: IS = 2 ! 7708: C DOES TOP OF STACK ENTRY HAVE UNVISITED DESC ! 7709: 10 IF (STACK(IS-1).NE.0) GO TO 20 ! 7710: C TEST IF ARE DONE WITH SUBLATTICE ! 7711: IF (IS.EQ.2) RETURN ! 7712: C POP UP A LEVEL IN PATH ! 7713: IS = IS - 2 ! 7714: GO TO 10 ! 7715: C UPDATE ENTRY OF NEXT DESCENDENT TO BE CHECKED ON STACK ! 7716: 20 K = STACK(IS-1) ! 7717: STACK(IS-1) = IABS (LAT(K+1)) ! 7718: C LAT(K) CONTAINS SIGNED INDEX OF DESC BEING PROCESSED ! 7719: C SIGN INDICATES COLOR OF LINK TO PARENT, (I.E. ! 7720: C NODE AT TOP OF STACK) ! 7721: C LT 0 IS GREEN LINK, GT 0 IS RED LINK ! 7722: C L IS INDEX IN NODE(*) OF DESC BEING PROCESSED ! 7723: C KK IS INDEX IN LAT(*) OF DESC BEING PROCESSED ! 7724: LL = 1 ! 7725: IF( LAT(K) .LT. 0) LL = -1 ! 7726: KK = IABS(LAT(K)) ! 7727: L = FIND(KK) ! 7728: C SKIP ALL DESC WITH NEGATIVE LEVELS ! 7729: IF (INODE(L).LT.0) GO TO 10 ! 7730: C SEE IF STACK TOO SHORT FOR LOOPS ! 7731: IF( IS.LE.2) GOTO 40 ! 7732: C CHECK FOR LOOPS IN PATH STACK DESC ! 7733: LOOP = 0 ! 7734: GR = .FALSE. ! 7735: IF(LL.EQ.(-1)) GR = .TRUE. ! 7736: DO 60 I = 2,IS,2 ! 7737: IF(LOOP) 70,70,90 ! 7738: 90 IF(STACK(I).LT.0) GR = .TRUE. ! 7739: GOTO 60 ! 7740: 70 IF(L.EQ.IABS(STACK(I))) LOOP = I ! 7741: 60 CONTINUE ! 7742: C NO LOOPS ! 7743: IF(LOOP.EQ.0) GOTO 40 ! 7744: C LOOP OF MIXED COLORED LINKS ! 7745: C DO NOT STACK DESC ! 7746: IF(GR) GOTO 10 ! 7747: C RECURSION ! 7748: ABORT = .TRUE. ! 7749: CALL ERROR2(19H RECURSIVE CALL OF ,19,LAT(KK), 1, 1, 0) ! 7750: DO 80 K=LOOP,IS,2 ! 7751: KK = IABS(STACK(K)) ! 7752: KK = NODE(KK) ! 7753: 80 CALL ERROR2(11H INVOLVING ,11,LAT(KK),1, 0, 0) ! 7754: CALL ERROR2(1H1, 0, ZERO, -3, 0, 1) ! 7755: 30 RETURN ! 7756: C TEST IF DESC LEVEL IS ALREADY GT LEVEL OF PAR ! 7757: C THEN NEEDNT CHECK PART OF SUBLATTICE UNDER THIS DESC ! 7758: 40 K = IABS (STACK(IS)) ! 7759: IF (INODE(L).GT.INODE(K)) GO TO 10 ! 7760: C PUSH DESC ONTO STACK AFTER FIXING HIS LEVEL ! 7761: INODE(L) = INODE(K) + 1 ! 7762: C TEST AGAINST LNODE BECAUSE SCRATCH ARRAY ! 7763: C IS AS LONG AS NODE ARRAY ! 7764: IF (IS+2.GT.LNODE) GO TO 50 ! 7765: STACK(IS+2) = LL * L ! 7766: K = NODE(L) + SYMLEN + 4 ! 7767: STACK(IS+1) = IABS( LAT(K)) ! 7768: IS = IS + 2 ! 7769: GO TO 10 ! 7770: 50 SYSERR = .TRUE. ! 7771: CALL ERROR1(43H IN ASLEV, PATH LONGER THAN NUMBER OF NODES, 43) ! 7772: GO TO 30 ! 7773: END ! 7774: C XXXXXINVOKE.f ! 7775: SUBROUTINE INVOKE ! 7776: C ! 7777: C PGM UNIT STEPS THROUGH NODES IN INVOCATION ORDER ! 7778: C PUSHING ACTUAL PROC ARGS DOWN LATTICE WHERE NECESSARY ! 7779: C AND READJUSTING LEVEL IF NECESSARY ! 7780: C ! 7781: INTEGER PNODE, PLAT, PDSA, DSA, SYMLEN, PREF, REF, FIND, CHK1, ! 7782: * ZERO(1), FINDND ! 7783: LOGICAL ERR, SYSERR, ABORT, OK, AOK ! 7784: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6 ! 7785: COMMON /DETECT/ ERR, SYSERR, ABORT ! 7786: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 7787: COMMON /SCR1/ LINODE, INODE(500) ! 7788: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 7789: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 7790: COMMON /CREF/ LREF, PREF, REF(100) ! 7791: COMMON /FACTS/ NAME, NOST, ITYPE, IASF ! 7792: DATA ZERO(1)/0/ ! 7793: C NC IS CURRENT NODE, NP IS PREVIOUS NODE PROCESSED ! 7794: NC = 0 ! 7795: 10 NP = NC ! 7796: OK = .TRUE. ! 7797: AOK = .TRUE. ! 7798: C ! 7799: C SEARCH FOR NEXT NODE TO DO, NODE WITH LOWEST POSIT LEVEL IN INODE ! 7800: C UPON ENTRY TO INVOKE, SUPEROOT IS -1, ASFS AND BLOCK DATA ! 7801: C ARE -2. IF CANT FIND A POSITIVE LEVEL ARE DONE ! 7802: C ! 7803: L = PNODE - 1 ! 7804: DO 20 I=1,L ! 7805: IF (INODE(I).LT.0) GO TO 20 ! 7806: NC = I ! 7807: GO TO 40 ! 7808: 20 CONTINUE ! 7809: 30 RETURN ! 7810: 40 J = NC ! 7811: DO 50 I=J,L ! 7812: IF (INODE(I).GE.0 .AND. INODE(I).LT.INODE(NC)) NC = I ! 7813: 50 CONTINUE ! 7814: C READ IN SYMBOL TABLE FOR NODE(NC) AND POSITION REFS CORRECTLY ! 7815: CALL RDSYM(NC, NP) ! 7816: 60 IF (INREF(I6)) 140, 140, 70 ! 7817: C HAVE A REFERENCE TO PROCESS ! 7818: 70 IF (IGATT1(REF(2),4).EQ.1) GO TO 80 ! 7819: C PROCESSING A DIRECT REFERENCE ! 7820: C NEED ONLY PROCESS REF TEMPLATE IF ANY PROC ACTUAL ARGS IN REF ! 7821: L = REF(2) ! 7822: L = FINDND(DSA(L+4),K) ! 7823: CALL PROC(NODE(NC), L, K, AOK) ! 7824: IF (SYSERR .OR. ABORT) GO TO 30 ! 7825: GO TO 60 ! 7826: C PROCESSING AN INDIRECT REF ! 7827: 80 K = NODE(NC) + SYMLEN + 5 ! 7828: K = LAT(K) ! 7829: IF (K.EQ.0) GO TO 150 ! 7830: C K PTS TO A TEMPLATE OF ACTUALS AT LAT(NODE(NC)) ! 7831: C L GIVES REL POSIT AMONG PROC DUMMIES IN LAT(NODE(NC)) ! 7832: C OF PROC DUMMY BEING CALLED ! 7833: L = REF(2) ! 7834: L = DSA(L+2) ! 7835: I = NODE(NC) + SYMLEN + 1 ! 7836: I = LAT(I) ! 7837: IF (L.EQ.1) GO TO 100 ! 7838: DO 90 M=2,L ! 7839: I = LAT(I+3) ! 7840: 90 CONTINUE ! 7841: C ! 7842: C I PTS TO DUMMY PROC ARG ENTRY IN LAT ! 7843: C ! 7844: 100 M = LAT(I+1) + K ! 7845: M = LAT(M) ! 7846: C M PTS TO ACTUAL SUBSTITUTABLE FOR I ! 7847: L = FIND(M) ! 7848: C RECURSION DUE TO INDIRECT REF COMPLETING THE LOOP ! 7849: IF (-1.NE.INODE(L)) GO TO 110 ! 7850: ABORT = .TRUE. ! 7851: CALL ERROR2(26H RECURSIVE LOOP INVOLVING , 26, DSA(NAME+4), 1,1,0) ! 7852: CALL ERROR2(14H AND POSSIBLY , 14, LAT(M), 1, 0, 1) ! 7853: GO TO 30 ! 7854: C NOTE NEED NOT WORRY ABOUT MISSING SUBPGM SINCE ! 7855: C THEN ITS LAT INDEX COULDNOT BE IN TEMPLATE ! 7856: 110 IF (CHK1(NODE(NC),M).EQ.0) GO TO 130 ! 7857: C PROCESSED A LEGAL INDIRET REF ! 7858: CALL SETPD(M, NODE(NC)) ! 7859: IF (SYSERR) GO TO 30 ! 7860: IF (-2.EQ.INODE(L) .OR. INODE(NC).LT.INODE(L)) GO TO 120 ! 7861: INODE(L) = INODE(NC) + 1 ! 7862: CALL ASLEV(L) ! 7863: IF (ABORT .OR. SYSERR) GO TO 30 ! 7864: C LOOK FOR MORE ACTUALS ! 7865: 120 CALL PROC(NODE(NC), M, L, AOK) ! 7866: IF (SYSERR .OR. ABORT) GO TO 30 ! 7867: 130 K = LAT(K) + K ! 7868: K = LAT(K) ! 7869: IF (K) 60, 60, 100 ! 7870: C MARK CURRENT NODE DONE ! 7871: 140 INODE(NC) = -1 ! 7872: GO TO 10 ! 7873: 150 IF (.NOT.OK) GO TO 60 ! 7874: K = NODE(NC) ! 7875: CALL ERROR2(20H NO ACTUAL PROCS IN ,20, LAT(K), 1, 1, 0) ! 7876: CALL ERROR2(28H CANNOT PROCESS FORMAL REFS , 28, ! 7877: * ZERO, -3, 0, 1) ! 7878: OK = .FALSE. ! 7879: GO TO 60 ! 7880: END ! 7881: C XXXXXRDSYM.f ! 7882: SUBROUTINE RDSYM(IC, IP) ! 7883: C ! 7884: C PGM UNIT RDSYM POSITIONS I4,I6 CORRECTLY AND INPUTS SYMBOL ! 7885: C TABLE OF PGM UNIT AT NODE(IC) WHEN LAST ONE READ WAS THAT OF NODE ! 7886: C ! 7887: INTEGER SYMLEN, PDSA, PLAT, FINDND, PNODE, DSA ! 7888: LOGICAL INSYM, L ! 7889: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6 ! 7890: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 7891: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 7892: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 7893: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 7894: IF (IP.LT.IC) GO TO 10 ! 7895: REWIND I4 ! 7896: REWIND I6 ! 7897: 10 L = INSYM(I6,0) ! 7898: IF (FINDND(DSA(NAME+4),I).EQ.NODE(IC)) RETURN ! 7899: 20 IF (INREF(I6).EQ.1) GO TO 20 ! 7900: GO TO 10 ! 7901: END ! 7902: C XXXXXPROC.f ! 7903: SUBROUTINE PROC(IP, IM, IIM, OK) ! 7904: C ! 7905: C P.U. AT LAT(IP) CALLS P.U. AT LAT(IM) (NODE(IIM)) ! 7906: C PROC COLLECTS ACTUAL PROC TEMPLATE(S) FROM THE CALL IF IT CAN ! 7907: C CHECKS FOR MISSING SUBPGMS AND STORES TEMPLATES OFF PGM UNIT ! 7908: C AT LAT(IM), THEM PROC CALLS ASLEV TO READJUST LEVELS OF ACTUALS ! 7909: C SENT TO LAT(IM) VS LEVEL (IM) ! 7910: C ! 7911: LOGICAL ERR, SYSERR, ABORT, OK ! 7912: INTEGER STACK, SYMLEN, PDSA, DSA, REF, PREF, PNODE, PLAT, FINDND, ! 7913: * FIND, SS(120), KBR(1) ! 7914: COMMON /CEXPRS/ LSTACK, STACK(620) ! 7915: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6 ! 7916: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 7917: COMMON /CREF/ LREF, PREF, REF(100) ! 7918: COMMON /HEAD/ LNODE, PNODE, NODE(500) ! 7919: COMMON /SCR1/ LINODE, INODE(500) ! 7920: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 7921: COMMON /DETECT/ ERR, SYSERR, ABORT ! 7922: EQUIVALENCE (SS(1),STACK(501)) ! 7923: DATA KBR(1) /0/ ! 7924: LSS = 501 ! 7925: C ARE THERE ARGS IN THIS REF ! 7926: IF (REF(1).NE.0) GO TO 20 ! 7927: 10 RETURN ! 7928: C CYCLE THROUGH REF ARGS ! 7929: C JJ IS LAST ENTRY IN REF FOR ARGS ! 7930: C IS PTS TO FIRST FREE WD IN STACK ! 7931: C MAX IS 1 IF NO DUMMY PROCS IN REF, ELSE IS EQUAL TO THE ! 7932: C NUMBER OF ACTUAL PROCS SUBSTITUTABLE FOR THE DUMMY PROCS ! 7933: 20 JJ = REF(1) + 4 ! 7934: IS = 1 ! 7935: MAX = 0 ! 7936: DO 90 I=5,JJ,2 ! 7937: C SKIP OVER EXPR AS ACTUAL ARGS AND ALL ACTUALS BUT PROC ARGS ! 7938: IF (REF(I).EQ.0) GO TO 90 ! 7939: IF (REF(I+1).NE.6) GO TO 90 ! 7940: C SEE IF ACTUAL ARG IS DUMMY PROC ARG AT LAT(IP) ! 7941: C OR ACTUAL PROCEDURE ! 7942: IF (IGATT1(REF(I),4).EQ.1) GO TO 40 ! 7943: C HAVE AN ACTUAL PROCEDURE ! 7944: L = REF(I) ! 7945: L = FINDND(DSA(L+4),K) ! 7946: IF (L.NE.0) GO TO 30 ! 7947: C IF, AS GATHERING ACTUAL PROCS MATCHED TO DUMMY PROC ARGS ! 7948: C PROC FINDS A MISSING SUBPROGM, PROCESSING OF THIS REF CEASES ! 7949: L = REF(I) ! 7950: CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(L+4), 1, 1, 0) ! 7951: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1) ! 7952: GO TO 10 ! 7953: 30 IF (IS+2.GT.LSS) GO TO 200 ! 7954: C 2 WD STACK ENTRY FOR AN ACTUAL PROC AS AN ACTUAL ARG ! 7955: C IS FIRST WD - 1, 2ND WD - LAT INDEX OF ACTUAL PROC ! 7956: STACK(IS) = 1 ! 7957: STACK(IS+1) = L ! 7958: IF (MAX.EQ.0) MAX = 1 ! 7959: IS = IS + 2 ! 7960: GO TO 90 ! 7961: C HAVE A DUMMY PROC CHECK OUT NO OF ACTUALS ! 7962: C MATCHED TO IT AND STACK THOSE WITH COUNTER ON TOP ! 7963: 40 L = IP + SYMLEN + 5 ! 7964: L = LAT(L) ! 7965: IF (L.NE.0) GO TO 50 ! 7966: IF (.NOT.OK) GOTO 10 ! 7967: CALL ERROR2(26H MISSING ACTUAL PROCEDURES ,26, KBR(1), -1,1,1) ! 7968: OK = .FALSE. ! 7969: GO TO 10 ! 7970: C COLLECT ACTUALS CORRESPONDING TO THIS PROC ARG ! 7971: C K IS REL POSIT OF PROC ARG AMONG ALL ARGS AT LAT(IP) ! 7972: C L PTS TO TEMPLATE AT LAT(IP) ! 7973: 50 K = REF(I) ! 7974: K = DSA(K+2) ! 7975: C J POINTS TO FIRST ELEMENT ON ARGLIST ! 7976: J = IP + SYMLEN + 1 ! 7977: J = LAT(J) ! 7978: IF (K.LE.1) GO TO 70 ! 7979: DO 60 LL=2,K ! 7980: J = LAT(J+3) ! 7981: 60 CONTINUE ! 7982: C K IS REL POSIT OF PROC ARG AMONG PROC ARGS IN LAT(IP) ! 7983: C THAT IS IT IS OFFSET NECESS TO READ CORRESP ACTUAL ! 7984: C PROCS OFF TEMPLATES AT LAT(IP) ! 7985: C J POINTS TO DUMMY PROC ARG ENTRY IN LAT (IP) ! 7986: 70 K = LAT(J+1) ! 7987: IF (IS+1.GE.LSS) GO TO 200 ! 7988: C J POINTS TO POSITION IN STACK OF COUNT OF HOW MANY ! 7989: C ACTUALS ARE MATCHED TO THIS DUMMY ! 7990: J = IS ! 7991: STACK(IS) = 0 ! 7992: IS = IS + 1 ! 7993: 80 IF (IS+1.GE.LSS) GO TO 200 ! 7994: C N WD STACK ENTRY FOR DUMMY PROC ARGS USED AS ACTUAL ARGS IN REF ! 7995: C WD 1 CONTAINS NO OF ACTUAL PROCS MATCHED TO THE DUMMY ! 7996: C WDS 2 - N CONTAIN THE LAT INDICES OF EACH ACTUAL PROC ! 7997: STACK(J) = STACK(J) + 1 ! 7998: LL = K + L ! 7999: STACK(IS) = LAT(LL) ! 8000: IS = IS + 1 ! 8001: L = LAT(L) + L ! 8002: L = LAT(L) ! 8003: IF (L.NE.0) GO TO 80 ! 8004: IF (STACK(J).GT.MAX) MAX = STACK(J) ! 8005: 90 CONTINUE ! 8006: C HAVE COLLECTED ALL PROC ACTUALS CORRESP TO THE PROC ! 8007: C ARGS IN THE REF, NOTE MAX IS NO OF TEMPLATES RESULTING FROM ! 8008: C THIS REF TO BE PASSED TO LAT(IM) AS LONG AS THEIR DUPS ! 8009: C ARE NOT THERE ALREADY ! 8010: C BUILD EACH TEMPLATE IN LOOP AND CHECK FOR DUPLICATION ! 8011: C IF NOT THERE COPY INTO LAT OFF LAT(IM) AND CHECK LEVEL OF ACTUALS ! 8012: C PASSED DOWN VS LEVEL OF LAT(IM) ! 8013: IF (MAX.EQ.0) GO TO 10 ! 8014: DO 190 I=1,MAX ! 8015: C CREATE PROC INDICES PORTION OF TEMPLATE IN SS ! 8016: K = 1 ! 8017: ISS = 1 ! 8018: 100 IF (K.GE.IS) GO TO 110 ! 8019: L = 1 ! 8020: IF (STACK(K).GT.1) L = I ! 8021: IF (ISS+1.GE.120) GO TO 200 ! 8022: J = K + L ! 8023: SS(ISS) = STACK(J) ! 8024: K = K + STACK(K) + 1 ! 8025: ISS = ISS + 1 ! 8026: GO TO 100 ! 8027: C HAVE TEMPLATE IN SS(1) THROUGH SS(ISS-1) ! 8028: C SEE IF IT HAS A DUPLICATE AT LAT(IM) ! 8029: 110 K = IM + SYMLEN + 5 ! 8030: K = LAT(K) ! 8031: IST = ISS - 1 ! 8032: 120 IF (K.EQ.0) GO TO 150 ! 8033: DO 130 L=1,IST ! 8034: J = K + L ! 8035: IF (LAT(J).NE.SS(L)) GO TO 140 ! 8036: 130 CONTINUE ! 8037: C FOUND DUPLICATE ! 8038: GO TO 190 ! 8039: C HAVENT FOUND A DUPLICATE YET ! 8040: C SEE IF THERE ARE MORE TEMPLATES TO COMPARE ! 8041: 140 K = LAT(K) + K ! 8042: K = LAT(K) ! 8043: GO TO 120 ! 8044: C NOT A DUPLICATE WILL ADD IT ON ! 8045: 150 IF (PLAT+IST+2.LE.LLAT) GO TO 160 ! 8046: CALL ERROR1(32H IN PROC, TABLE OVERFLOW OF LAT , 32) ! 8047: SYSERR = .TRUE. ! 8048: GO TO 10 ! 8049: C MAKE AN ENTRY CONSISTING OF 1ST WORD - NO OF PROCS+1, SUBSEQUENT ! 8050: C WORDS - PROCS LAT INDICES, LAST WORD - PTR ! 8051: C TO NEXT SUCH TEMPLATE ! 8052: 160 DO 170 L=1,IST ! 8053: J = PLAT + L ! 8054: LAT(J) = SS(L) ! 8055: 170 CONTINUE ! 8056: LAT(PLAT) = IST + 1 ! 8057: L = PLAT ! 8058: PLAT = PLAT + IST + 2 ! 8059: J = IM + SYMLEN + 5 ! 8060: LAT(PLAT-1) = LAT(J) ! 8061: LAT(J) = L ! 8062: C CHECK LEVELS ! 8063: DO 180 L=1,IST ! 8064: J = FIND(SS(L)) ! 8065: C FIND HEAD OF GREEN LINKS LIST AT LAT(IM) ! 8066: JR = IM + SYMLEN + 3 ! 8067: JLR = -SS(L) ! 8068: 210 IF(LAT(JR+1) .LE. 0) GOTO 220 ! 8069: JR = LAT(JR+1) ! 8070: GOTO 210 ! 8071: C HAVE TOP OF GREEN LINKS LIST AT LAT(JR) ! 8072: 220 IF(LAT(JR+1) .EQ. 0) GOTO 230 ! 8073: JR = IABS( LAT(JR+1) ) ! 8074: C LOOK FOR DUPLICATE ENTRY ON GREEN LINKS LIST ! 8075: IF(LAT(JR) .EQ. JLR) GOTO 240 ! 8076: GOTO 220 ! 8077: C ADD ON ENTRY TO GREEN LINKS LIST ! 8078: 230 IF(PLAT + 2 .GT. LLAT) GOTO 250 ! 8079: LAT(PLAT) = JLR ! 8080: LAT(PLAT+1) = 0 ! 8081: LAT(JR+1) = -PLAT ! 8082: PLAT = PLAT+2 ! 8083: 240 IF((-1).EQ.INODE(J) .OR. (-2).EQ.INODE(J) .OR. ! 8084: * INODE(J).GT.INODE(IIM)) GOTO 180 ! 8085: INODE(J) = INODE(IIM) + 1 ! 8086: CALL ASLEV (-J) ! 8087: IF (SYSERR .OR. ABORT) GO TO 10 ! 8088: 180 CONTINUE ! 8089: 190 CONTINUE ! 8090: GO TO 10 ! 8091: 200 SYSERR = .TRUE. ! 8092: CALL ERROR1(33H IN PROC, TABLE OVERFLOW OF STACK, 33) ! 8093: GO TO 10 ! 8094: 250 SYSERR = .TRUE. ! 8095: CALL ERROR1(31H IN PROC, TABLE OVERFLOW OF LAT,31) ! 8096: GOTO 10 ! 8097: END ! 8098: C XXXXXCHKALL.f ! 8099: SUBROUTINE CHKALL ! 8100: C ! 8101: C CHKALL READS IN REFS FROM OUTUT4 AND CHECKS THEM ! 8102: C EXPANDS ALL INDIRECTS AND CHECKS THEM, IF ALL OK ! 8103: C WRITES THE EXPANDED VERSION OUT ON OUTUT3 ! 8104: C TEMPLATE WRITTEN OUT CONSISTS OF ! 8105: C PREF - NO OF WORDS TO FOLLOW ! 8106: C IBR - CODE .LT.3 TO SHOW OK REF ! 8107: C REF(1) - 2*NO OF ARGS ! 8108: C IJR - LAT INDEX OF CALLED P.U. ! 8109: C REF(3) - STMT NO OF REF ! 8110: C REF(4) - CODE 0-SUBR, 1-FCN ! 8111: C REF(5 -) - ARG ENTRIES ! 8112: C FOR DIRECT REFS IF OK WRITES THE DIRECT REF OUT ON OUTUT3 ! 8113: C CHKALL WRITES END OF REFS ON OUTUT3 BEFORE RETURNING ! 8114: C ! 8115: INTEGER OUTUT3, OUTUT4, DSA, PDSA, REF, PREF, PLAT, SYMLEN, FINDND ! 8116: INTEGER CHK1, CHK2 ! 8117: LOGICAL ERR, SYSERR, ABORT, QP2, QBR ! 8118: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, OUTUT3, OUTUT4 ! 8119: COMMON /CTABL/ LDSA, PDSA, DSA(5000) ! 8120: COMMON /CREF/ LREF, PREF, REF(100) ! 8121: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 8122: COMMON /DETECT/ ERR, SYSERR, ABORT ! 8123: COMMON /FACTS/ NAME, NOST, ITYP, IASF ! 8124: COMMON /PASS/ QP2, QBR ! 8125: DATA IBR /1/, JBR /3/ ! 8126: C IJK IS CALLING PGM UNIT; IJR IS PGM UNIT CALLED ! 8127: IJK = FINDND(DSA(NAME+4),L1) ! 8128: 10 IF (INREF(OUTUT4)) 20, 20, 30 ! 8129: C WRITE END OF REFS AND RETURN ! 8130: 20 WRITE (OUTUT3) IBR, JBR, IBR ! 8131: QBR = .FALSE. ! 8132: RETURN ! 8133: C CHECK IF REF INDIRECT OR DIRECT ! 8134: 30 IF (IGATT1(REF(2),4).EQ.1) GO TO 40 ! 8135: C HAVE A DIRECT REF ! 8136: IJR = REF(2) ! 8137: IJR = FINDND(DSA(IJR+4),L1) ! 8138: IBAR = CHK2(IJK,IJR) ! 8139: IF (SYSERR) GO TO 20 ! 8140: IF (IBAR.EQ.1) WRITE (OUTUT3) PREF, IBR, REF(1), IJR, ! 8141: * (REF(L),L=3,PREF) ! 8142: GO TO 10 ! 8143: C HAVE AN INDIRECT REF ! 8144: 40 K = IJK + SYMLEN + 5 ! 8145: K = LAT(K) ! 8146: C NOTE HAVE FLAGGED THIS ERROR OF NO ACTUALS AT LAT(IM) ! 8147: C BEFORE IN PROC SO NOW SKIP OVER REF ! 8148: IF (K.EQ.0) GO TO 10 ! 8149: C K POINTS TO ACTUALS TEMPLATE AT CALLING PGM ! 8150: L = REF(2) ! 8151: L = DSA(L+2) ! 8152: J = IJK + SYMLEN + 1 ! 8153: J = LAT(J) ! 8154: IF (L.LE.1) GO TO 60 ! 8155: DO 50 LL=2,L ! 8156: J = LAT(J+3) ! 8157: 50 CONTINUE ! 8158: 60 L = LAT(J+1) ! 8159: C L IS OFFSET IN ACTUALS TEMPLATE OF ACTUALS ! 8160: C CORRESP TO THIS DUMMY ! 8161: 70 J = K + L ! 8162: IJR = LAT(J) ! 8163: QBR = .TRUE. ! 8164: IF (CHK1(IJK,IJR).NE.1) GO TO 80 ! 8165: IBAR = CHK2(IJK,IJR) ! 8166: IF (SYSERR) GO TO 20 ! 8167: IF (IBAR.EQ.1) WRITE (OUTUT3) PREF, IBR, REF(1), IJR, ! 8168: * (REF(L),L=3,PREF) ! 8169: 80 QBR = .FALSE. ! 8170: K = LAT(K) + K ! 8171: K = LAT(K) ! 8172: IF (K) 10, 10, 70 ! 8173: END ! 8174: C XXXXXCHK3.f ! 8175: SUBROUTINE CHK3(IDUM, IACT, IDUM8, IACT8, IE, R, NO) ! 8176: C ! 8177: C CHECKS PROC ARGUMENTS FOR PROPER USAGE AND TYPE ! 8178: C IDUM LAT INDEX DUMY PROC ARG ! 8179: C IACT LAT INDEX ACTUAL PROC ! 8180: C IDUM8 USAGE DUMMY FROM DSA ATTRIBUTES ! 8181: C IACT8 USAGE ACTUAL FROM LAT ENTRY ! 8182: C IE CALLED RTNE ! 8183: C R STMT NO OF CALL ! 8184: C NO CONTAINS THE NUMBER OF PARAMETER BEING CHECKED BY THIS CALL ! 8185: C ! 8186: INTEGER PLAT, R(1), SYMLEN, NO(1) ! 8187: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6 ! 8188: COMMON /GRAPH/ LLAT, PLAT, LAT(6000) ! 8189: C SEPARATE OUT EXTERNAL ENTITIES ! 8190: IF (IDUM8.NE.13) GO TO 20 ! 8191: L = IGATT2(IDUM,1)/8 ! 8192: IF (L.NE.1) GO TO 50 ! 8193: C FURTHER CHECK THAT EPLICITLY TYPED EXTERNAL ENTITIES ! 8194: C MATCH FCNS ! 8195: IF (IACT8.NE.1 .AND. IACT8.NE.6) GO TO 30 ! 8196: C CHECK FCN HAS SAME TYPE ACROSS REF BNDRY ! 8197: 10 L = IACT + SYMLEN + 6 ! 8198: IF (MOD(IGATT2(IDUM,1),8).EQ.LAT(L)/8) GO TO 50 ! 8199: CALL ERROR2(40H INCONSISTENT FCN TYPES IN REFERENCE TO , 40, ! 8200: * LAT(IE), 1, 1, 0) ! 8201: CALL ERROR2(1H1, 0, R(1), -1, 0, 1) ! 8202: GO TO 50 ! 8203: C CHECK SUBROUTINES ! 8204: 20 IF (IDUM8.EQ.6 .AND. IACT8.EQ.0) GO TO 50 ! 8205: C CHECK OUT FCNS ! 8206: IF (IDUM8.EQ.5 .AND. IACT8.EQ.1) GO TO 10 ! 8207: C SEPARATE OUT BASIC EXTERNALS BECAUSE THEY ARE CONSIDERED ! 8208: C TYPED BY THE FORTRAN. ! 8209: IF (IDUM8.EQ.5 .AND. IACT8.EQ.6) GO TO 40 ! 8210: 30 CALL ERROR2( ! 8211: * 50H INCOMPATIBLE PROCEDURE PARAMETER ASSOCIATED WITH ,50, ! 8212: * NO, -2, 1, 0) ! 8213: CALL ERROR2(17H IN REFERENCE TO ,17, LAT(IE), 1, 0, 0) ! 8214: CALL ERROR2(1H1, 0, R(1), -1, 0, 1) ! 8215: GO TO 50 ! 8216: C CHECK BASIC EXTER HAS NOT BEEN EXPLICITLY TYPED ! 8217: C OR ELSE IT HAS TO AGREE WITH THE ACTUAL TYPE ! 8218: 40 L = IACT + SYMLEN + 6 ! 8219: IF (LAT(L)/8.EQ.1) GO TO 10 ! 8220: 50 RETURN ! 8221: END ! 8222: combine done
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.