!                                                         falloc3a
! 20/07/87 - Genfmt, set com_ioareaca=4 if zero
!                                                                falloc2a
! 09/04/87 - include contents of csyn71 instead of ftn_csynt70
!                                                               falloc1a
! 15/01/87 - insert %alis for FORMATCD
!
!                                                               falloc1
! 16/11/86 - incorporate changes up to ftnalloc15
! 23/09/86 - include files inserted
!                                                               ftnalloc13
! 16/09/86 - syntax modified to fault missing WHILE
!                                                               ftnalloc12
! 06/08/86 - use BSS for local arrays when practicable
!                                                               ftnalloc11
! 13/08/86 - allow up to 15Mb of common
! 22/08/86 - correct -I2 action for lit int and log args (in Alloc Const)
!* 07/07/86                                                     ftnalloc10
!*
%include "ftn_ht"
%if target=LATTICE %thenstart
   %externalroutinespec ICdatarec(%integer idrec,adict,anames)
%finish
{%include "ercs01:csyn71"}
!*
!* Syntax tables generated from file SYNTAX71 on 06/04/87 at 16.09.36
!*
%CONSTSHORTINTEGERARRAY COMP(0:3000)=  %C
     0,   258,     0,   258,     0,   259,     0,   260,     0,   261,
     0,   262,     0,   263,     0,   264,     0,     0,     1,  1025,
    50,  5377, 17921,     0,     1,  1026,    70,  5377, 17922,   808,
     0,   265,     0,     0,     1,  1027,    94,  5377, 17923,   552,
    90,   265,     0,     0,     1,     0,     1,  1028,   114,   266,
   108, 17925,     0,     1, 28672,     0,     1,  1029,   146,  5125,
   267,     0,  1026,     0,  5377,  5888, 17922,   808,     0,   265,
     0,     0,     1,   268,   202,   554,   180,  5379,  5632,  1026,
     0,  5377,  5888, 17922,   808,     0,   265,     0,     0,     1,
  1026,     0,  5377,  5888, 17922,   808,     0,   265,     0,     0,
     1,  1030,     0, 20224,     0,     1,  5383,     0,     1,   269,
     0,   573,     0,   270,     0, 15111,  1536,     0,     0,     2,
 27392,  1536,   254,   271,     0,     0,    17,  5376, 13568,  1536,
     0,     0,    22,   272,     0,   273,     0, 32768,  1536,   354,
   554,   302, 15106,   274,     0,   275,   298,     0,    25,     0,
    37,   559,   346,   559,   328, 15106,   274,     0,   275,   324,
     0,    47,     0,    57, 15106,   274,     0,   275,   342,     0,
    64,     0,    76,   275,     0,     0,    86,     0,    94,   555,
   372, 15106,   276,     0,     0,   100,   557,   386, 15106,   276,
     0,     0,   105,   574,   406, 15360,  1536,     0, 15107,   270,
     0,     0,   110,   545,   420, 15108,   270,     0,     0,   114,
   550,   434, 15108,   270,     0,     0,   118,   638,   448, 15108,
   270,     0,     0,   122,   547,     0, 15108,   270,     0,     0,
   128,  1536,     0,   273,     0, 32768,  1536,   528,   554,   498,
 15106,   274,     0,   275,   494,     0,   134,     0,   147,   559,
   520, 15106,   274,     0,   275,   516,     0,   158,     0,   171,
   275,     0,     0,   182,     0,   191,  1536,     0,   273,     0,
   554,   554, 15106,   274,     0,     0,   198,   559,   582,   559,
   572, 15106,   274,     0,     0,   209, 15106,   274,     0,     0,
   218,     0,   229,   277,     0,  1031,   604, 15106,   273,     0,
     0,   236,     0,   242,   552,   644,  5382,  1536,   628, 13568,
  1536,     0,     0,   245, 15616,   271,     0,   809,     0, 15872,
     0,   248,  5376,   552,   776, 14336,  1536,     0, 17664,  1536,
   744,  1536,   714,  1536,   686,   278,     0, 28163, 30720,  1536,
     0,     0,   253,   553,   700,  1536,     0, 20992,     0,   259,
   279,     0,   809,     0, 20992,     0,   261,   280,     0, 13056,
   552,   740,   278,     0, 28163, 30720,  1536,     0,     0,   265,
     0,   273,   553,   758, 14848,  1536,     0,     0,   278,   281,
     0,   809,     0, 14848,  1536,     0,     0,   280, 13568,  1536,
     0,     0,   286,  5377,   552,   878, 16640,  1536,     0, 21504,
  1536,   854,  1536,   824,   278,     0, 28161, 30720,  1536,     0,
     0,   289,   280,     0, 19968,   552,   850,   278,     0, 28161,
 30720,  1536,     0,     0,   295,     0,   303,   553,   864, 20480,
     0,   308,   282,     0,   809,     0, 20480,     0,   311, 13824,
  1536,     0,     0,   314,   555,   898, 15110,     0,   317,   557,
   908, 15110,     0,   320,   604,   938, 15109,   555,   924, 15110,
     0,   323,   557,   934, 15110,     0,   326,     0,   329,     0,
   332,   570,   978, 29696,  1536,     0,   553,   966, 29696,  1536,
     0,     0,   335,   283,     0,   809,     0,     0,   337,   283,
     0,   826,     0,   553,  1000, 29696,  1536,     0,     0,   341,
   283,     0,   809,     0,     0,   345, 15616, 28172,   270,     0,
 15111, 15872,     0,   351, 28172,   285,     0,     0,   356, 27392,
  1536,  1054,   286,     0, 15111,     0,   359,  5376, 26368,  1536,
     0,     0,   364,   272,     0,   287,     0,   288,  1094,   289,
     0,   290,  1090,     0,   367,     0,   379,   290,  1102,     0,
   389,     0,   397,   291,  1118,   292,     0,     0,   403,   293,
     0,   286,     0,     0,   408,  1536,     0,  1536,     0,   287,
     0,   288,  1162,   289,     0,   290,  1158,     0,   413,     0,
   426,   290,  1170,     0,   437,     0,   446,  1536,     0,  1536,
     0,   287,     0,   288,  1198,   289,     0,     0,   453,     0,
   464,   294,     0,  1031,  1220, 15106,   287,     0,     0,   471,
     0,   480,   552,  1260,  5382,  1536,  1244, 26369,  1536,     0,
     0,   483, 15616,   286,     0,   809,     0, 15872,     0,   486,
  5376, 26368,  1536,     0,     0,   491,  1032,  1282, 15106,     0,
   494,   559,  1292, 15106,     0,   497,   554,     0, 15106,     0,
   500,   555,  1312, 15106,     0,   503,   557,     0, 15106,     0,
   506,   574,  1338, 15360,  1536,     0, 15107,     0,   509,   545,
  1348, 15108,     0,   512,   550,  1358, 15108,     0,   515,   638,
  1368, 15108,     0,   518,   547,     0, 15108,     0,   521,   554,
  1402,  5379, 12544,   556,  1398,   281,     0,     0,   524,     0,
     1,   550,  1426,  5379, 12544,   556,  1422,   281,     0,     0,
   527,     0,     1,  1033,  1466,   270,     0, 15111,  1536,     0,
 14592,  1536,     0,   553,     0,   556,  1462,   281,     0,     0,
   530,     0,   541,   295,     0, 15111,  1536,     0, 14592,  1536,
     0,   556,  1494,   281,     0,     0,   544,     0,   555, 27392,
  1536,  1512,   270,     0,     0,   564,  5376, 32256,  1536,     0,
     0,   567,   270,     0, 15111, 16384,  1536,     0,   556,  1548,
   280,     0,     0,   570,   809,     0,     0,   578,  5377, 20736,
   556,  1572,   282,     0,     0,     1,     0,     1,   270,     0,
 15111,  1536,     0, 21248,  1536,     0,   556,  1604,   279,     0,
     0,   584,     0,   597, 32512,  1034,  1638,  5379, 14081,  1536,
     0,  1035,     0,  5377, 11776,  1536,     0,     0,   608,  1036,
  1666,  2566,   296,     0,   556,  1662, 28161,   297,     0,     0,
   614,     0,   626,  1037,  1690,   552,  1682,   298,     0,     0,
   635,   299,     0,     0,   641,  1038,  1708,  2561,  5127, 30976,
   300,     0,     0,     1,  1039,  1768,  5377,   552,  1754, 16896,
  1536,     0,   553,  1736,  1536,     0,     0,   650,   281,     0,
 12800,  1536,     0,   553,     0,     0,   655, 16896,  1536,     0,
  1536,     0,     0,   663,  1040,  1776,     0,   668,  1041,  1788,
   301,     0,     0,     1,  1042,  1802,  6912,   302,     0,     0,
     1,  1043,  1834,  5123, 30976,   554,  1826,  5379,  5632,   303,
     0,     0,     1,   300,     0,     0,     1,  1029,  1854,  5125,
 30976,   267,     0,   303,     0,     0,     1,  1044,  1872,  2562,
  5129, 30976,   300,     0,     0,     1,  1045,  1888,   808,     0,
   298,     0,     0,   670,  1046,  1900,   304,     0,     0,     1,
  1047,  1912,   305,     0,     0,     1,  1048,  1944,  5126, 30976,
   554,  1936,  5379,  5632,   303,     0,     0,     1,   300,     0,
     0,     1,  1049,  1960,  5128, 30976,   300,     0,     0,     1,
  1050,  1996, 33280, 11521,  1536,     0,  1307,     0,   270,     0,
 15111,  1536,     0,   809,     0, 33536,     0,   676,  1052,  2008,
   306,     0,     0,     1,  1053,  2022, 26624,   307,     0,     0,
     1,  1054,  2046,   552,  2038,   298,     0,     0,   682,   299,
     0,     0,   688,  1055,  2056, 28931,     0,   697,  1056,  2066,
 33024,     0,   700,  1057,  2076,  4865,     0,   702,  1058,  2102,
  4864,  5377, 17924,   552,  2098,   265,     0,     0,     1,     0,
     1,  1059,  2130,   270,     0, 15111,  1536,     0,   809,     0,
  1316,     0, 28929,     0,   704,  1061,  2140, 28930,     0,   713,
  1062,  2150, 22528,     0,     1,  1063,  2174,   308,     0,   809,
     0,  1836,     0,   270,     0,     0,   716,  1064,  2190,  5376,
 14080,  1536,     0,     0,   722,  1065,  2222,  5121, 30976,   554,
  2214,  5379,  5632,   303,     0,     0,     1,   303,     0,     0,
     1,  1066,  2248,  1067,  2238,  2563,  9985,     0,     1,   309,
     0,  9984,     0,     1,  1068,  2262, 26627,   307,     0,     0,
     1,  1069,  2278,   808,     0,   298,     0,     0,   724,  1070,
  2288, 33792,     0,     1,  1071,  2320,  5124, 30976,   554,  2312,
  5379,  5632,   303,     0,     0,     1,   303,     0,     0,     1,
  1072,  2342,  2568,  5377, 21760,   815,     0,   310,     0,     0,
     1,  1073,  2358,   808,     0,   298,     0,     0,   730,  1074,
  2384,   296,     0,   556,  2380, 28161,   297,     0,     0,   736,
     0,   748,  1075,  2400,   808,     0,   311,     0,     0,     1,
  1076,  2426, 22784,  1536,  2414,     0,   757,  5381, 12288,  1536,
     0,     0,   759,  1077,  2458,  5122, 30976,   554,  2450,  5379,
  5632,   303,     0,     0,     1,   303,     0,     0,     1,  1078,
  2502,   552,  2480,   312,     0, 28161,   297,     0,     0,   761,
   296,     0,   556,  2498, 28161,   297,     0,     0,   770,     0,
   782,  1079,  2526, 28416,  1536,  2516,     0,   791, 28172,   270,
     0,     0,   793,  1080,  2550,   552,  2542,   298,     0,     0,
   797,   299,     0,     0,   803,  1081,  2576, 22784,  1536,  2564,
     0,   812,  5381, 12288,  1536,     0,     0,   814,  1082,  2600,
 30976, 22784,  1536,  2592,     0,     1,   313,     0,     0,     1,
  1083,  2628,  2567,   296,     0,   556,  2624, 28161,   297,     0,
     0,   816,     0,   828,  1084,  2650,   808,     0,   312,     0,
 28161,   297,     0,     0,   837,  1085,  2660, 10240,     0,     1,
  1086,  2670, 10241,     0,     1,  1030,  2680, 20224,     0,     1,
  1087,     0, 25088,     0,     1,   554,  2748,   552,  2736,   554,
  2716,   809,     0, 31488,  1836,     0,     0,     1,   284,     0,
   809,     0, 31489,  5632,  1836,     0,     0,     1,  5379,  5632,
  1836,     0,     0,     1,     0,     1,   554,  2798,   552,  2790,
   554,  2774,   809,     0, 31490,     0,     1,   284,     0,   809,
     0, 31489,  6144,     0,     1,  5379,  6144,     0,     1,     0,
     1,  1065,  2812,  5121,     0,     1,  1077,  2822,  5122,     0,
     1,  1043,  2832,  5123,     0,     1,  1071,  2842,  5124,     0,
     1,  1048,  2852,  5126,     0,     1,  1029,  2862,  5125,     0,
     1,  1038,  2874,  2561,  5127,     0,     1,  1049,  2884,  5128,
     0,     1,  1044,     0,  2562,  5129,     0,     1,  5377,  5888,
   315,     0,   556,  2916,   300,     0,     0,     1,   559,  2940,
   316,     0,   556,  2936,   300,     0,     0,     1,     0,     1,
     0,     1,  5377,  5888,   315,     0,   314,  2996,   556,  2968,
   303,     0,     0,     1,   559,  2992,   316,     0,   556,  2988,
   303,     0,     0,     1,     0,     1,     0,     1,   556,  3008,
   303,     0,     0,     1,     0,     1,  7680,  7936,   317,     0,
     0,     1,   552,  3038,  6400,   318,     0,     0,     1,     0,
     1,   554,  3058, 29184,   809,     0,  8960,     0,     1,   319,
     0,  6656,   556,  3076,   318,     0,     0,     1,   553,  3086,
  8960,     0,     1,   826,     0,   554,  3106, 29185,   809,     0,
  8960,     0,     1,   319,     0,  6657,   556,  3124,   318,     0,
     0,     1,   809,     0,  8960,     0,     1,   284,     0,     0,
   846,  5381,   554,  3176,  9216,  5381,  9472,   556,  3166,   317,
     0,     0,     1,   815,     0,  9728,     0,     1,  9472,   556,
  3190,   317,     0,     0,     1,   815,     0,  9728,     0,     1,
  5377,   552,     0,  6400,   318,     0,   556,  3224,   304,     0,
     0,     1,     0,     1,   559,  3242,  6912,   302,     0,     0,
     1,  5377,  7168,   815,     0,   302,     0,     0,     1,  5377,
  7424,   315,     0,   556,  3290,   559,  3282,   301,     0,     0,
     1,   302,     0,     0,     1,   559,  3302,   301,     0,     0,
     1,     0,     1,  5377,  7680,   321,     0,   815,     0,   317,
     0, 31232,  1836,     0,   305,     0,     0,     1,  7680,   322,
     0,   559,     0,   317,     0, 31232,  1836,     0,   305,     0,
     0,     1,   552,  3388,   323,     0,   556,  3384,   322,     0,
     0,     1,     0,     1,  5377,   552,  3416,  8192,   324,     0,
   556,  3412,   322,     0,     0,     1,     0,     1,  7936,   556,
  3430,   322,     0,     0,     1,     0,     1, 10496,   325,     0,
     0,     1,   552,  3464,   323,     0,   812,     0,   325,     0,
     0,     1,  5377,   552,  3488, 10497,   326,     0,   812,     0,
   325,     0,     0,     1,   829,     0, 10498,   327,     0, 10499,
   812,     0,   327,     0, 10500,   556,  3530,   327,     0, 10501,
   809,     0, 10503,     0,     1,   809,     0, 10503, 10502,     0,
     1,   327,     0, 10504,   556,  3560,   326,     0,     0,     1,
   809,     0, 10505,     0,     1,   328,     0, 30208,     0,     1,
   285,     0,     0,   851,   552,  3616,  8192,   324,     0,   556,
  3612,  5377,   321,     0,     0,     1,     0,     1,  7936,   556,
  3632,  5377,   321,     0,     0,     1,     0,     1,  8193,  1536,
  3654,   278,     0, 30208,  7937,     0,     1,   329,     0,     0,
     1,   284,     0, 30208,  8448,   556,  3682,   329,     0,     0,
     1,   809,     0,   552,  3702,   278,     0, 30208,  8705,     0,
     1,  8705,     0,     1,  5377, 21761,   556,  3724,   310,     0,
     0,     1,   559,  3746, 21762,  5377, 21760,   815,     0,   310,
     0,     0,     1, 21762,     0,     1,   330,     0, 30208,   556,
  3770,   311,     0,     0,     1,   809,     0,     0,     1,  5377,
   829,     0, 26112,  1536,     0,   285,     0, 30720,  1536,     0,
     0,   856,   268,  3904,   554,  3880,   552,  3852,   284,     0,
   809,     0, 31489,  5632,   808,     0,   331,     0,   556,  3848,
   309,     0,     0,     1,     0,     1,  5379,  5632,   808,     0,
   331,     0,   556,  3876,   309,     0,     0,     1,     0,     1,
   808,     0,   331,     0,   556,  3900,   309,     0,     0,     1,
     0,     1,  1088,     0,  2564,   552,  3936,  5120,   331,     0,
   556,  3932,   309,     0,     0,     1,     0,     1,  9985,     0,
     1, 10752,   557,  3970, 11008,   556,  3962,   331,     0,     0,
     1,   809,     0,     0,     1,   556,  3982,   331,     0,     0,
     1,   809,     0,     0,     1,   808,     0,  5377,  7680,   321,
     0,   809,     0, 11264,   556,  4020,   306,     0,     0,     1,
     0,     1,  5379, 12544,   556,  4040,   308,     0,     0,   861,
 12800,  1536,     0,     0,   864,   332,  4074,   556,  4066,   333,
     0,     0,   867,   809,     0,     0,   872,   299,     0,   556,
  4114,   333,  4090,     0,   875,   296,     0,   556,  4106,   333,
     0,     0,   883,   809,     0,     0,   896,   809,     0,     0,
   907,   332,     0,   556,  4138,   333,     0,     0,   913,   809,
     0,     0,   918,   554,  4154,     0,   921, 28161,   270,     0,
     0,   924,   554,  4172,     0,   927, 28161,   270,     0,     0,
   930,  1089,  4194,   299,     0,     0,   933,  1090,  4206,   296,
     0,     0,   939,  1091,  4220, 28161,   270,     0,     0,   945,
  1092,  4234,  5376,  1536,     0,     0,   951,  1093,  4248,  5376,
  1536,     0,     0,   955,  1094,     0, 28161,   270,     0,     0,
   959,   332,  4286,   556,  4278,   334,     0,     0,   965,   809,
     0,     0,   970,   334,  4294,     0,   973,   299,     0,   556,
  4310,   334,     0,     0,   976,   809,     0,     0,   984, 28161,
   332,  4344,   556,  4336,   334,     0,     0,   990,   809,     0,
     0,   995,   335,     0,   270,     0,   556,  4364,   334,     0,
     0,   998,   809,     0,     0,  1007,  1095,  4380,     0,  1014,
  1096,  4388,     0,  1017,  1097,  4396,     0,  1020,  1098,  4404,
     0,  1023,  1099,  4412,     0,  1026,  1100,  4420,     0,  1029,
  1101,  4428,     0,  1032,  1102,  4436,     0,  1035,  1103,  4444,
     0,  1038,  1104,  4452,     0,  1041,  1105,  4460,     0,  1044,
  1106,  4468,     0,  1047,  1107,  4476,     0,  1050,  1108,  4484,
     0,  1053,  1109,  4492,     0,  1056,  1110,  4500,     0,  1059,
  1111,  4508,     0,  1062,  1112,  4516,     0,  1065,  1113,     0,
     0,  1068,   552,  4608, 18688,   297,     0,   573,  4594, 19456,
  1536,     0,   336,     0,   812,     0,   336,     0,   556,  4576,
   336,     0,   809,     0,   337,     0,     0,  1071, 12033,  1536,
     0,   809,     0,   337,     0,     0,  1086,   809,     0, 23808,
   337,     0,     0,  1099, 32000,  1536,  4640,  1536,  4622,     0,
     1,  5377, 32256, 18432,  1536,     0,   337,     0,     0,  1104,
 28161,   270,     0, 15111,  1536,     0,   337,     0,     0,  1109,
   556,  4674, 17408,   297,     0,     0,  1120,     0,     1,  5377,
 17152,   556,  4694,   307,     0,     0,     1,     0,     1,   559,
  4726,  5377, 31745,   815,     0,   556,  4722,   313,     0,     0,
     1,     0,     1,  5377, 31744,   556,  4742,   313,     0,     0,
     1,     0,     1,   553,  4754,     0,     1,   554,  4780, 18944,
   556,  4772,   265,     0,     0,     1,   809,     0,     0,     1,
  5377, 19200,   556,  4796,   265,     0,     0,     1,   809,     0,
     0,     1,  1114,     0,   270,     0, 15111,  1536,     0,   809,
     0, 16128,  1536,  4872,  4608,  5379, 14080,  4352,  1536,     0,
   556,     0,  5379, 14080,  4352,  1536,     0,   556,     0,  5379,
 14080,  4352,  1536,     0,     0,  1123,  1114,  4940,   270,     0,
 15111,  1536,     0,   553,     0, 16128,  1536,     0,  4608,  5379,
 14080,  4352,  1536,     0,   556,     0,  5379, 14080,  4352,  1536,
     0,   556,     0,  5379, 14080,  4352,  1536,     0,     0,  1130,
  1060,  4950, 28928,     0,  1143,   258,     0,     0,  1152,  1114,
     0,   270,     0, 15111,  1536,     0,   809,     0, 19712,   259,
     0,     0,  1162,   580,     0,   847,     0, 33280, 11520,  1536,
     0,  1836,     0,  5377, 11777,  1536,     0,   829,     0,   336,
     0,   812,     0,   336,     0,   556,  5042,   336,     0,     0,
  1172, 12033,  1536,     0,     0,  1180, 28169,   270,     0, 15111,
     0,  1186,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0,     0,     0,     0,     0,     0,     0,     0,     0,     0,
     0;


{%include "ftn_fmts2"}
!* 09/12/85 - add recordformat SUBFMT
!* modified 14/03/85
!*
!***********************************************************************
!* Formats for accessing dictionary records                            *
!***********************************************************************
!*
%recordformat PRECF(%byteinteger CLASS,TYPE,X0,X1,
                    %integer LINK1, LINK2,
                   (%shortinteger COORD,LINK3  %OR %integer LAST   %C
                        %OR %integer CONSTRES %OR %integer INF3),
                    %integer ADDR4,
                    %shortinteger DISP,LEN,IDEN,IIN,
                    %integer LINE,XREF,CMNLENGTH,CMNREFAD)
!*
%recordformat SRECF(%integer INF0, LINK1, INF2, INF3, INF4)
!*
%recordformat RESF((%integer W %OR %shortinteger H0,
                      (%shortinteger H1 %OR %byteinteger FORM,MODE)))
!*
%recordformat DORECF( %C
    %integer LABEL, LINK1,
    %record(RESF) LOOPAD, ENDREF, INDEXRD, INCRD, FINALRD, ICRD,
    %integer LABLIST,LINE)
!*
%recordformat BFMT(%integer L,U,M)
!*
%recordformat ARRAYDVF(%integer DIMS, ADDRDV,ADDRZERO,  %C
            %integer ZEROTOFIRST, ADFIRST, NUMELS, ELLENGTH,  %C
            %record(BFMT) %ARRAY B(1 : 7))
!*
!*
%recordformat LRECF(%integer NOTFLAG,LINK1,
                    %record(RESF) ORLAB,ANDLAB,
                    %integer RELOP)
!*
%recordformat IFRECF(%integer TYPE,LINK1,
                     %record(RESF) ENDIFLAB,FALSELAB,
                     %integer LABLIST,LINE)
!*
%recordformat LABRECF(%shortinteger BLKIND,%byteinteger X0,X1,  %C
            %integer LINK1,LINK2,LINK3,ADDR4,LINK5,LAB,LINE,  %C
            %shortinteger DOSTART,DOEND,IFSTART,IFEND)
!*
%recordformat PLABF(%shortinteger BLKIND,%byteinteger USE,X1,
                    %integer INDEX,CODEAD,REF,REFCHAIN)
!*
%recordformat IMPDORECF(%integer VAL,LINK,IDEN)
!*
%recordformat CONSTRECF(%shortinteger MODE,LENGTH,
                      (%integer VALUE %OR %integer LINK1),
                      %integer DADDR,CADDR)
!*
%recordformat TMPF((%byteinteger CLASS,TYPE,
                        %shortinteger LEN %OR %integer W0),
                    %integer LINK1,
                    %byteinteger REG,MODE,%shortinteger INDEX,
                    %shortinteger COORD,USECNT,
                    %integer ADDR)
!*
%recordformat CHARF(%integer ADESC,LINK,LEN)
!*
%recordformat FNRECF(%integer FPTR,LINK1,HEAD,PCT)
!*
%recordformat TERECF(%shortinteger MODE,LOOP,
                      %integer CHAIN,DISP1,INDEX,
                      %shortinteger COORD,FLAGS)
!*
%recordformat DTRECF(%shortinteger MODE,IDENT,
                      %integer CHAIN,DISP2,
                      %shortinteger FLAGS,INDEX,
                     (%integer LOOP %OR %record(RESF) CONST))
!*
!*
!***********************************************************************
!* TRIAD record format                                                 *
!***********************************************************************
!*
%recordformat TRIADF(  %C
               %byteinteger OP,
               (%byteinteger USE %OR %byteinteger VAL2),
               %shortinteger CHAIN,
               (%record(RESF) RES1      %OR     %C
               (%shortinteger OPD1,%byteinteger QOPD1,MODE  %OR  %C
               (%integer SLN %OR %integer VAL1))),
               (%record(RESF) RES2      %OR   %C
                %shortinteger OPD2,%byteinteger QOPD2,MODE2))
!*
!***********************************************************************
!* COM record format                                                   *
!***********************************************************************
!*
%recordformat COMFMT(%integer CONTROL,OPT,OPTIONS1,OPTIONS2,PTRACE,
      ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR,
      MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD,
      SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST,
      RESCOM1,RESCOM2,F77PARM,FNO,FAULTY,LINEST,CMNIIN,SFMK,
      LISTL,LISTSTREAM,DIAGSTREAM,LISTMODE,XREF,
      PACKCMN,ITSMODE,PATHANAL,CHARACTER CODE,SPACE CHAR,
      HEADINGS,ARRAYCHECKS,JBRMODE,MESSLEN,NAMESLEN,
      NEXTCH,FUNRESDISP,WARNCOUNT,INP,MAXINP,MESSCOUNT,
      UNASSPATTERN,LISTCODE,PI21INT,DOPTR,SUBPROGPTR,
      FNLST,LAB,NAMESFREE,ALGOLREF,FIRSTSTATNUM,CEXPDICT,
      COMMONBASE,FASTPROLOGUE,STATEMENT,IFPTR,
      CNSTCA,COMMENTCNT,ADIDENT,ADERRIDEN,
      ADEXT,MAXDICT,MAXNAMES,MAXOUTPUT,MAXEXT,
      ACOMP,ASUBNAMES,MAXPSTACK,
      ATRIADS,TRFILEID,TRBLOCK,CMNCNT,SCANONLY,NOISY,
      MAXANAL,MAXGEN,SAVEANAL,SAVEGEN,OPTFLAGS,NEXTBIT,
      ACMNBITS,NEXTTEMP,ASSGOTOS,TMPPTR,DESTEMPS,OBJADDR,
      AREAADDR,PASTART,ADOPTDATA,TMINDEX,VRETURN,ENTRIES,
      EQUCHK,LABWARN,LINENO,MAXIBUFF,
      COMMENTS,DIAGLEVEL,WARNNOT77,WARNLENGTH,ALLOWUNIX,ALLOWVAX,
      ONETRIP,HOST,TARGET,MONERRS,CODECA,
      GLACA,DIAGCA,SSTCA,GSTCA,CONSTCA,SCALARCA,IOAREACA,ZGSTCA,STACKCA,
      W1,W2,W4,STATORDERMODE,CURSTATCLASS,LISTPOINT,STACKBASE,
      NEXTTRIAD,ASAVE,MAXSAVE,SUBTAB,LASTSUBTAB,
      INHIBOP4,ARGCNT,IDCNT,LABCNT,TMLIST,MAINPROG,PROCINDEX,CONSOLE)
!*
!***********************************************************************
!* record format for communicating with optimiser                      *
!***********************************************************************
!*
%recordformat OBJFMT(%string(35) MODULE,%integer MAINEP,I,J,K,
                     ADATE,ATIME,OPTIONS2,EXTPROCS,ATRIADS,MAXTRIADS,
                     ABLOCKS,MAXBLOCKS,ALOOP,MAXLOOP,ATABS,MAXTABS,
                     SRFLAGS,INHIBMASK,OPT,OPTFLAGS,OPTDESC0,OPTDESC1,
                     D1,D2,D3,D4)
!*
!***********************************************************************
!*
!*
%RECORDFORMAT SUBRECF(%INTEGER LINK,FLAGS,TRIADS,DICT,NAMES,PTRS,PROG,
      LABCNT,ARGCNT,IDCNT,TRCNT,REFSCNT,SUBSCNT,
      DPTR,NEXTTRIAD,NAMESFREE,NEXTBIT,SUBPROGTYPE,SUBPROGPTR,
      CBNPTR,SCPTR,CMNIIN,FUNRESDISP,CMNCNT,ASSGOTOS,VRETURN,ENTRIES,
      TMLIST,ALABS,ALHEADS,NEXTPLAB,
      %STRING(32) NAME,%INTEGERARRAY COORDS(0:15))
!*
%CONSTINTEGER SUBSIZE=232
%CONSTINTEGER LABSIZE=128
%CONSTINTEGER LHEADSIZE=620
!*
{%include "ftn_consts"}
!* modified 23/09/86
!*
!*
%constinteger WSCALE = 2;! scale word address to byte address
%constinteger BSCALE = 0;! scaling factor for words to architectural units
%constinteger CSCALE = 0;! byte offset to architectural unit offset
%constinteger DSCALE = 2;! dict pointer scaling in RES records
!*
%constinteger W1 =  4 ;!  1 word  in architectural units
%constinteger W2 =  8 ;!  2 words in architectural units
%constinteger W3 = 12 ;!  3 words in architectural units
%constinteger W4 = 16 ;!  4 words in architectural units
!*
%constinteger TRIADLENGTH    = 12 ;! size of an individual triad
%constinteger BLRECSIZE      = 44 ;! size of a block table entry in architectural units
%constinteger LOOPRECSIZE    = 16 ;! size of a loop table entry
%constinteger PROPRECSIZE    = 12 ;! size of a propagation table entry
%constinteger CLOOPSZ        = 12 ;! size of cloop table entry
%constinteger FRSIZE         =  8 ;! size of freelist created by PUSHFREE
%constinteger TESZ           = 20
%constinteger DTSZ           = 20
%constinteger ARTICSZ        =  4
%constinteger CTSIZE         =  2 ;! used in OP3
%constinteger EXTNSIZE       =  4 ;! used in OP3
!*
!* following used in strength reduction
!*
%constinteger RDSZ           =  8
%constinteger RUSESZ         = 12
%constinteger RTESTSZ        =  4
%constinteger RDEFSZ         = 16
%constinteger USESZ          = 32
%constinteger SRUSESZ        =  2
%constinteger SRSCALE        =  2;! SR==RECORD(ABLOCKS + SRPTR<<SRSCALE)
%constinteger SRFIXED        = 36
!*
!*
%conststring(5) REG1="reg7"
%constinteger GLAOFFSET=32
%if target=ibm %thenstart
   %constinteger dvarea=7
%finishelsestart
   %constinteger DVAREA=2
%finish
!*
!***********************************************************************
!* Constants defining the size of DICT records                         *
!***********************************************************************
!*
   %constinteger IDRECSIZE    = 28;! size of dict entry reserved for a new identifier
   %constinteger CONRECSIZE   = 16
   %constinteger CNSTRECMIN   =  4
   %constinteger IMPDORECSIZE = 12;! size of DATA-implied-DO list item
   %constinteger LABRECSIZE   = 40
   %constinteger PLABRECSIZE  =  8;! N.B. this is a reduced size for compiler using Put interfaces
   %constinteger XREFSIZE     =  8
   %constinteger CMNRECEXT    = 16;! extra space on iden record for common block name
   %constinteger TMPRECSIZE   = 20
   %constinteger DVRECSIZE    = 28
   %constinteger TRIADSIZE    = 12
   %constinteger LBLKSIZE     = 520
!*
!*
!********************* TRIAD qualifiers ********************************
!*
%CONSTINTEGER NULL    = 0
%CONSTINTEGER LABID   = 1
%CONSTINTEGER PLABID  = 2
%CONSTINTEGER PROCID  = 3
%CONSTINTEGER STKLIT  = 4
%CONSTINTEGER GLALIT  = 5
%CONSTINTEGER SRTEMP  = 6
%CONSTINTEGER BREG    = 7
%CONSTINTEGER VALTEMP = 8
%CONSTINTEGER DESTEMP = 9
%CONSTINTEGER LSCALID =16
%CONSTINTEGER OSCALID =17
%CONSTINTEGER CSCALID =18
%CONSTINTEGER ASCALID =19
%CONSTINTEGER PSCALID =20
%CONSTINTEGER ARRID   =21
%CONSTINTEGER TMPID   =22
%CONSTINTEGER PERMID  =23
%CONSTINTEGER STFNID  =24
%CONSTINTEGER ITMPID  =22
%CONSTINTEGER RTMPID  =22
%CONSTINTEGER ETMPID  =22
%CONSTINTEGER TRIAD   =32
%CONSTINTEGER ARREL   =33
%CONSTINTEGER CHAREL  =34
%CONSTINTEGER CHVAL   =35
%CONSTINTEGER LIT     =64
%CONSTINTEGER NEGLIT  =65
%CONSTINTEGER CNSTID  =66
!*
!********************* TRIAD masks *************************************
!*
%CONSTINTEGER CONSTMASK=X'40'
%CONSTINTEGER IDMASK   =X'10'
%CONSTINTEGER TEXTMASK =X'20'
!*
!********************* other useful masks ******************************
!*
%CONSTINTEGER ARRAYBIT  = X'04'
%CONSTINTEGER CMNBIT    = X'02'
%CONSTINTEGER EQUIVBIT  = X'80'
!*
!********************* modes *******************************************
!*
%CONSTINTEGER INT2    = 0, INT4    = 1, INT8    = 2
%CONSTINTEGER REAL4   = 3, REAL8   = 4, REAL16  = 5
%CONSTINTEGER CMPLX8  = 6, CMPLX16 = 7, CMPLX32 = 8
%CONSTINTEGER LOG1    = 9, LOG2    =10, LOG4    =11
%CONSTINTEGER LOG8    =12, CHARMODE=13, HOLMODE =14
%CONSTINTEGER BYTE    =15, HEXCONST=16
!*
!********************* types *******************************************
!*
%CONSTINTEGER INTTYPE   = 1
%CONSTINTEGER REALTYPE  = 2
%CONSTINTEGER CMPLXTYPE = 3
%CONSTINTEGER LOGTYPE   = 4
%CONSTINTEGER CHARTYPE  = 5
!*
!********************* scaling factors *********************************
!*
!*
!********************* length of maximum source statement **************
!*
%CONSTINTEGER INPUT LIMIT = 1328
!*
!********************* mode to bytes etc. ******************************
!*
%CONSTBYTEINTEGERARRAY ModetoBytes(0:15)=  %c
   2,4,8,4,8,16,8,16,32,1,2,4,8,1,0,1
!*
!********************** location of pseudo common record in dict *******
!*
%CONSTINTEGER PSEUDOCMN=20
!*
!********************** location of blank common record in dict ********
!*
%CONSTINTEGER BLCMPTR=96
!*
!********************** other useful consts ****************************
!*
%CONSTINTEGER NO  = 0
%CONSTINTEGER YES = 1
%CONSTINTEGER FULL= 2
!*
!********************** area identifiers *******************************
!*
%constinteger STACK   = 0
%CONSTINTEGER GLA     = 2
%CONSTINTEGER SST     = 4
%CONSTINTEGER GST     = 5
%CONSTINTEGER DIAGS   = 6
%if target=ibm %thenstart
   %constinteger scalars=7
%finishelsestart
   %CONSTINTEGER SCALARS = 2
%finish
%CONSTINTEGER IOAREA  = 8
%CONSTINTEGER ZEROGST = 9
%CONSTINTEGER CONSTS  =10
!*
!********************** system procedures ******************************
!*
%constinteger F77AUX   = 0
%constinteger F77STOP  = 1
%constinteger F77PAUSE = 2
%constinteger F77IOA   = 3
%constinteger F77IOB   = 4
%constinteger F77IOC   = 5
%constinteger F77IOD   = 6
%constinteger F77IOE   = 7
%constinteger F77IOF   = 8
%constinteger F77FILE  = 9
%constinteger IMPSTOP  =10
%constinteger F77RTERR =11
%constinteger F77IOAR  =12
%constinteger F77IOBR  =13
%constinteger F77IOG   =14
%constinteger F77CPSTR =15
%constinteger F77CONCAT=16
%constinteger F77INDEX =17
%constinteger FIBITS   =18
%constinteger FISHFTC  =19
%constinteger F77PCHECK=20
%constinteger F77IOH   =21
%constinteger F77IOI   =22
!***********************************************************************
!*
!*
!*
!***********************************************************************
!* Exports                                                             *
!***********************************************************************
!*
%routinespec   Init Alloc(%integer Mode,Adcom,Rel,Avers)
%routinespec   Alloc(%integer PTR)
%integerfnspec Freesp(%integer n)
%routinespec   Free List Cell(%integername listhead,%integer n)
%integerfnspec New List Cell(%integername listhead,%integer n)
%integerfnspec Setlab(%integer lab,%integername labrecptr)
%integerfnspec Setconrec(%record(resf) res)
%integerfnspec Dict Space(%integer Length)
%integerfnspec Genfmt(%byteintegerarrayname Input,Type,
                      %string(*)%name Identifier)
%routinespec   New Temp(%record(Resf)%name Res,%integer Mode,Use)
%integerfnspec Conin(%integer Val)
%integerfnspec Alloc Const(%integer Resw,%integername IIN)
%integerfnspec New Subprogram(%integer Ptr,P1,Ctyp,%integername Er)
%integerfnspec Formal Parameter(%integer Ptr,Mode,Ctyp)
%routinespec   Dumpdict(%integer Mode)
!*
!***********************************************************************
!* Imports                                                             *
!***********************************************************************
!*
%externalroutinespec Edbytes(%integer area, Disp, len, ad)
%externalroutinespec Ed4(%integer area, Disp, DataQuadbyte)
!*
%externalroutinespec fault(%integer er)
%externalroutinespec ifault(%integer er,val)
%externalroutinespec lfault(%integer er)
%externalroutinespec tfault(%integer er,ta,tb)
%externalintegerfnspec formatcd %alias "s#formatcd" %c
            (%integer fmtbase,fmtdisp,arraybase,
            inlen,outlen,inout,type,%integername tablen,fmtlen)
%externalroutinespec dicful
%externalintegerfnspec Dv Space(%integer LEN,%integername IIN)
%externalintegerfnspec Stack Space(%integer Len)
%externalintegerfnspec Scalar Space(%integer Len,%integername IIN)
%externalintegerfnspec Array Space(%integer Len,%integername IIN,%integer AllowBSS)
%externalintegerfnspec Const Space(%integer Len,%integername IIN)
%externalintegerfnspec Alloc Char(%integer Len,Ad,%integername IIN)
%externalintegerfnspec Char Ref(%integer IIN,Disp,Len)
%externalroutinespec Set Array Head(%integer Adv,IIN,Disp,Addrzero,Type)
%externalintegerfnspec Newcmn(%integer Init,Iden,%integername Refad)
%externalroutinespec Init Data(%integer Mode,Adcom,Rel,Avers)
%externalintegerfnspec Op4 Ref(%string(63) S)
!*
!***********************************************************************
!*                                                                     *
!* OWN variables                                                       *
!*                                                                     *
!***********************************************************************
!*
%ownrecord(COMFMT)%name COM
%owninteger ADICT;! local copy for efficiency
%owninteger ANAMES;! ditto
%owninteger CHEAD0,CHEAD1,CHEAD2,CHEAD3
%owninteger Lastsubprogep,Paramlink,Mainprog
%owninteger BSSarrays
!*
%ownintegerarray LABH(0:31)
%externalintegerarray ASL(0:10)
%ownintegerarray Cmnbits(0:15)
!*
%owninteger COMAD
!*
!***********************************************************************
!* Consts                                                              *
!***********************************************************************
!*
%CONSTINTEGER MAX AREA SIZE=X'F00000'
%CONSTBYTEINTEGERARRAY NUMBYTES(0:7)=0(3),1,2,4,8,16
%CONSTINTEGERARRAY ROND(0 : 3) =    %C
X'FFFFFFFF',X'FFFFFFFE',0,X'FFFFFFFC'
!*
%CONSTBYTEINTEGERARRAY HEX(0 : 15) =   %C
 '0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
!*
{%include "ftn_copy1"}
!* modified 23/09/86
!*
%routine Zero(%integer Addr,Length)
!***********************************************************************
!* Set Length (a multiple of 4) bytes to zero                          *
!***********************************************************************
%integer I
      I=0
      %while I<Length %cycle
         integer(Addr+I)=0
         I=I+4 {bytes}
      %repeat
%end;! Zero
!*
!*
%constbyteintegerarray UCtoLC(0:255)=%C
   0,1,2,3,4,5,6,7,8,9,10,
   11,12,13,14,15,16,17,18,19,20,
   21,22,23,24,25,26,27,28,29,30,
   31,32,33,34,35,36,37,38,39,40,
   41,42,43,44,45,46,47,48,49,50,
   51,52,53,54,55,56,57,58,59,60,
   61,62,63,64,97,98,99,100,101,102,
   103,104,105,106,107,108,109,110,111,112,
   113,114,115,116,117,118,119,120,121,122,
   91,92,93,94,95,96,97,98,99,100,
   101,102,103,104,105,106,107,108,109,110,
   111,112,113,114,115,116,117,118,119,120,
   121,122,123,124,125,126,127,128,129,130,
   131,132,133,134,135,136,137,138,139,140,
   141,142,143,144,145,146,147,148,149,150,
   151,152,153,154,155,156,157,158,159,160,
   161,162,163,164,165,166,167,168,169,170,
   171,172,173,174,175,176,177,178,179,180,
   181,182,183,184,185,186,187,188,189,190,
   191,192,193,194,195,196,197,198,199,200,
   201,202,203,204,205,206,207,208,209,210,
   211,212,213,214,215,216,217,218,219,220,
   221,222,223,224,225,226,227,228,229,230,
   231,232,233,234,235,236,237,238,239,240,
   241,242,243,244,245,246,247,248,249,250,
   251,252,253,254,255
!*
%externalstringfn Lcstring(%string(63) S)
%integer I,L
      %if Target=IBM %or Target=Lattice %thenstart
         %result=S
      %finish
      L=length(S)
      %cycle I=1,1,L
         charno(S,I)=UCtoLC(charno(S,I))
      %repeat
      length(S)=L+1        
      charno(S,L+1)='_'    
      %result=S
%end;! Lcstring
!*
%externalstringfn Lowstring(%string(63) S)
%integer I,L
      %if Target=IBM %thenstart
         %result=S
      %finish
      L=length(S)
      %cycle I=1,1,L
         charno(S,I)=UCtoLC(charno(S,I))
      %repeat
      %result=S
%end;! Lcstring
!*
%externalintegerfn Dictspace(%integer Length)
!***********************************************************************
!* Reserve Length bytes in Dict                                        *
!***********************************************************************
%integer I,L
      %if Length&3#0 %then %monitor
      %if HOST=PERQPNX %or HOST=ACCENT %thenstart
         L=Length>>1
      %finishelsestart
         L=Length
      %finish
      I=Com_Dptr
      Com_Dptr=Com_Dptr+L
      %if Com_Dptr>Com_Diclen %then Dicful
      Zero(Com_Adict+I,Length)
      %result=I
%end;! Dictspace
!*
!******************************************************************************
!*                                                                            *
!*         LIST MANIPULATION                                                  *
!*                                                                            *
!******************************************************************************
!*
!*
%externalintegerfn FREESP(%integer N)
!***********************************************************************
!* OBTAIN N-WORD(32 BIT) LIST ITEM                                     *
!***********************************************************************
%integer PTR
%record(SRECF) %name SS
         PTR=ASL(N)
         %if PTR = 0 %thenstart
            PTR = Dict Space(N<<2)
            SS == RECORD(ADICT+PTR)
         %finishelsestart
            SS == RECORD(ADICT+PTR)
            ASL(N) = SS_LINK1
         %finish
         SS_LINK1 = 0
         %result=PTR
%end;                                   ! FREESP
!*
%externalroutine FREE LIST CELL(%integername LISTHEAD,%integer N)
%integer J
%record(SRECF) %name SS
      SS==record(ADICT+LISTHEAD)
      J=SS_LINK1;! NEW LISTHEAD
      SS_LINK1=ASL(N)
      ASL(N)=LISTHEAD
      LISTHEAD=J
%end;! FREE LIST CELL
!*
%externalintegerfn NEW LIST CELL(%integername LISTHEAD,%integer N)
%integer PTR
%record(SRECF) %name SS
      PTR=FREESP(N)
      SS==record(ADICT+PTR)
      SS_LINK1=LISTHEAD
      LISTHEAD=PTR
      %result=PTR
%end;! NEW LIST CELL
!*
!******************************************************************************
!*                                                                            *
!*        NAME, LABEL AND CONST HANDLING                                      *
!*                                                                            *
!******************************************************************************
!*
!*
%externalintegerfn SETLAB(%integer LAB,%integername LABRECPTR)
!***********************************************************************
!* LOCATE ENTRY IN LABEL LIST OR CREATE NEW ENTRY                      *
!***********************************************************************
%integer LPTR,PTR,I,J
%record(LABRECF) %name LABREC
         PTR = LABH(LAB&31)
         LPTR=PTR
         %while PTR # 0 %cycle
            LABREC == RECORD(ADICT+PTR)
            %if LABREC_LAB = LAB %C
               %then LABRECPTR=PTR %AND %result=0
            PTR = LABREC_LINK1
         %repeat
         PTR = Dictspace(LABRECSIZE)
         LABREC == RECORD(ADICT+PTR)
         LABREC_BLKIND=0
         LABREC_LINK1 = LPTR
         LABREC_LAB = LAB
         LPTR = PTR
         LABH(LAB&31) = LPTR
         LABRECPTR=PTR
         Com_Labcnt=Com_Labcnt+1  ;! for Op4
         %result=1
%end;                                   ! SETLAB
!*
%externalintegerfn SETCONREC(%record(RESF) RES)
!***********************************************************************
!* On entry a copy of the const is held as the item last added to DICT *
!* RES = (PTR>>DSCALE) << 16 ! x'100' ! mode                           *
!* For numeric constants a search is made of the appropriate list      *
!* of 4, 8, or 16 byte entries to see whether a copy is already held.  *
!* If not, and also for non-numeric constants, a new 4 word record is  *
!* added to the appropriate list                                       *
!* Content is  MODE   mode                                             *
!*             LINK1  link through chain of consts of same size        *
!*             DADDR  DICT @ of const                                  *
!*             CADDR  @ of const in CONSTS if allocated, else 0        *
!***********************************************************************
%CONSTBYTEINTEGERARRAY LIST(0:15)=1,1,2,1,2,0,2,0,0,1,0,0,0,0,0,0
%integer I,J,K,M,R,Val,Len
%record(CONSTRECF) %name CON
%SWITCH S(0:3)
      M=RES_MODE
      R=RES_H0<<DSCALE
      K=ADICT+R
      Val=integer(K)
      I=LIST(M)
      ->S(I)
!*
S(1): J=CHEAD1
      %while J#0 %cycle
         CON==record(ADICT+J)
         %if Val=INTEGER(ADICT+CON_DADDR)   %C
                                    %AND M=CON_MODE %thenstart
HIT:        %result=J
         %finish
         J=CON_LINK1
      %repeat
      J=CHEAD1
      CHEAD1=COM_DPTR
      Len=4
SET:  I=Dict Space(CONRECSIZE)
      CON==record(ADICT+I)
      CON_MODE=M
      %if M=HOLMODE %thenstart
         Val=((Val+3)>>2)<<2
         %if Val>Len %then Len=Val
      %finish
      Con_Length=Len
      CON_LINK1=J
      CON_DADDR=R
      CON_CADDR=0
      %result=I
!*
S(2): J=CHEAD2
      %while J#0 %cycle
         CON==record(ADICT+J)
         %if Val=integer(Adict+Con_Daddr)   %c
                       %and M=Con_Mode %thenstart
            %if integer(K+Com_W1)=integer(Adict+Con_Daddr+Com_W1) %then ->Hit
         %finish
         J=CON_LINK1
      %repeat
      J=CHEAD2
      CHEAD2=COM_DPTR
      Len=8
      ->SET
!*
S(0): J=CHEAD0
      CHEAD0=COM_DPTR
      Len=16
      ->SET
%end;! SETCONREC
!*
%externalintegerfn Conin(%integer Val)
%record(RESF) R
      R_Mode=INT4
      %if 0<=Val<=X'7FFF' %thenstart
         R_Form=LIT
         R_H0=Val
         %result=R_W
      %finish
      %if -X'7FFF'<=Val<0 %thenstart
         R_Form=NEGLIT
         R_H0=-Val
         %result=R_W
      %finish
      integer(Adict+Com_Dptr)=Val
      R_H0=Com_Dptr>>DSCALE
      R_Form=1
      Com_Dptr=Com_Dptr+W1
      R_H0=Setconrec(R)>>DSCALE
      R_Form=CNSTID
      %result=R_W
%end;! Conin
!*
{%include "pf_setbit"}
!*
%ROUTINE SETBIT(%INTEGER STRIPADDR,INDEX)
%INTEGER WD,BIT
%INTEGERARRAYNAME BS
%ownINTEGERARRAYFORMAT BSFMT(0:100)
BS==ARRAY(STRIPADDR,BSFMT)
WD=INDEX>>5
BIT=31-INDEX&X'1F'
BS(WD)=BS(WD)!(1<<BIT)
%END;! SETBIT
!*
{end "pf_setbit"}
!*
%externalroutine Init Alloc(%integer Mode,Adcom,Rel,Avers)
!***********************************************************************
!* Mode = 0  first time - reset everything                             *
!*        1  reset for start of new subprog                            *
!***********************************************************************
%integer I
      %if Mode=0 %thenstart
         Comad=Adcom
         Com==record(Adcom)
         Com_Acmnbits=Addr(Cmnbits(0))
         Com_Acomp=Addr(Comp(0))
         Adict=Com_Adict
         Anames=Com_Anames
         Com_Alabh=addr(Labh(0))
         Mainprog=0;! will trap multiple main programs
      %finish
      Init Data(Mode,Adcom,Rel,Avers)
      %cycle i=0,1,15
         Cmnbits(I)=0
      %repeat
      Cmnbits(0)=X'50000000'
      %cycle I=0,1,31
         Labh(I)=0
      %repeat
      %cycle I=0,1,10
         Asl(I)=0
      %repeat
      Chead0=0
      Chead1=0
      Chead2=0
      BSSarrays=0
%end;! Init Alloc
!*
%externalintegerfn Alloc Const(%integer Resw,%integername IIN)
%record(CONSTRECF)%name Con
%record(RESF) R
%integer Val,Ad,Cad,Bytes
%switch f(64:66)
      R_W=Resw
      Val=R_H0
      ->F(R_Form)
!*
F(NEGLIT):
      Val=-Val
!*
F(LIT):
      Ad=Dictspace(4)
      integer(Com_Adict+Ad)=Val
      R_H0=Ad>>DSCALE
      Ad=Setconrec(R)
Set:  Con==record(Adict+Ad)
!      %if Con_Caddr=0 %thenstart
         Con_Caddr=Const Space(Con_Length,IIN)
         Cad=Con_Caddr
         Ad=Adict+Con_Daddr
         %if Modetobytes(R_Mode)=2 %then Ad=Ad+2
         %if Con_Mode=HOLMODE %then Ad=Ad+W1
         Edbytes(IIN,Cad,Con_Length,Ad)
!      %finish
      %result=Con_Caddr
!*
F(CNSTID):
      Ad=R_H0<<DSCALE
      ->Set
%end;! Alloc Const
!*
%externalroutine NEW TEMP(%record(RESF)%name RES,%integer MODE,USE)
!***********************************************************************
!* Get temp scalar DICT record                                         *
!***********************************************************************
%integer IIN,J
%record(TMPF)%name TMP
%record(COMFMT)%name COM
      COM==record(COMAD)
      J=Dict Space(TMPRECSIZE)
      TMP==record(COM_ADICT+J)
      TMP_MODE=MODE
      TMP_REG=0
      TMP_LINK1=0
      TMP_ADDR=0
      TMP_W0=0
      TMP_USECNT=USE
      TMP_INDEX=COM_NEXT TEMP
      COM_NEXT TEMP=COM_NEXT TEMP+1
      %IF COM_NEXTBIT<512 %THENSTART
         TMP_COORD=COM_NEXTBIT
         COM_NEXTBIT=COM_NEXTBIT+1
      %FINISHELSE TMP_COORD=3
      RES_FORM=TMPID
      RES_MODE=MODE
      RES_H0=J>>DSCALE
%end;! GET TEMP
!*
!*
%externalroutine BSSreloc(%integer Ptr)
%record(Precf)%name PP
%record(Arraydvf)%name Dvrec
%record(Srecf)%name SS
%integer I,Link,N,Base
      Link=addr(BSSarrays)
      I=BSSarrays
      %while I#0 %cycle
         SS==record(Com_Adict+I)
         %if SS_Inf0=Ptr %or SS_Inf3=Ptr %thenstart
            integer(Link)=SS_Link1
            PP==record(Com_Adict+SS_Inf0)
            Dvrec==record(Com_Adict+PP_Addr4)
            PP_IIN=GST
            Base=Com_Gstca
            Dvrec_Adfirst=Base
            Dvrec_Addrzero=Dvrec_Adfirst-Dvrec_Addrzero
            N=((SS_Inf2+7)>>3)<<3
            Com_Gstca=Com_Gstca+N
            Set Array Head(Dvrec_Addrdv,GST,Dvrec_Adfirst,  %c
                           Dvrec_Addrzero,PP_Type)
            %if SS_Inf3#0 %thenstart;! equivalenced array
               PP==record(Com_Adict+SS_Inf3)
               Dvrec==record(Com_Adict+PP_Addr4)
               PP_IIN=GST
               Dvrec_Adfirst=Base
               Dvrec_Addrzero=Dvrec_Adfirst-Dvrec_addrzero
               Set Array Head(Dvrec_addrdv,GST,Dvrec_Adfirst,  %c
                              Dvrec_Addrzero,PP_Type)
            %finish
            %return
         %finish
         I=SS_Link1
         Link=addr(SS_Link1)
      %repeat
%end;! BSSreloc
!*
%externalroutine BSStidy
%record(Precf)%name PP
%record(Arraydvf)%name Dvrec
%record(Srecf)%name SS
%integer I,Link,N,Base
      I=BSSarrays
      %while I#0 %cycle
         SS==record(Com_Adict+I)
         PP==record(Com_Adict+SS_Inf0)
         Dvrec==record(Com_Adict+PP_Addr4)
         PP_IIN=ZEROGST
         Base=Com_Zgstca
         Dvrec_Adfirst=Base
         Dvrec_Addrzero=Dvrec_Adfirst-Dvrec_Addrzero
         N=((SS_Inf2+7)>>3)<<3
         Com_Zgstca=Com_Zgstca+N
         Set Array Head(Dvrec_Addrdv,ZEROGST,Dvrec_Adfirst,  %c
                        Dvrec_Addrzero,PP_Type)
         %if SS_Inf3#0 %thenstart;! equivalenced array
            PP==record(Com_Adict+SS_Inf3)
            Dvrec==record(Com_Adict+PP_Addr4)
            PP_IIN=ZEROGST
            Dvrec_Adfirst=Base
            Dvrec_Addrzero=Dvrec_Adfirst-Dvrec_addrzero
            Set Array Head(Dvrec_addrdv,ZEROGST,Dvrec_Adfirst,  %c
                           Dvrec_Addrzero,PP_Type)
         %finish
         I=SS_Link1
      %repeat
      BSSarrays=0
%end;! BSStidy
!*
%externalroutine Alloc(%integer PTR)
!***********************************************************************
!* ON ENTRY PTR POINTS AT RECORD FOR AN IDENTIFIER FOR WHICH           *
!* STORAGE MUST BE ALLOCATED. THIS MAY REQUIRE ALLOCATION OF A COMPLETE*
!* COMMON BLOCK, OR ALL ITEMS INVOLVED IN EQUIVALENCE CHAINS.          *
!***********************************************************************
!*
%routinespec DV(%integer DVADDR,MODE)
%integerfnspec Next Coord
!*
%record(ARRAYDVF) %name DVREC
!*
%integer I, T, IIN
%integer J, K, L, M, N, P, Q, U, V, W, TEMP,CHAR,CMNBLKAD
%integer SAVEPTR, DATAMODE, CMNIND, CCOORD
%integer CLASS,SZTYPE,DR1
%integer BOUND, BEND, ER
%integer BSSinhib,BSScount
%owninteger Curbit;! to carry across recursive call to Alloc equiv item
%record(PRECF) %name PP
%record(PRECF) %name QQ
%record(SRECF) %name WW
%record(SRECF) %name SS
%record(Srecf) %name BSSrec
%record(PRECF) %name CMNBLK
%SWITCH SW(0 : 6)
%SWITCH TW(8 : 14)
!*
      PP == RECORD(COM_ADICT+PTR)
      I = PP_X1
      DATAMODE = I&2
      SAVEPTR = PTR
      CLASS = PP_CLASS&X'1F'
      SZTYPE=PP_TYPE
      %if I&1#0 %thenstart;! allocated (at least partially)
         %unless PP_CLASS&6=6 %then %RETURN;! unless COMMON array
         %if COM_SUBPROGTYPE=5 %then %RETURN;! blockdata
         DVREC==record(COM_ADICT+PP_ADDR4)
         %if DVREC_ADDRDV#0 %then %RETURN;! fully allocated
         DV(PP_ADDR4,2);! complete allocation
         SET ARRAY HEAD(DVREC_ADDRDV,PP_IIN,DVREC_ADFIRST,  %c
                                      Dvrec_Addrzero,Sztype)
         %RETURN
      %finish
      Curbit = 3
      L = PP_ADDR4
      N = NUMBYTES(SZTYPE>>4)
      %if SZTYPE=5 %then N=PP_LEN
      %if N>0 %then T=N-1;! NO OF BYTES IN ELEMENT-1
      %if SZTYPE&15 = 3 %then N=N+N;! complex
      -> SW(CLASS&3!(PP_X1&4));      ! EQUIV:COMMON:PARAM
!*
!*** LOCAL SCALARS OR ARRAYS
SW(0):PP_X1=PP_X1!1;                 ! SET ALLOCATED BIT
      PP_Coord=Next Coord
      PP_Link2=Com_Scptr;! ADD TO DIAGS LIST
      Com_Scptr=Ptr
      %if Class&4 # 0 %thenstart;    ! ARRAY
         Dv(PP_Addr4,0)
         Dvrec_Adfirst = Array Space(N,IIN,1)
         %if Target=Gould %and IIN=ZEROGST %thenstart
            SS==record(Com_Adict+Newlistcell(BSSarrays,4))
            SS_Inf0=Ptr
            SS_Inf2=N
            SS_Inf3=0
         %finishelsestart
            Dvrec_Addrzero= Dvrec_Adfirst-Dvrec_Addrzero
            Set Array Head(Dvrec_Addrdv,IIN,Dvrec_Adfirst,  %c
                            Dvrec_Addrzero,PP_Type)
         %finish
      %finishelsestart;              ! SCALAR
         %if Sztype=5 %thenstart
            PP_Addr4=Alloc Char(N,0,IIN)
         %finishelsestart
            PP_Addr4 = Scalar Space(N,IIN)
         %finish
      %finish
      PP_IIN=IIN
      %if target=LATTICE %thenstart
         ICdatarec(addr(PP_Class),Com_Adict,Com_Anames)
      %finish
      %return
!*
!*** PARAM
SW(1):PP_X1=PP_X1!1;                 ! SET ALLOCATED BIT
      %if PP_CLASS=9 %thenstart;! SUBPROG
         PP_Addr4=Scalar Space(8,IIN);! space for ref and length
         PP_IIN=IIN
         %return
      %finish
      PP_Link2=Com_Scptr;! FOR DIAGNOSTICS
      Com_Scptr=Ptr
      %if Class = 5 %thenstart;      ! PARAMETER ARRAY
         DV(PP_Addr4,0);               ! CONSTRUCT REST OF DOPE VECTOR
         PP_Coord=1;! bit for array and char params(i.e. ref values)
         Setbit(Com_Acmnbits,1)
      %finishelsestart;              ! SCALAR
         I=Com_Checklist;! OF ITEMS WHICH SHOULD APPEAR AS PARAMS
         %while I#0 %cycle
            SS==record(Com_Adict+I)
            %if SS_Inf0=Ptr %then SS_Inf2=0;! ENTRY TO BE IGNORED
            I=SS_Link1
         %repeat
!!         %if PP_X0&1 # 0 %and Sztype#5 %thenstart;! 'VALUE' PARAM SCALAR
!!            PP_Coord=Next Coord;! same as local scalar
!!         %finishelsestart;! 'NAME' PARAM SCALAR - only char in F77
            PP_Coord=1
            Setbit(Com_Acmnbits,1)
            PP_X0=PP_X0&X'FE'
            %if PP_Type=CHARTYPE %then N=8 %else N=4
!!         %finish
         PP_Addr4=Scalar Space(N,IIN)
         PP_IIN=IIN
      %finish
      %if target=LATTICE %thenstart
         ICdatarec(addr(PP_Class),Com_Adict,Com_Anames)
      %finish
      %return
!*** COMMON
SW(2):Cmnblk == record(Com_Adict+PP_Link3<<DSCALE);  ! RECORD DESCRIBING COMMON BLOCK
      M=Cmnblk_Cmnlength
      Char=0
      %if Com_Subprogtype = 5 %thenstart;    ! BLOCKDATA - SPACE WILL BE ALLOCATED
         M=0
         IIN=Newcmn(1,Cmnblk_Iden,Cmnblk_Cmnrefad)
         Cmnblk_IIN=IIN
      %finishelsestart
         %if Cmnblk_Cmnrefad=0 %thenstart
            IIN=Newcmn(0,Cmnblk_Iden,Cmnblk_Cmnrefad)
            Cmnblk_IIN=IIN
         %finishelse IIN=Cmnblk_IIN
      %finish
      Er = 304;                      ! ALLIGNMENT
      Ptr = Cmnblk_Link2;            ! FIRST ITEM IN THIS COMMON AREA
      %while PTR # 0 %cycle
         PP == record(Com_Adict+Ptr)
         %if PP_X1&1 = 0 %thenstart; ! NOT YET ALLOCATED
            PP_IIN=IIN
            %if PP_Type=5 %thenstart
               N=PP_Len
               Char=Char!1
            %finishelsestart
               N = Numbytes (PP_Type>>4)
               %if Target=Gould %thenstart  {leave gaps in common}
                  %if N=2 %and M&1#0 %then M=M+1
                  %if N=4 %and M&3#0 %then M=(M+3)&X'fffffc'
                  %if N=8 %and M&7#0 %thenstart
                     M=(M+7)&X'fffff8'
                     Tfault(358,Com_Anames+Cmnblk_Iden,0)
                  %finish
               %finish
               Char=Char!2
               %if PP_Type&15=3 %then N=N+N;! COMPLEX
               %if N>2 %then T=3 %else T=N-1
                                        ! NO. OF BYTES IN ELEMENT - 1
                                        ! (PER PART IF COMPLEX)
               %unless M = (M+T)&ROND(T) %or Er = 0 %thenstart
                                        ! UNLESS ALLIGNMENT O.K. OR FAULT ALREADY REPORTED
!                  LFAULT(ER)   **** CANNOT HAPPEN UNTIL I*2 ALLOWED
                  ER = 0
               %finish
            %finish
            PP_X1=PP_X1!1;           ! SET ALLOCATED BIT
            %if PP_CLASS&4 # 0 %thenstart;! ARRAY
               SZTYPE=PP_TYPE
               %if PTR=SAVEPTR %OR COM_SUBPROGTYPE=1 %then I=0  %C
                                                     %else I=1
                                        ! full alloc if specifically referenced
                                        ! or in main program
               DV(PP_ADDR4,I);         ! SET DOPE VECTOR(UNLESS BLOCK DATA) 
                                     ! CALCULATE TOTAL ARRAY SIZE
               DVREC_ADFIRST=M
               Dvrec_Addrzero=M-Dvrec_Addrzero
!* N.B. RELOCATION BY COMMON BASE AS FOR LOCAL ARRAYS
               %unless COM_SUBPROGTYPE=5 %OR I=1 %thenstart
                  SET ARRAY HEAD(DVREC_ADDRDV,IIN,M,Dvrec_Addrzero,Sztype)
               %finish
            %finishelsestart
               PP_ADDR4=M;! bytes
            %finish
            M = M+N
         %finish
         PP_Coord=Curbit
         PP_Coord=Next Coord;! to be suppressed if in trouble
         Setbit(Com_Acmnbits,PP_Coord)
         %if target=LATTICE %thenstart
            ICdatarec(addr(PP_Class),Com_Adict,Com_Anames)
         %finish
         PTR = PP_LINK2;             ! NEXT ITEM ON THE LIST
      %repeat
      %if CHAR=3 %thenstart
         TFAULT(183,COM_ANAMES+CMNBLK_IDEN,0)
      %finish
      CMNBLK_CMNLENGTH = M
      %if M>MAX AREA SIZE %thenstart
         TFAULT(317,COM_ANAMES+CMNBLK_IDEN,0)
      %finish
      %RETURN
!*** ITEM IS ON AN EQUIVALENCE LIST
SW(4):
SW(6):
      W = N;                         ! ITEM LENGTH
      K = 0;                         ! FOR DISPLACEMENT
      T = 0
      M = 0;                         ! MAX VALUE OF N DISPL
      J = PTR;                       ! STARTING POINT
      P = PTR
      V = PP_LINK2;                  ! CORRESPONDING EQUIV CHAIN ENTRY
      CHAR=0
      SS == RECORD(COM_ADICT+V)
!*
!* STAGE 1   CHOOSE AN ELEMENT WHOSE @ WILL BE FIXED. COMMON ELSE
!*           ARRAY EL WITH GREATEST DISPLACEMENT ELSE ARRAYNAME ELSE
!*           SCALAR
!*           V POINTS TO LIST & P POINTS TO ELEMENT
!*
      BSSinhib=0
      BSScount=0
      %cycle
         BSScount=BSScount+1
         PP==record(COM_ADICT+P)
         %if PP_TYPE=5 %thenstart
            BSSinhib=1
            N=PP_LEN 
            CHAR=CHAR!1
         %finishelsestart
            N = NUMBYTES(PP_TYPE>>4)
            CHAR=CHAR!2
            ER=SS_INF3
         %finish
         U = SS_INF2;                ! DISPL OF EQUIVALENCED ITEM FROM BASE
         %unless U=0 %then BSSinhib=1
         %if PP_X1&1 # 0 %thenstart; ! ALLOCATED
            K = U
            PTR = P;                 ! SET TO POINT AT ITEM TO BE USED AS ROOT
            T = 3;                   ! ALLOCATED (MAY BE COMMON ITEM IN CHAIN)
            BSSinhib=1
         %finishelsestart
            %if PP_Class&2#0 %thenstart;! item in common
               BSSinhib=1
               PP_X1=PP_X1&X'F3';! clear equiv flag
               Alloc(P)
               K=U
               Ptr=P
               T=3
            %finishelsestart
               %if PP_TYPE&15=3 %then N=N+N;! COMPLEX
               %if PP_CLASS&4 # 0 %thenstart;! ARRAY
                  %unless K > U %OR T = 3 %thenstart
                                     ! WILL BE ROOT UNLESS ALLOCATED OR COMMON ITEM, OR 
                                     ! ARRAY WITH BIGGER DISPLACEMENT IS FOUND
                     K = U
                     PTR = P
                  %finish
                  SZTYPE=PP_TYPE
                  DV(PP_ADDR4,0);         ! SET UP DOPE VECTOR, N TOTAL SIZE IN BYTES
               %finishelsestart
                  BSSinhib=1
                  %if PP_TYPE=5 %thenstart
                     %unless K>=U %OR T=3 %thenstart
                        K=U
                        PTR=P
                    %finish
                 %finish
               %finish
               %if N-U > M %then M = N-U;    ! MAX LENGTH REQUIRED BEYOND ALLIGNMENT POINT
            %finish
         %finish
         %if SS_link1=0 %then %exit;! previous error - avoid loop
         SS == RECORD(COM_ADICT+SS_LINK1);    ! NEXT ITEM DESCRIPTOR IN EQUIV CHAIN
         P = SS_INF0
      %repeat %until P = J 
      %unless BSScount=2 %then BSSinhib=1
      %if CHAR=3 %thenstart
         IFAULT(357,ER);! equivalence of char and non-char items
      %finish
      CHAR=CHAR&1
      PP == RECORD(COM_ADICT+PTR);       ! ITEM WHOSE ADDRESS IS TO BE FIXED FIRST
      P = PP_ADDR4
      DVREC == RECORD(COM_ADICT+PP_ADDR4)
!*
!* STAGE 2   ALLOCATE @ OF THE CHOSEN ELEMENT
!*
      %unless T > 0 %thenstart;      ! NOT YET ALLOCATED
         PP_X1=(PP_X1&X'F0')!1;                    ! CLEAR EQUIV FLAGS & SET ALLOC BIT
         T=4;! indicate local rather than common
         %if BSSinhib=0 %then I=1 %else I=0
         Q=Array Space(M+K,IIN,I)
         %if IIN=ZEROGST %thenstart
            BSSrec==record(Com_Adict+Newlistcell(BSSarrays,4))
            BSSrec_Inf0=Ptr
            BSSrec_Inf2=M
            BSSrec_Inf3=0
         %finishelsestart
            BSSinhib=1
            %if PP_CLASS&4#0 %thenstart
               DVREC==record(COM_ADICT+PP_ADDR4)
               DVREC_ADFIRST=Q
               Dvrec_Addrzero=Q-Dvrec_Addrzero
               SET ARRAY HEAD(DVREC_ADDRDV,IIN,Q,Dvrec_Addrzero,PP_Type)
            %finishelsestart
               PP_ADDR4=Q
            %finish
         %finish
         PP_IIN=IIN
         PP_Link2=Com_Scptr
         Com_Scptr=Ptr
      %finishelsestart;              ! COMMON ELEMENT (ALREADY ALLOCATED)
         T=3;! indicates common later
         %if PP_CLASS&4=0 %thenstart;! NOT AN  ARRAY
            P=PTR
            Q=PP_ADDR4
         %finishELSE Q=DVREC_ADFIRST
         CMNBLKAD=PP_Link3
         CMNBLK==record(COM_ADICT+CMNBLKAD<<DSCALE);! common block record
         %if M+K+Q>CMNBLK_CMNLENGTH %then CMNBLK_CMNLENGTH=M+K+Q
         IIN=CMNBLK_IIN
!* set all items in this block to the same coord pro tem
         QQ==RECORD(COM_ADICT+CMNBLK_LINK2)
         CCOORD=QQ_COORD
         %WHILE QQ_LINK2#0 %CYCLE
            QQ==RECORD(COM_ADICT+QQ_LINK2)
            QQ_COORD=CCOORD
            %IF COM_OPT&1#0 %THEN QQ_X1=QQ_X1!X'80';! to ensure always BOEX
         %REPEAT
         CURBIT=CCOORD
      %finish
!*********** STAGE 3
      BOUND = K+Q;                   ! DISPL. OF EQUIVALENCING POINT FROM START OF FIRST ITEM
                                     ! +DISPL. OF FIRST ITEM FROM AREA BASE
!      W = V;                         ! POINTS TO FIRST ITEM IN LIST
!      %cycle
!         WW == RECORD(COM_ADICT+W)
!         QQ == RECORD(COM_ADICT+WW_INF0)
!         %unless QQ_TYPE=5 %thenstart
!            L = NUMBYTES(QQ_TYPE>>4)-1
!            %if L>3 %then L=3
!            Q = WW_INF2;                ! DISPLACEMENT
!            %if BOUND-Q # (BOUND-Q+L)&ROND(L) %thenstart
!                                        ! WRONG ALLIGNMENT
!ALLIGNERROR:   FAULT(304)
!               %EXIT
!            %finish
!         %finish
!         W = WW_LINK1
!      %repeat %until W = V ;! I.E. COMPLETE LIST PROCESSED
!*
      K = V;                         ! POINTER TO LIST
      SS == RECORD(COM_ADICT+K)
      PTR = J
      %cycle
         PP == RECORD(COM_ADICT+PTR)
         PP_Coord=Curbit
         %if PP_X1&1 = 0 %thenstart; ! NOT USED/ALLOCATED
            PP_X1=PP_X1!DATAMODE!1;  ! SET DATA IF NEC. AND ALLOCATED BIT
            M = BOUND-SS_INF2;       ! START OF THIS ITEM RELATIVE TO THE BASE
            %if PP_TYPE=5 %AND T=2 %thenstart;! local char scalars
               %if PP_LINK2=0 %thenstart
                  PP_LINK2=COM_SCPTR
                  COM_SCPTR=PTR
               %finish
               PP_ADDR4=M;! bytes
               ->MEET3
            %finish
            W = T;                   ! FIXED ITEM IS:  2 SCALAR  3 COMMON  4 ARRAY
            -> TW(T+6+PP_CLASS&4);   ! 8 SCALAR:SCALAR  12 SCALAR:ARRAY
                                     ! 9 COMMON:SCALAR  13 COMMON:ARRAY
                                     !10 ARRAY :SCALAR  14 ARRAY :ARRAY
TW(13):                              ! ARRAY EQUIV COMMON
            W = 4;                   ! TO INDICATE THAT ADDRESS IS TO GO IN DOPE VECTOR
TW(9):      !SCALAR EQUIV COMMON
            %if M < 0 %then FAULT(268);! ATTEMPT TO EXTEND BACKWARDS
            PP_LINK2=CMNBLK_LINK2
            CMNBLK_LINK2=PTR
            PP_Link3 = CMNBLKAD;            ! ADDRESS OF COMMON BLOCK RECORD
            PP_X0=PP_X0!4
            PP_CLASS=PP_CLASS!2;     ! COMMON MARKER  ??
            -> MEET2
TW(8):                               ! SCALAR EQUIV SCALAR
TW(10):                              ! SCALAR EQUIV ARRAY
            PP_LINK2 = COM_SCPTR;        ! LINK TO SCALAR LIST FOR DIAGNOSTICS
            COM_SCPTR = PTR
            PP_ADDR4=M;! bytes
            -> MEET3
TW(14):     ! ARRAY EQUIV ARRAY
            PP_LINK2=COM_SCPTR
            COM_SCPTR=PTR
MEET2:      %if W = 3 %thenstart; ! COMMON OR SCALAR IN ARRAY AREA
               PP_ADDR4=M;! bytes
            %finishelsestart;     ! ARRAY
               %if BSSinhib=0 %thenstart
                  BSSrec_Inf3=Ptr
               %finishelsestart
                  DVREC == RECORD(COM_ADICT+PP_ADDR4)
!* N.B RELOCATE ARRAY BASE BY START OF AREA
                  DVREC_ADFIRST = M
                  Dvrec_Addrzero=M-Dvrec_Addrzero
                  %if COM_SUBPROGTYPE#5 %thenstart;! EXCEPT BLOCKDATA
                     SET ARRAY HEAD(DVREC_ADDRDV,IIN,M,Dvrec_Addrzero,PP_Type)
                  %finish
               %finish
            %finish
         %finish
MEET3:   PTR = K
         PP_IIN=IIN
         K = SS_LINK1;               ! TO POINT AT NEXT ITEM DESCRIPTOR
!!         SS_LINK1=ASL(3)
!!         ASL(3)=PTR                  ! temporarily conceeding this list space
         %if K=0 %then %exit;! previous error
         SS == RECORD(COM_ADICT+K)
         PTR = SS_INF0
         %if target=LATTICE %thenstart
            ICdatarec(addr(PP_Class),Com_Adict,Com_Anames)
         %finish
      %repeat %until PTR = J 
      %RETURN
!*
%INTEGERFN NEXT COORD
      %IF COM_NEXTBIT<512 %THENSTART
         CURBIT=COM_NEXTBIT
         COM_NEXTBIT=CURBIT+1
      %FINISH
      %RESULT=CURBIT
%END;! NEXT COORD
!*
%routine Dv(%integer Dvaddr,Mode)
!* generate dope vector for array
!* Mode = 0  normal allocation
!*        1  partial allocation (no dvarea descriptors)
!*        2  finalise allocation (set dvarea descriptors)
%integer I,J,K,L,D,Dvbase
      Dvrec ==record(Com_Adict+Dvaddr)
      %if Mode<2 %thenstart
         Dvrec_Ellength = N
         Dvrec_Addrzero=Dvrec_Zerotofirst*Dvrec_Ellength
      %finish
      Dvrec_Addrdv=0;! in case only partial init
      %if Com_Subprogtype # 5 %and Mode#1 %thenstart
         %if DVAREA=GLA %then K=Com_Glaca %else K=Com_Scalarca
         Dvbase=K
         %if Class=5 %thenstart;! param - reserve hole for zerotofirst
            Ed4(DVAREA,K,Dvrec_Zerotofirst)
            K=K+4
         %finish
         %if Sztype=CHARTYPE %thenstart
            %if PP_Len=0 %then K=K+4;! reserve space for actual arg len
            I=Dvrec_Numels*PP_Len
         %finishelsestart
            I=Dvrec_Numels
         %finish
         K=K+4
         Dvrec_Addrdv=K
         K=K+8
         Ed4(DVAREA,K-4,I);! numels or numchars(for char arrays)
         %if PP_Class&X'C0'#0 %and Dvrec_Dims>1 %thenstart;! > 1 adj dim
            %cycle I=2,1,Dvrec_Dims
               Ed4(DVAREA,K,Dvrec_B(I)_M)
               K=K+4
            %repeat
         %finish
         J=Dv Space(K-Dvbase,I)
      %finish
      %if Mode<2 %thenstart;! first time for this array
         N = Dvrec_Numels*N
      %finish
%end;                                   ! Dv
!*
!*
%end;                                   ! ALLOC
!*
%externalintegerfn New Subprogram(%integer Ptr,P1,Ctyp,%integername Er)
!***********************************************************************
!* FOLLOWS PROGRAM, SUBROUTINE, FUNCTION, ENTRY OR BLOCKDATA           *
!***********************************************************************
!*
%conststring(12)%array Prg(0:5)=  %C
   "main program",
   "program    ",
   "function   ",
   "subroutine ",
   "   entry   ",
   "blockdata  "
!*
%integer I,J
!*
%record(Precf) %name PP
%record(Precf) %name QQ
      PP==record(Com_Adict+Ptr)
      %if P1 = 4 %thenstart;         ! entry
         Com_Entries=Com_Entries+1
         Er = 100;                     ! SYNTAX
         %result = 4 %unless 2 <= Com_Subprogtype <= 3
                                     ! UNLESS FUNCTION OR SUBROUTINE
         Er = 141;                    ! INVALID ENTRY name
         %result=4 %unless Ctyp<0 %or PP_X1&1=0;! MUST BE A 'NEW' OR UNUSED IDENTIFIER
         %result=4 %if PP_Class#0
         Er=235
         %result=4 %unless Com_Doptr=0 %and Com_Ifptr=0;! NOT VALID INSIDE A DO LOOP OR IF BLOCK
         PP_Coord=2;! standard value for fn result
         I = Com_Subprogptr
         QQ==record(Com_Adict+I)
         J=QQ_Type
         %if Com_Subprogtype=2 %thenstart;! function
            %if PP_Type=5 %thenstart
               %unless J=5 %then Er=197 %and %result=4;! entry is char,fn is not
            %finishelsestart
               %if J=5 %then Er=198 %and %result=4;! fn is char,entry is not
            %finish
         %finish
         %while I>0 %cycle;          ! THROUGH ENTRY POINT LIST
            QQ == record(Com_Adict+I)
            I = QQ_Link3<<DSCALE
         %repeat
         QQ_Link3 = Ptr>>DSCALE
      %finishelsestart
         %if P1<=1 %thenstart
            Com_Subprogtype=1
            %if Mainprog#0 %then Lfault(316);! multiple main prog
            Mainprog=1
         %finishelse Com_Subprogtype=P1
         %if Com_Opt&2#0 %then I=Op4 Ref(string(Com_Anames+PP_Iden))
         Com_Subprogptr=Ptr
         Com_Funresdisp=0;! NO RESULT SPACE YET ASSIGNED FOR FUNCTION
         Com_Pastart=Com_Linest
      %finish
      %if Com_Subprogtype=2 %then PP_Coord=2;! function
      %if P1<=4 %and Com_Noisy#0 %thenstart
         selectoutput(Com_Console)
         spaces(3)
         printstring(Prg(P1))
         {%if P1<=1 %then printstring("MAIN ")}
         %if P1>0 %thenstart
            printstring(string(Anames+PP_Iden))
         %finish
         newline
         %if Com_Liststream>=0 %then selectoutput(Com_Liststream)
      %finish
      %if P1#5 %thenstart
         Lastsubprogep = Ptr;             ! LOCATE THE 'LATEST' SUBPROG ENTRY
         Paramlink = addr(PP_Link2);                ! PARAM CHAIN LINK
         PP_Class = 11
         Com_Rescom1=Ptr;! will identify record for definition of plabel
      %finish
      %if P1=0 %then P1=1;! unnamed main program
      %if P1<5 %then PP_X1=PP_X1!((P1-1)<<4)
      %if Com_Opt&2#0 %thenstart
         %if P1<4 %then Com_Procindex=Com_Procindex+1
         %if Com_Procindex=1 %or P1=4 %then Com_Inhibop4=1;! first or entries
      %finish
      %result = 1
%end;! New Subprogram
!*
%externalintegerfn Formal Parameter(%integer Ptr,Mode,Ctyp)
!***********************************************************************
!* PROCESS FORMAL PARAMETER                                            *
!* MODE = 0  'value' TYPE                                              *
!*        1  'name' TYPE, I.E. / <IDEN> /                              *
!***********************************************************************
!*
%integer I,Er
%record(Precf) %name PP
%record(Srecf) %name SS
      PP==record(Com_Adict+Ptr)
      Er = 129;                       ! INVALID ARGUMENT
      %if Ctyp >= 0 %thenstart;   ! NOT FIRST OCCURENCE OF THIS IDEN
         %if PP_Class&2#0 %or PP_Class&X'1F'>9  %C
                             %or PP_X1&X'80'#0 %thenstart ;! in common or namelist or equiv etc.
Err:        string(Com_Adident)=string(Anames+PP_Iden)
            %result=4
         %finish
         %if PP_Class&1=0 %and PP_X1&1#0 %then %result=4;! param on entry already referenced
         %unless PP_X1&1#0 %then PP_Class=PP_Class!1;!  MARK AS PARAM UNLESS ALLOC.
         %if PP_Class&X'60'=X'60' %then PP_Class=PP_Class&X'DF';! clear 'not known as param' bit
         PP_X0=PP_X0!1 %unless PP_Type=5 %AND PP_Class&4=0;! except for char scalars
      %finishelsestart;           ! 'NEW' IDENTIFIER
         PP_X0 = 1;               ! 'VALUE' PARAM
         PP_Class=1
      %finish
      I=Freesp(2)
      SS==record(Com_Adict+I)
      SS_Inf0 = Ptr
      integer(Paramlink) = I;    ! PARAMLINK LOCATES PREVIOUS LINK POSITION
      Paramlink = addr(SS_Link1)
      Com_Argcnt=Com_Argcnt+1;! for Op4
      %result = 1
%end;! Formal Parameter
!*
%externalintegerfn Genfmt(%byteintegerarrayname Input,Type,
                          %string(*)%name Identifier)
%integer ER,I,J,Ptr,Tablen,Fmtlen,Ad,Len
%record(LABRECF)%name LABREC
      I=SETLAB(COM_LAB,PTR);! 1  NEW    0  ALREADY EXISTS
      LABREC==record(ADICT+PTR)
      COM_PI21INT=COM_LAB;! IN CASE OF FAULT 77
      COM_LAB = 0
      %unless LABREC_ADDR4 = 0 %thenstart
         COM_PI21INT=LABREC_LINE
         %result = 227;! LABEL SET TWICE
      %finish
      COM_LABWARN = 0
      ER=0
      Labrec==record(Com_Adict+Ptr)
      %if Com_Ioareaca=0 %then Com_Ioareaca=4
      Labrec_Addr4=Com_Ioareaca
      Labrec_Line=Com_Linest
      %if I = 0 %thenstart;! ALREADY REFERENCED
         ER = 302;! AS A STATEMENT LABEL
         %if LABREC_X0=16 %thenstart;! ASSIGNed
            LABREC_X0=8;! mark as definitely format
         %finishelsestart
            %result=ER %if LABREC_X0#8
         %finish
      %finishelsestart
         LABREC_X0=8
      %finish
      I = COM_INP
L870: %unless TYPE(I)=12 %AND INPUT(I)=10 %then I=I+1 %AND ->L870
      %unless TYPE(I)=12 %then I=I+1 %AND ->L870
      Len=I-COM_INP
      LABREC_LINK3=Len
      Ad=Com_Adict+Com_Dptr;!   workspace
      Er=Formatcd(addr(Input(0)),Com_Inp,Ad,Len,Len*4,0,0,Tablen,Fmtlen)
      %if Er=0 %thenstart
         Tablen=(Tablen+3)&X'FFFC'
         Edbytes(IOAREA,Com_Ioareaca,Tablen,Ad)
         Com_Ioareaca=Com_Ioareaca+Tablen
      %finishelsestart
         %if FMTLEN>32 %then FMTLEN=32
         %cycle J=1,1,FMTLEN
            INPUT(J)=INPUT(TABLEN+J-1)
         %repeat
         INPUT(0)=FMTLEN;! this fiddle is to ensure word allignment
         IDENTIFIER=string(addr(Input(0)))
      %finish
      COM_INP=I
      %result=ER
%end;! GEN FMT
!*
!***********************************************************************
!* ROUTINES TO DUMP DICTIONARY RECORDS                                 *
!***********************************************************************
!*
%ROUTINE PRHEX(%INTEGER J)
%INTEGER K
      %CYCLE K = 28,-4,0
         PRINT SYMBOL(HEX((J>>K)&15))
      %REPEAT
%END
!*
%ROUTINE PH(%INTEGER I)
%INTEGER J,K,L
prhex(integer(i))
spaces(2)
%return
%END
!*
%ROUTINE DICREC(%INTEGER A,ID)
%RECORD(PRECF)%NAME PP
%INTEGER I
      I = ADICT+A
      PP==RECORD(I)
      PRHEX(A)
      SPACES(6)
      PH(I)
      PH(I+W1)
      SPACES(2)
      PH(I+W2)
      PH(I+3*W1)
      SPACES(2)
      NEWLINE
      WRITE(A,7)
      SPACES(6)
      PH(I+W4)
      PH(I+5*W1)
      SPACES(2)
      PH(I+6*W1)
      PH(I+7*W1)
      SPACES(2)
      %IF ID#0 %THENSTART
         WRITE(PP_COORD,2)
         SPACES(2)
         PRINTSTRING(STRING(ANAMES+PP_IDEN))
      %FINISH
      NEWLINES(2)
%END
!*
%ROUTINE DICRECLIST(%INTEGER HEAD,ID)
%RECORD(PRECF) %NAME P
      %WHILE HEAD # 0 %CYCLE
         P == RECORD(ADICT+HEAD)
         DICREC(HEAD,ID)
         %IF ID#0 %AND P_CLASS&X'C'=4 %THEN DICREC(P_ADDR4,0);! ARRAY DV
         %IF P_CLASS=12 %THEN DICREC(HEAD+32,0);! common block
         HEAD = P_LINK1
      %REPEAT
%END;                                   ! DICRECLIST
!*
%externalroutine Dumpdict(%integer Mode)
%INTEGER I, J
      NEWLINE
      PRINTSTRING("IDEN LISTS:")
      NEWLINE
      %CYCLE I = 0,1,154
         J = INTEGER(COM_ADLHEAD+I<<2{BSCALE})
         %IF J # 0 %THENSTART
            WRITE(I,1);  NEWLINE
            DICRECLIST(J,1)
         %FINISH
      %REPEAT
      PRINTSTRING("LABEL LISTS:")
       NEWLINE
      %CYCLE I = 0,1,31
         J = INTEGER(COM_ALABH+I<<2{BSCALE})
         %IF J # 0 %THENSTART
            WRITE(I,1)
            NEWLINE
            DICRECLIST(J,0)
         %FINISH
      %REPEAT
      %if Mode=0 %then %return
      printstring("
Full Dict:
")
      I=0
      J=0
      %while I<Com_Dptr %cycle
         %if J=0 %then Prhex(I) %and spaces(4)
         PH(Adict+I)
         I=I+4
         J=J+1
         %if J=6 %then newline %and J=0
      %repeat
      newline
%end;! Dumpdict
!*
%externalroutine Op4 Resetanal
      Chead0=0
      Chead1=0
      Chead2=0
      Chead3=0
%end;! Op4 Resetanal
!*
%endoffile