%OWNINTEGER LAST WARNING
%OWNINTEGER OMFRESULT
%OWNSTRING(40) %ARRAY OMFERRORS(0:3)=  %C
E" *** ERROR CREATE OMF MODULE FAILS ***",
E" *** ERROR WRITE OMF RECORD FAILS ***",
E" *** ERROR SET ALIAS FAILS ***",
E" *** ERROR END OMF MODULE FAILS ***"
!* MODIFIED  21/07/81
!*
%OWNSTRING(4) CSUBNAME=E"F77 "
%CONSTSTRING(4) CVERSION=E"  70"
%CONSTSTRING(23)    CIDENT=E"FORTRAN77/B.70.01      "
%CONSTINTEGER CFLAG=C'G   '
%OWNINTEGER CLANGCODE=C'G'
%EXTERNALINTEGERFNSPEC  %C
                        ICL9CEF77CSM(%INTEGERFN INPUT,OUTPUT,SUPPORT,%C
                                     %INTEGER WORK,TEMP,AUX,OBJREC,%C
                                     SYSTEM,CODE,OPTIONS0,OPTIONS1,%C
                                     COM46,SPARE)
!*
%EXTERNALINTEGERFNSPEC ICL9HNCREATEMODULE(%INTEGER NAME DR0,NAME DR1,%C
                                           FULLNAME DR0,FULLNAME DR1,I)
%EXTERNALINTEGERFNSPEC ICL9HNENDMODULE(%INTEGER DELETE)
%EXTERNALINTEGERFNSPEC ICL9HNREADCARD(%INTEGER BUFFDR0,BUFFDR1,%C
                                       SEQDR0,SEQDR1,LENDR0,LENDR1)
%EXTERNALINTEGERFNSPEC ICL9HNOUTPUTLINE(%INTEGER BUFFDR0,BUFFDR1)
%EXTERNALINTEGERFNSPEC ICL9HNCOMPILESUPPORT(%INTEGER                  %C
                     FLAGS0,FLAGS1,LINK,%LONGINTEGER INPUT,OUTPUT,    %C
                     RUN,LISTINGS,MESS,SAVELIST,%INTEGER DIAG0,DIAG1, %C
                     %LONGINTEGER RTCHECKS,SHARE,OPT,LIBPROC,LEN,ARG, %C
                     TRACE,CANCEL,TESTENV,TP,SA,IOS,EC,IGNORE,CATCH,  %C
                     EMESS,ROUTE,REPORT,COUNT,DEPTH,RDIAG,ARSIZE,     %C
                     CONT,TRIES,DFILE,DEBUG,RTRACE,TFILE,BUFF,MAXL,   %C
                     CDIAG,DUMP,TEMP,CODE,%INTEGER GENK0,GENK1,       %C
                     %LONGINTEGER PROCEDURE,DIRECTIVES,TAS,UNIND,     %C
                     DISPLAY,LINES)
%EXTERNALINTEGERFNSPEC ICL9HNCREATEVS(%INTEGER NAMDR0,NAMDR1,%C
                                      SIZE,MODE,DESC DR0,DESC DR1)
%EXTERNALINTEGERFNSPEC ICL9HNLOG(%INTEGER MESSDR0,MESSDR1,DEST)
%EXTERNALINTEGERFNSPEC ICL9HNNEWLINE(%INTEGER LINES)
%EXTERNALINTEGERFNSPEC ICL9HNNEWPAGE
%EXTERNALINTEGERFNSPEC ICL9HNNEWSUBHEADING(%INTEGER SUBHEADING0,SUBH1,%C
                                           %INTEGER LINES,NEWPAGE)
%EXTERNALINTEGERFNSPEC ICL9HNMONITOR(%INTEGER TAG)
%EXTERNALINTEGERFNSPEC ICL9HNCREATEALIAS(%LONGINTEGER NAME DR,DUM DR)
%EXTERNALINTEGERFNSPEC ICL9HNOUTPUTRECORD(%LONGINTEGER BUFFER)
!*
%SYSTEMROUTINESPEC ONTRAPB(%INTEGER EVENT,SUBCLASS,CLASS)
%SYSTEMINTEGERFNSPEC PRIME CONTINGENCY(%ROUTINE CONTPROC)
%SYSTEMROUTINESPEC DUMP(%INTEGER AD,L)
!*
%OWNINTEGER ITSFLAG
%OWNINTEGER TEST4SET
%OWNINTEGER JSVARREAD=0
!*
%OWNINTEGER INITIALISED=0;! SET = 1 AFTER AREAS HAVE BEEN CREATED
!*
%OWNINTEGER TEMP
%OWNINTEGER AUX
%EXTERNALINTEGER AUXAD
%OWNINTEGER WORK
%OWNINTEGER SUMST
%EXTRINSICINTEGER ICL9HNDATE
%EXTRINSICINTEGER ICL9HNTIME
%OWNINTEGER ENTRYLNB
%OWNINTEGER COM26,COM27,COM28,COM53,PROCPLEX
%OWNINTEGER RESULT;! 0 ALL O.K.  >0 FAILURE
%OWNINTEGER MCOUNT;! NO OF SEPARATE SOURCE FILES
%OWNINTEGER OMFCOUNT;! NO OF SEPARATE OMF MODULES
%OWNINTEGER LISTINGSNONE;! 0 IF LISTINGS=NONE
%OWNINTEGER DISPLAYNONE;! 0 IF DISPLAY=NONE
%OWNINTEGER PRSUM;! SET WHEN OUTPUTTING COMPILATION SUMMARY
%OWNSTRING(32) %ARRAY EXTNAMES(0:20)
%RECORDFORMAT OBJFMT(%STRING(35) MODULE,%INTEGER MAINEP,I,J,K,  %C
                                        ADATE,ATIME,OPTIONS2,EXTPROCS)
%OWNRECORD OBJ(OBJFMT)
%CONSTBYTEINTEGERARRAY ITOETAB(0 : 255) = %C
     0,
     1,     2,     3,    55,    45,
    46,    47,    22,     5,    21,
    11,    12,    13,    14,    15,
    16,    17,    18,    19,    60,
    61,    50,    38,    24,    25,
    63,    39,    28,    29,    30,
    31,    64,    79,   127,   123,
    91,   108,    80,   125,    77,
    93,    92,    78,   107,    96,
    75,    97,   240,   241,   242,
   243,   244,   245,   246,   247,
   248,   249,   122,    94,    76,
   126,   110,   111,   124,   193,
   194,   195,   196,   197,   198,
   199,   200,   201,   209,   210,
   211,   212,   213,   214,   215,
   216,   217,   226,   227,   228,
   229,   230,   231,   232,   233,
    74,   224,    90,    95,   109,
   121,   129,   130,   131,   132,
   133,   134,   135,   136,   137,
   145,   146,   147,   148,   149,
   150,   151,   152,   153,   162,
   163,   164,   165,   166,   167,
   168,   169,   192,   106,   208,
   161,     7,    32,    33,    34,
    35,    36,    37,     6,    23,
    40,    41,    42,    43,    44,
     9,    10,    27,    48,    49,
    26,    51,    52,    53,    54,
     8,    56,    57,    58,    59,
     4,    20,    62,   225,    65,
    66,    67,    68,    69,    70,
    71,    72,    73,    81,    82,
    83,    84,    85,    86,    87,
    88,    89,    98,    99,   100,
   101,   102,   103,   104,   105,
   112,   113,   114,   115,   116,
   117,   118,   119,   120,   128,
   138,   139,   140,   141,   142,
   143,   144,   154,   155,   156,
   157,   158,   159,   160,   170,
   171,   172,   173,   174,   175,
   176,   177,   178,   179,   180,
   181,   182,   183,   184,   185,
   186,   187,   188,   189,   190,
   191,   202,   203,   204,   205,
   206,   207,   218,   219,   220,
   221,   222,   223,   234,   235,
   236,   237,   238,   239,   250,
   251,   252,   253,   254,   255

%CONSTBYTEINTEGERARRAY ETOITAB(0 : 255) = %C
     0,
     1,     2,     3,   156,     9,
   134,   127,   151,   141,   142,
    11,    12,    13,    14,    15,
    16,    17,    18,    19,   157,
    10,     8,   135,    24,    25,
   146,   143,    28,    29,    30,
    31,   128,   129,   130,   131,
   132,   133,    23,    27,   136,
   137,   138,   139,   140,     5,
     6,     7,   144,   145,    22,
   147,   148,   149,   150,     4,
   152,   153,   154,   155,    20,
    21,   158,    26,    32,   160,
   161,   162,   163,   164,   165,
   166,   167,   168,    91,    46,
    60,    40,    43,    33,    38,
   169,   170,   171,   172,   173,
   174,   175,   176,   177,    93,
    36,    42,    41,    59,    94,
    45,    47,   178,   179,   180,
   181,   182,   183,   184,   185,
   124,    44,    37,    95,    62,
    63,   186,   187,   188,   189,
   190,   191,   192,   193,   194,
    96,    58,    35,    64,    39,
    61,    34,   195,    97,    98,
    99,   100,   101,   102,   103,
   104,   105,   196,   197,   198,
   199,   200,   201,   202,   106,
   107,   108,   109,   110,   111,
   112,   113,   114,   203,   204,
   205,   206,   207,   208,   209,
   126,   115,   116,   117,   118,
   119,   120,   121,   122,   210,
   211,   212,   213,   214,   215,
   216,   217,   218,   219,   220,
   221,   222,   223,   224,   225,
   226,   227,   228,   229,   230,
   231,   123,    65,    66,    67,
    68,    69,    70,    71,    72,
    73,   232,   233,   234,   235,
   236,   237,   125,    74,    75,
    76,    77,    78,    79,    80,
    81,    82,   238,   239,   240,
   241,   242,   243,    92,   159,
    83,    84,    85,    86,    87,
    88,    89,    90,   244,   245,
   246,   247,   248,   249,    48,
    49,    50,    51,    52,    53,
    54,    55,    56,    57,   250,
   251,   252,   253,   254,   255
!***                                  LOG
!*
%ROUTINE LOG(%INTEGER I)
%INTEGER J
J=ICL9HNLOG(X'18000000'!LENGTH(OMFERRORS(I)),ADDR(OMFERRORS(I))+1,-1)
%END
!*
!***                           MOVE
!*
%SYSTEMROUTINE MOVE(%INTEGER LENGTH, FROM, TO)
%INTEGER I
      %RETURNIF LENGTH <= 0
      I = X'18000000'!LENGTH
      *LSS_FROM
      *LUH_I
      *LDTB_I
      *LDA_TO
      *MV_%L=%DR
%END;                                   !OF MOVE
!*
!***                             ETOI
!*
%SYSTEMROUTINE ETOI(%INTEGER AD, L)
%INTEGER I, J, K
      I = ADDR(ETOITAB(0))
      %RETURNIF L <= 0
      J = X'18000100'
      K = X'18000000'!L
      *LSS_I
      *LUH_J
      *LDTB_K
      *LDA_AD
      *TTR_%L=%DR
%END;                                   ! ETOI
!*
!***                           ITOE
!*
%SYSTEMROUTINE ITOE(%INTEGER AD, L)
%INTEGER I, J, K
      I = ADDR(ITOETAB(0))
      %RETURNIF L <= 0
      J = X'18000100'
      K = X'18000000'!L
      *LSS_I
      *LUH_J
      *LDTB_K
      *LDA_AD
      *TTR_%L=%DR
%END;                                   ! ITOE
!*
!***                         PHEX
!*
%CONSTBYTEINTEGERARRAY C(0 : 15) =  '0','1','2','3',
               '4','5','6','7','8','9','A','B','C','D','E','F'
%ROUTINE PX(%INTEGER H)
%INTEGER I,J
      %CYCLE I = 0,1,3
         J=BYTEINTEGER(I+H)
         PRINTSYMBOL(C(J>>4))
         PRINTSYMBOL(C(J&15))
      %REPEAT
%END;                                   !OF PX
!*
%SYSTEMROUTINE PHEX(%INTEGER N)
      PX(ADDR(N))
%END; !PHEX
!*
!***                        PARM
!*
%CONSTSTRING(9)%ARRAY PARMS(0:29)=   %C
'QUOTES','NOLIST','NODIAG','STACK',
'NOCHECK','NOARRAY','NOTRACE','PROFILE',
'IMPS','INHIBIOF','ZERO','XREF',
'LABELS','LET','CODE','ATTR',
'OPT','INHIBOPEH','DEBUG','FREE',
'####','####','EBCDIC','NOLINE',
'####','MAXKEYS','####','####',
'####','MISMATCH'
!*
%CONSTSTRING(10)%ARRAY ALTPARMS(0:29)=   %C
   'PERCENT','LIST','DIAG','NOSTACK',
   'CHECK','ARRAY','TRACE','####',
   'RUN','####','####','NOXREF',
   'NOLABELS','NOLET','NOCODE','NOATTR',
   '####','####','####','FIXED',
   '####','####','ISO','LINE',
   '####','MINKEYS','####','####',
   '####','NOMISMATCH'
!*
%CONSTSTRING(10) %ARRAY ALTCHECKS(0:4)=%C
"UNASSIGNED","#RRAYS","ARGUMENTS","CHARACTERS","ALL"
%CONSTSTRING(12) %ARRAY CHECKS(0:4)=%C
"NOUNASSIGNED","#OARRAYS","NOARGUMENTS","NOCHARACTERS","NONE"
%CONSTSTRING(12)%ARRAY ARR(0:2)="NOARRAYS","ARRAYS","ARRAYSINFULL"
%CONSTINTEGERARRAY INDEX(0:5)=28,5,27,26,X'1C010020',X'E3FEFFDF'
%INTEGERFN PARM(%STRING (63) S)
%STRING (63) T
%INTEGER I, J, K, FLAG, NOPT
%SWITCH NSW(5:13)
         FLAG = 0
         I = COM27
         NOPT=COM26
L1:      %IF S = "" %THEN %START
            COM27 = I
            COM26=NOPT
            %RESULT=0
         %FINISH
         %UNLESS S->T.("&").S %THENSTART
            T = S
            S = ""
         %FINISH
         %CYCLE J=0,1,4
            %IF CHECKS(J)=T %THENSTART
               %IF J=4 %THEN I=I!INDEX(J) %ELSE I=I!(1<<INDEX(J))
               ->L1
            %FINISH
            %IF ALTCHECKS(J)=T %THENSTART
               %IF J=4 %THEN I=I&INDEX(5)  %C
                       %ELSE K=(-1)!!(1<<INDEX(J)) %AND I=I&K
               -> L1
            %FINISH
         %REPEAT
         %IF T="ARRAYS" %THEN I=(I!X'20')&X'FFFEFFFF' %AND ->L1
         %IF T="NOARRAYS" %THEN I=I!X'10020' %AND ->L1
         %IF T="ARRAYSINFULL" %THEN I=I&X'FFFEFFDF' %AND ->L1
         ->SKIPMML
         %CYCLE J = 0,1,29
            %IF PARMS(J) = T %THEN %START
               I = I!(1<<J)
               -> L1
            %FINISH
            %IF ALTPARMS(J)=T %THENSTART
               K=(-1)!!(1<<J)
               I=I&K
               ->L1
            %FINISH
         %REPEAT
         %IF T="MINSTACK" %THEN COM28=COM28!X'4000' %AND ->L1
         ->SKIPMML
         %IF T="MML" %THEN COM28=COM28!X'1000' %AND -> L1
SKIPMML: PRINTSTRING('***INVALID VALUE '.T.' TO CHECKS IGNORED
')
         ->L1
NSW(5):  NOPT=NOPT&X'FFFFFFF7';! NOCASCADE
         ->L1
NSW(6):  I=I!X'8000';! MAP
         ->L1
L3:
NSW(7):  ! TEST1
         ->L1
NSW(9):  ! TEST3
         ->L1
NSW(8):  ! TEST2
         ->L1
NSW(10): ! TEST4
         TEST4SET=1
         ->L1
NSW(11): ! LOCAL
         ->L1
NSW(12): ! SPARSE
         ->L1
NSW(13):
         ->L1
%END;                                   !OF PARM
!*
!*
!***                               PRINT CHECKS
!*
%OWNSTRING(3) CSTRICT=""
%ROUTINE PRINT CHECKS(%INTEGER COMP)
%INTEGER I,J,K,L,M,N
%STRING(255) R,S,T,W1,W2,W3,W
%ROUTINESPEC P(%STRING(15) S)
         %RETURN %IF LISTINGSNONE=0 %AND DISPLAYNONE=0
         %IF COMP=-1 %THEN S="  CHECKS          " %ELSE %C
          S="                   CHECKS          ";!DISPLAY ELSE LISTING FILE
         %IF COMP=-1 %THEN T="  STRICT          " %ELSEC
         T="                   STRICT          ";
      W3=" DIAG=4, ITEMSONSTACK=NO, SHARE=YES, CHECKS=ALL."
      W1="** COMMENT **"
      W2="  COMPILED WITH ITS. OPTIONS FORCED ARE :"
      W="  ".W1."
".W1.W2.W3."
".W1."
"
         J=COM27
         K=0
         %CYCLE I=0,1,3
            %IF I=1 %THENSTART
               %IF J&X'10020'=0 %THEN L=2 %ELSESTART
                  %IF J&X'10000'=0 %THEN L=1 %ELSE L=0
               %FINISH
               P(ARR(L))
            %FINISHELSESTART
               L=INDEX(I)
               %IF J&(1<<L)=0 %THEN P(ALTCHECKS(I)) %ELSE P(CHECKS(I))
            %FINISH
         %REPEAT
      %IF ITSFLAG=1 %THEN M=2 %ELSE M=1
         %CYCLE L=0,1,M
            %IF L=0 %THEN R=S %AND ->OUT
      %IF L=1 %THEN R=T.CSTRICT %ELSE R=W
OUT:        I=LENGTH(R)
            J=ADDR(R)+1
            ITOE(J,I)
            %IF COMP=-1 %THEN K=ICL9HNLOG(X'18000000'!I,J,-1) %C
              %ELSE K=ICL9HNOUTPUTLINE(X'18000000'!I,J)
         %REPEAT
         %RETURN
!*
%ROUTINE P(%STRING(15) T)
         %IF K#0 %THEN S=S." & "
         S=S.T
         K=K+1
%END;! P
%END;!  PRINT CHECKS
!*
!*
!*
!***                           BPARS
!*
%OWNSTRING(64) COPTIONS=""
%OWNSTRING(64) CLIBNAME=""
%OWNSTRING(64) OMFNAME=""
%ROUTINE BPARS(%LONGINTEGER OMF,EXTERNALPROCS,CHECKS,STRICT,%C
        %INTEGERNAME SW)
%LONGINTEGERARRAY A(0:3)
%STRING(63) S,LIB
%SWITCH V(0:3)
%INTEGER I,J,K,LEN,ADDRS,OPTLEN,ADDROPT
%LONGINTEGER DESC
      A(0)=OMF
      SW=0
      A(1)=STRICT
      A(2)=EXTERNALPROCS
      A(3)=CHECKS
      %CYCLE I=0,1,3
          %IF A(I)=-1 %THEN S="" %AND ->V(I)
          LEN = (A(I)<<8)>>40
          ADDRS = A(I)&X'00000000FFFFFFFF'
          %IF I>1 %THEN -> V(I)
          J=ADDR(S)+1
          MOVE(LEN,ADDRS,J)
          ETOI(J,LEN)
          LENGTH(S)=LEN
          ->V(I)
REP:
      %REPEAT
      %RETURN
V(0):
      OMFNAME=""
      CLIBNAME=""
      %IF S="" %THENSTART;! NO LIBRARY SPECIFIED
         CLIBNAME=""
      %FINISHELSESTART
         %IF S->CLIBNAME.(".").OMFNAME %THENSTART
            %CYCLE
               %EXIT %UNLESS OMFNAME->LIB.(".").OMFNAME
               CLIBNAME=CLIBNAME.".".LIB
            %REPEAT
         %FINISHELSE OMFNAME=S
      %FINISH
      ->REP
!*
V(1):!PROCESSING STRICT   PARM(FREE) BIT SET IF NO
      %IF A(1)=-1 %OR LEN=0 %THEN S="YES" 
      K=COM27
      %IF S="NO" %THEN K=K!1<<19 %ELSEC
         J=(-1)!!(1<<19) %AND K=K&J %AND S="YES"
      COM27=K
      CSTRICT=S
      -> REP
!*
V(2):! EXTERNAL PROCEDURE NAMES FOR ALGOL ALLOW 20 AT PRESENT
      %IF A(2)=-1 %OR LEN=0 %THEN OBJ_EXTPROCS=0 %AND ->REP
      %IF LEN>20 %THEN LEN=20
      %CYCLE K=0,1,LEN-1
         DESC=LONGINTEGER(ADDRS+8*K)
         OPTLEN=(DESC<<8)>>40
         ADDROPT=DESC&X'00000000FFFFFFFF'
         J=ADDR(EXTNAMES(K))+1
         MOVE(OPTLEN,ADDROPT,J)
         ETOI(J,OPTLEN)
         LENGTH(EXTNAMES(K))=OPTLEN
      %REPEAT
      EXTNAMES(K+1)=""
      OBJ_EXTPROCS=ADDR(EXTNAMES(0))
      -> REP
!*
V(3): COPTIONS=""
      %IF A(3)=-1 %OR LEN=0 %THENRETURN;! NIL PARAMATER OR ZERO LENGTH
                                         ! SUPERLITERAL
      %CYCLE I=0,1,LEN-1
         DESC=LONGINTEGER(ADDRS+8*I)
         OPTLEN=(DESC<<8)>>40
         ADDROPT=DESC&X'00000000FFFFFFFF'
         J=ADDR(S)+1
         MOVE(OPTLEN,ADDROPT,J)
         ETOI(J,OPTLEN)
         LENGTH(S)=OPTLEN
         %IF I=0 %THEN COPTIONS=S %ELSE COPTIONS=COPTIONS."&".S
      %REPEAT
      %RETURN
      %END
!*
%EXTERNALINTEGERFNSPEC CTMCTM JSREAD    (%INTEGER                     %C
                                        NAME DR0,NAME DR1,            %C
                                        INT DR0,INT DR1,              %C
                                        STR DR0,STR DR1,              %C
                                        BOOL DR0,BOOL DR1)
!*
%INTEGERFN JSREAD(%STRING(32) NAME,%INTEGER I0,I1,S0,S1)
%INTEGER NAME0,NAME1
      NAME0=X'18000000'!LENGTH(NAME)
      NAME1=ADDR(NAME)+1
      %RESULT=CTMCTM JSREAD(NAME0,NAME1,I0,I1,S0,S1,-1,-1)
%END;! JSREAD
!*
%INTEGERFN READ JS VAR(%STRING(32) NAME,%STRINGNAME RES)
%INTEGER I,RC
%BYTEINTEGERARRAY WSTRING(0:255)
      RC=JSREAD(NAME,-1,-1,X'18000078',ADDR(WSTRING(1)))
      %IF RC > 0 %THEN %RESULT = RC
      %CYCLE I=120,-1,1
         %EXIT %IF WSTRING(I)#X'40'
      %REPEAT
      ETOI(ADDR(WSTRING(1)),I)
      WSTRING(0)=I
      RES=STRING(ADDR(WSTRING(0)))
      %RESULT=0
%END      ;!  OF READ JS VAR
!*
!*
!***                      GEN OMF
!*
%SYSTEMINTEGERFNSPEC OMFOUT(%INTEGER OPSYS,ATEMP,AWRK,CONTROL,LANG   %C
                            CODE,ADATE,ATIM,%STRING(7) SUBNAM,       %C
                            %STRING(6) VERSION,%STRING(31)MODULENAME,%C
                            CEPREFIX,MRTPREFIX)
%INTEGERFN GEN OMF(%INTEGER MODE)
%STRING(32) FILE,LIB,SUBNAME,VERSION
%STRING(64) S,FULLNAME
%INTEGER ADATE,ATIME,CONTROL,I,J,NAME DR0,NAME DR1
%INTEGER FULLNAME DR0,FULLNAME DR1,SIZE
%OWNSTRING(32) CEPREFIX,MRTPREFIX
       OMFRESULT=0
      %IF LAST WARNING#0 %AND COM28&X'2000'#0 %THEN LAST WARNING=0 %C
                 %AND %RESULT=0
      %IF COM28&X'20'#0 %THEN %RESULT=0
      FILE=OBJ_MODULE
      %IF OMFNAME#"" %THEN FILE=OMFNAME
      ADATE=ADDR(ICL9HNDATE)
      ATIME=ADDR(ICL9HNTIME)
      SUBNAME=CSUBNAME
      VERSION=CVERSION
      -> SKIP
      CEPREFIX="ICLSTDSW"
      MRTPREFIX="ICLSTDSW"
      ->SKIP
      CEPREFIX="ICLSTDSWFS";! FOR VME/K
SKIP: CONTROL=COM26
      %IF MODE=0 %OR OBJ_MAINEP=0 %OR COM27&X'40000'#0 %C
                                   %THEN CONTROL=CONTROL!4;!MAXKEYS
      ->SKIPM
      S="  OBJECT FILENAME IS  ".FILE
      I=ICL9HNNEWLINE(2)
      I=LENGTH(S)
      J=ADDR(S)+1
      ITOE(J,I)
      I=ICL9HNOUTPUTLINE(X'18000000'!I,J)
      I=ICL9HNNEWLINE(2)
SKIPM:S=FILE
      NAME DR0=X'18000000'!LENGTH(S)
      NAME DR1=ADDR(S)+1
      ITOE(NAMEDR1,LENGTH(S))
      %IF BYTEINTEGER(PROCPLEX)=0 %AND OBJ_MAINEP#0 %THENSTART
         STRING(PROCPLEX)=S
      %FINISH
      FULLNAME DR0=X'18000040'
      FULLNAME DR1=ADDR(FULLNAME)+1
      SIZE=-1;! DEFAULT
      J=ICL9HNCREATEMODULE(NAME DR0,NAME DR1,FULLNAME DR0,  %C
                                             FULLNAME DR1,SIZE)
      %IF J>0 %THENSTART
         RESULT=1
         LOG(0)
         %RESULT=4
      %FINISH
      J=OMFOUT(1,TEMP,WORK,CONTROL,CLANGCODE,ADATE,ATIME,SUBNAME,  %C
                  VERSION,FILE,MRTPREFIX,CEPREFIX)
      %IF J>0 %THEN RESULT=1
      ETOI(FULLNAME DR1,64)
      %CYCLE J=64,-1,1
        %IF CHARNO(FULLNAME,J)#32 %THEN %EXIT
      %REPEAT
      LENGTH(FULLNAME)=J
      %IF OMFRESULT>1 %THEN %RESULT=4
      J=ICL9HNENDMODULE(0)
      %IF J>0 %THENSTART
         RESULT=1
         LOG(3)
         %RESULT=4
      %FINISH
      PRINTSTRING(" OBJECT FILE CREATED -  ".FULLNAME)
      NEWLINE
      %RESULT=J
%END
!*
%ROUTINE MESSAGE(%INTEGER I,J)
      PRINTSTRING("COMPCTL FAILURE")
      WRITE(I,4)
      WRITE(J,4)
      NEWLINE
%END;! MESSAGE
!*
%INTEGERFN CREATEVS(%STRINGNAME S,%INTEGER SIZE,PROP,  %C
                                 %INTEGERNAME AD)
%INTEGER D0,D1,I
      I=ICL9HNCREATEVS(X'18000000'!LENGTH(S),ADDR(S)+1, %C
                SIZE,PROP,X'30000001',ADDR(D0))
      %IF I=0 %THENSTART
         AD=D1
      INTEGER(AD)=16
      INTEGER(AD+4)=16
      INTEGER(AD+8)=SIZE
      INTEGER(AD+12)=0
      %FINISH
      %RESULT=I
%END;! CREATEVS
!*
!*
!*                          SET OPTIONS
!*
%ROUTINE SET OPTIONS (%INTEGER ADR)
%INTEGER I,J,K,K2,L,M,N,P
%STRING(255) S,U
%STRING(15) T
%BYTEINTEGERARRAYFORMAT AA(0:255)
%BYTEINTEGERARRAYNAME A
      %BYTEINTEGERARRAY DIAGJSV(0:35)
      A==ARRAY(ADR,AA)
      ITSFLAG=0
      I=COM26
      J=COM27
      K=COM28
       K2=COM53
      %IF A(18)&X'80'#0 %THENSTART;! ITS OR PA MAY BE SET (TOP BIT OF CDIAG)
         P=JSREAD(E"ICL9HDSWITCH",X'30000001',ADDR(M),-1,-1)
         %IF P=0 %THENSTART
            %IF N&4#0 %THEN %START
      ITSFLAG=1
      J=J!X'40000' 
      K=K!X'10';! DEBUG (ITS)
      K=K!X'44040';  !TO FORCE DIAG=4 SHARE=YES AND IOS=NO
      I=I!X'400000'
      J=J&X'E3FEFFDF'   ;! TO FORCE CHECKS=ALL FOR ITS
%FINISH
         %FINISH
         P=JSREAD(E"ICL9HFDIAGJSV",-1,-1,X'18000024',ADDR(DIAGJSV(0)))
         %IF P=0 %THENSTART
            %IF DIAGJSV(10)&X'80'#0 %THEN J=J!X'80';! PROFILE (PATH ANALYSIS)
         %FINISH
      %FINISH
      %IF A(0)=0 %THEN K=K!X'20';! CODE=NO
      %IF A(0)=1 %THEN K=K!X'2000';!CODE=NW
      %IF A(1)=0 %THEN J=J!2;! LISTINGS=NOSOURCE
      %IF A(1)=3 %THEN K2=K2!X'1000';! LISTINGS=ERRORLINES
      PROCPLEX=ADR+A(2)
      %IF A(3)=0 %THEN K2=K2!X'200';! MESSAGES=SHORT
      K2=K2!(A(4)<<8);! MESSAGES AT END
      J=J!(A(5)<<11);! LISTINGS=XREF
      K=K!(A(6)<<7);! LISTINGS=ERL
      K=K!(A(7)<<15);!LISTINGS=MAPS
      J=J!(A(8)<<15);! LISTINGS=ATTR
      J=J!(A(9)<<14);! LISTINGS=OBJECT
      K=K!(A(10)<<16);! DIAGNOSTICS=N
      K=K!(A(12)<<6);! SHARE=YES
      I=I!(A(12)<<5);! DITTO FOR OMFOUT
      I=I!(A(13)<<4);! LIBPROC=YES
      %IF A(16)=0 %THEN K2=K2!X'400';! MESSAGES=NOCOMMENTS
      %IF A(23)=8 %THEN K=K!2;!  LENGTHS=I8
      %IF A(27)=8 %THEN K=K!4;!   LENGTHS=L8
      %IF A(31)=8 %THEN T="E8" %AND -> MESSOUT;!  CHECK FOR E8
      %IF A(31)=16 %THEN T="E16" %ELSE -> MISS;!  CHECK FOR E16
MESSOUT:
   U=" IS NOT A RECOGNISED VALUE FOR THE LENGTHS PARAMETER IN FORTRAN77"
      S="*** WARNING ".T.U
      L=LENGTH(S)
      P=ADDR(S)+1
      ITOE(P,L)
      M=ICL9HNLOG(X'18000000'!L,P,-1)
MISS:
      %IF A(34)=8 %THEN K=K!8;!   LENGTHS=R8
      %IF A(35)#0 %THEN J=J!X'20000000';! ARGUMENTS=MISMATCH
      %IF A(62)=0 %THEN K=K!X'4040' %AND I=I!X'00400000';!IOS=NO 
      %IF A(46)=0 %THEN K=K!X'200';! RUN=NO
      L=A(48);! RTCHECKS
      K=K!(L<<24);! RTCHECKS=N
      %IF L&4#0 %THEN J=J!X'20';! NOARRAY
      %IF A(53)=0 %THEN OMFNAME="";! AVOID ODD CE EFFECTS
      %IF OMFNAME="" %THEN K=K!X'10';! SEPARATE MODULES
      LISTINGSNONE=A(63)
      %IF LISTINGSNONE=0 %THEN K=K!X'800' %ELSESTART
         %UNLESS A(64)=0 %THEN PRINT CHECKS(0);! LISTINGS=OPTIONS
      %FINISH
      DISPLAYNONE=A(66)
      %IF 1<=A(67)<=2 %THEN K2=K2!1;! DISPLAY=SOURCE
      %IF A(67)=3 %THEN K2=K2!2;! DISPLAY=ERRORLINES
      K2=K2!(A(68)<<7);! DISPLAY=OPTIONS
      K2=K2!(A(70)<<5);! DISPLAY=OBJECT
      K2=K2!(A(72)<<3);! DISPLAY=XREF
      K2=K2!(A(73)<<2);! DISPLAY=ATTR
      K2=K2!(A(74)<<4);! DISPLAY=ERL
      %UNLESS DISPLAYNONE=0 %OR A(68)=0 %THEN PRINT CHECKS(-1)
      %IF CSTRICT="NO" %THEN J=J!(1<<19)
      COM26=I
      COM27=J
      COM28=K
      COM53=K2
%END
!*
!***                        COMPCTL
!*
%INTEGERFNSPEC CSUPPORT(%INTEGER EP,P1,P2,P3)
!*
%RECORDFORMAT SUMFMT(%INTEGER SLINE,ELINE,ERRORS,WARNINGS,  %C
    %INTEGER CODE,PLT,STACK,DIAG,%STRING(35) NAME,%STRING(11) ATTRIBUTE)
%OWNRECORDNAME SUMREC(SUMFMT)
%STRING(31) %FN ITOS(%INTEGER N,PLACES)
%CONSTINTEGERARRAY TENS(0:9)=%C
1,10,100,1000,10000,100000,1000000,10000000,100000000,1000000000
%STRING(11) RES
%INTEGER M,R,I,STARTED,J
      %IF N=0 %THEN %RESULT="0";
      %IF N<0 %THEN N=-N %AND RES="-" %ELSE RES=""
      STARTED=0
      %CYCLE I=9,-1,0
      R=TENS(I)
      %IF N>=R %OR STARTED#0 %START
      STARTED=1
      M=N//R
      RES=RES.TOSTRING(M+'0')
      N=N-M*R
      %FINISH
      %REPEAT
      J=PLACES-LENGTH(RES)
      %WHILE J>0 %CYCLE
      J=J-1
         RES=" ".RES
      %REPEAT
      %RESULT=RES
%END
!*
!*
!*
%INTEGERFN COMPCTL(%INTEGER OPTIONS DR0,OPTIONS DR1)
!*
%OWNINTEGER ALGHEAD=X'15151515'
%STRING(15) S
%STRING(255) DLINE,DERRORS,DWARNINGS,DISPLAYLINE
%INTEGER I,J,K,PROPERTY,OBJREC,OPTIONS1,COM46,SPARE
%INTEGER OPTIONS0,CONTROL
%INTEGER TOTERRS,TOTWARNS,TOTCODE,TOTPLT,TOTSTACK,TOTDIAG
%INTEGER ENTRIES,ENTRYSTART,DATA,STAK
!*
!***   LOOK AT AREA SET BY CE FOR OPTIONS
!*
!      PRINTSTRING("CE OPTION ARRAY")
!      NEWLINES(2)
!      DUMP(OPTIONS DR1,256)
      %IF MCOUNT=0 %THENSTART
         SET OPTIONS(OPTIONS DR1)
      %FINISHELSE ->SET AUX
!*
      %IF INITIALISED=1 %THEN ->SET AUX1
!*
!***  PROPERTY - DENSE 0:LOCALISED 1:SPARSE 2:SERIAL 3
!*
!*
SET AUX1:
      PROPERTY=1;! LOCALISED
!*
!***  TO CREATE AND INITIALISE AUXST
!*
      S=E"ICL9CEAUXST"
      I=4
      J=CREATEVS(S,I<<16,PROPERTY,AUX)
      AUXAD=AUX
      %IF J#0 %THENSTART
         K=1
ABORT:   MESSAGE(1,J)
         %RESULT=4
      %FINISH
!*
!***  TO CREATE AND INITIALISE WRK
!*
      %IF INITIALISED=1 %THEN ->SET AUX2
SET AUX2:
      S=E"ICL9CEWRK"
      I=8
      J=CREATEVS(S,I<<16,PROPERTY,WORK)
      %IF J#0 %THEN K=2 %AND -> ABORT
!*
!***  TO CREATE AND INITIALISE TMPOBJ
!*
      S=E"ICL9CETMPOBJ"
      I=8
      J=CREATEVS(S,I<<16,PROPERTY,TEMP)
      %IF J#0 %THEN K=3 %AND -> ABORT
      INITIALISED=1
SET AUX:
      MCOUNT=MCOUNT+1
      I=4
      INTEGER(AUX)=AUX+16
      INTEGER(AUX+8)=AUX+(I<<16-X'8000')
SET SUM AREA:
      SUMST=INTEGER(AUX+8)
      OMFCOUNT=0;! INITIALISE OMF MODULE COUNT
!*
!***  CALL COMPILER SUPPORT MODULE(FORTRAN)
!*
!*
   I=X'18000002'
         J=ADDR(ALGHEAD)
         K=2
      I=ICL9HNNEWSUBHEADING(I,J,K,-1);! FORCE TO NEW PAGE
      OPTIONS0=COM27
      OPTIONS1=COM28
      OBJ_OPTIONS2=COM53
      OBJREC=ADDR(OBJ_MODULE)
      COM46=0
      SPARE=0
      I=ICL9HNMONITOR(3)
!*
      OBJ_ADATE=ADDR(ICL9HNDATE)
      OBJ_ATIME=ADDR(ICL9HNTIME)
!*
!*
      %IF TEST4SET=1 %THEN I=PRIMECONTINGENCY(ONTRAPB)
!*
      OBJ_MODULE=OMFNAME
      LAST WARNING=0
J=ICL9CEF77CSM(ICL9HNREADCARD,ICL9HNOUTPUTLINE,           %C
                      CSUPPORT,WORK,TEMP,AUX,OBJREC,  %C
                      2,1,OPTIONS0,OPTIONS1,COM46,SPARE)
!*
      I=ICL9HNMONITOR(5)
!      DUMP(OPTIONS DR1,256)
      %IF J#0 %THEN RESULT=4 %AND ->PR SUMMARY
!*
!***  POST PROCESS OMF
!*
!      DUMP(TEMP,4096)
      %UNLESS COM28&X'10'#0 %AND CLANGCODE=C'G' %THENSTART
         J=GEN OMF(1)
      %FINISH
PR SUMMARY:
      TOTERRS=0;TOTWARNS=0;TOTCODE=0;TOTPLT=0;TOTSTACK=0;TOTDIAG=0
      %UNLESS OMFCOUNT<=0 %THENSTART
        ENTRIES=0
        PRSUM=1
        %UNLESS LISTINGSNONE=0 %THENSTART
         PRINTSTRING("                                               ")
         PRINTSTRING("END OF COMPILATION SUMMARY")
         NEWLINES(2)
         PRINTSTRING("  LINE  SECTION NAME           ")
         PRINTSTRING("ERRORS  WARNINGS              SIZE")
         PRINTSTRING("              ATTRIBUTE")
         PRINTSTRING("
                                                 ")
         PRINTSTRING("CODE  PLT+DATA  STACK  DIAGS")
         PRINTSTRING("
                                                     ")
         PRINTSTRING("(EXC COMMON)")
         NEWLINES(2)
        %FINISH
        %CYCLE I=0,1,OMFCOUNT-1
          SUMREC==RECORD(SUMST+(I*80))
          %IF SUMREC_SLINE=0 %THENSTART
            %IF ENTRIES=0 %THEN ENTRYSTART=SUMST+(I*80)
            ENTRIES=ENTRIES+1
          %FINISHELSESTART
           %UNLESS LISTINGSNONE=0 %THENSTART
            WRITE(SUMREC_SLINE,5)
            PRINTSTRING("  ".SUMREC_NAME)
            J=23-LENGTH(SUMREC_NAME)
            %UNLESS J<=0 %THENSTART
              SPACES(J)
            %FINISH
            WRITE(SUMREC_ERRORS,3)
            WRITE(SUMREC_WARNINGS,8)
            WRITE(SUMREC_CODE,8)
      %IF COM28&X'4000'#0 %THENSTART
         DATA=SUMREC_PLT+SUMREC_STACK
         STAK=0
      %FINISHELSESTART
         DATA=SUMREC_PLT
         STAK=SUMREC_STACK
      %FINISH
            WRITE(DATA,7)
            WRITE(STAK,8)
            WRITE(SUMREC_DIAG,6)
       %FINISH
      %UNLESS DISPLAYNONE=0 %THENSTART
      %IF SUMREC_WARNINGS=0 %AND SUMREC_ERRORS=0 %THEN -> MISS SUMMARY
      DLINE=""
      DERRORS=""
      DWARNINGS=""
      DLINE=ITOS(SUMREC_SLINE,4)
      DISPLAYLINE=DLINE."    ".SUMREC_NAME
      J=23-LENGTH(SUMREC_NAME)
      %WHILE J>0 %CYCLE
      J=J-1
      DISPLAYLINE=DISPLAYLINE." "
      %REPEAT
      %UNLESS SUMREC_ERRORS<=0 %THENSTART
         DERRORS=ITOS(SUMREC_ERRORS,5)
         DISPLAYLINE=DISPLAYLINE.DERRORS." ERROR(S)"
      %FINISH
      %UNLESS SUMREC_WARNINGS<=0 %THENSTART
         DWARNINGS=ITOS(SUMREC_WARNINGS,5)
         DISPLAYLINE=DISPLAYLINE.DWARNINGS." WARNING(S)"
      %FINISH
      ITOE(ADDR(DISPLAYLINE)+1,LENGTH(DISPLAYLINE))
      J=ICL9HNNEWLINE(1)
     J=ICL9HNLOG(X'18000000'!LENGTH(DISPLAYLINE),ADDR(DISPLAYLINE)+1,-1)
           %FINISH
      MISS SUMMARY:
           TOTERRS=TOTERRS+SUMREC_ERRORS
           TOTWARNS=TOTWARNS+SUMREC_WARNINGS
           TOTCODE=TOTCODE+SUMREC_CODE
           TOTPLT=TOTPLT+SUMREC_PLT
           TOTSTACK=TOTSTACK+SUMREC_STACK
           TOTDIAG=TOTDIAG+SUMREC_DIAG
           %UNLESS LISTINGSNONE=0 %THENSTART
            PRINTSTRING("  ".SUMREC_ATTRIBUTE)
            NEWLINE
            SPARE=SUMREC_ELINE
            %IF ENTRIES#0 %THENSTART
              %CYCLE K=1,1,ENTRIES
                SUMREC==RECORD(ENTRYSTART)
                PRINTSTRING("          ".SUMREC_NAME)
                J=23-LENGTH(SUMREC_NAME)
                %UNLESS J<=0 %THEN SPACES(J)
                SPACES(46)
                PRINTSTRING(SUMREC_ATTRIBUTE)
                NEWLINE
                ENTRYSTART=ENTRYSTART+80
              %REPEAT
              ENTRIES=0
            %FINISH
           %FINISH
          %FINISH
        %REPEAT
      %UNLESS DISPLAYNONE=0 %THEN %START
          DLINE=ITOS(OMFCOUNT,3)
          DISPLAYLINE="NO. OF SECTIONS:".DLINE
          ITOE(ADDR(DISPLAYLINE)+1,LENGTH(DISPLAYLINE))
          J=ICL9HNLOG(X'18000000'!LENGTH(DISPLAYLINE),  %C
                     ADDR(DISPLAYLINE)+1,-1)
          %FINISH
        %UNLESS LISTINGSNONE=0 %THENSTART
          NEWLINE
          PRINTSTRING("  TOTAL LINES =")
          WRITE(SPARE,5)
          PRINTSTRING("          ")
          WRITE(TOTERRS,3)
          WRITE(TOTWARNS,8)
          WRITE(TOTCODE,8)
      %IF COM28&X'4000' #0 %THEN TOTPLT=TOTPLT+TOTSTACK %AND TOTSTACK=0
          WRITE(TOTPLT,7)
          WRITE(TOTSTACK,8)
          WRITE(TOTDIAG,6)
          NEWLINES(2)
         %FINISH
        PRSUM=0
      %FINISH
      %IF RESULT>0 %THEN %RESULT=4
      %IF TOTWARNS>0 %THEN %RESULT=-2
      I=ICL9HNMONITOR(4)
      %RESULT=0
%END
!*
!***                          CSUPPORT
!*
%SYSTEMINTEGERFN CSUPPORT(%INTEGER EP,P1,P2,P3)
!*
!***  SERVICES FOR 0 LOG MESSAGE  1  NEWLINE  2  NEWPAGE
!***               3 SUBHEADING   4 GEN OMF   5  MONITOR
!***               6  ABORT       7 END OF COMPILATION SUMMARY
!*
%SWITCH SW(0:7)
%INTEGER I,J,DESTINATION
      -> SW(EP) %UNLESS EP<0 %OR EP>7
      %RESULT=1
SW(0): !LOG MESSAGE P1 AND P2 DESCRIPTOR TO MESSAGE
      DESTINATION=4
      J=ICL9HNLOG(P1,P2,DESTINATION)
      %RESULT=J

SW(1): !NEWLINE P1 HOLDS NUMBER OF NEWLINES REQUIRED
      J=ICL9HNNEWLINE(P1)
      %RESULT=J
SW(2): !NEWPAGE  REQUIRES NO PARAMETER
      J=ICL9HNNEWPAGE
      %RESULT=J
SW(3): !SUBHEADING  P1 @ DESCRIPTOR TO SUBHEADING-P2 LINES-P3 NEWPAGE
      J=ICL9HNNEWSUBHEADING(INTEGER(P1),INTEGER(P1+4),P2,P3)
      %RESULT=J
SW(4): !GEN OMF
      J=GEN OMF(P1)
      %RESULT=0
SW(5): !MONITOR   P1 HOLDS TAG VALUE
      J=ICL9HNMONITOR(P1)
      %RESULT=J
SW(6): !ABORT VIA NDIAG
      %MONITOR
      %RESULT=0
SW(7): !COMPILATION SUMMARY
       !PASS SUMMARY LINE TO AUXSTACK
      SUMREC==RECORD(SUMST+(OMFCOUNT)*80)
      MOVE(80,P1,ADDR(SUMREC_SLINE))
      %IF COM28&X'10'#0 %THEN LAST WARNING=SUMREC_WARNINGS %C
           %ELSE LAST WARNING=SUMREC_WARNINGS+LAST WARNING
      OMFCOUNT=OMFCOUNT+1
      %RESULT=0
%END
!*
!***                         SET ALIAS
!*
%SYSTEMINTEGERFN SET ALIAS(%LONGINTEGER NAME DR)
%INTEGER I
I=ICL9HNCREATEALIAS(NAME DR,-1)
     %IF I>0 %THEN %START
          RESULT=1
         LOG(2)
         OMFRESULT=1
        %RESULT=4
      %FINISHELSE %RESULT=I
%END
!*
!***                           OMF RECORD
!*
%SYSTEMINTEGERFN OMFRECORD(%LONGINTEGER DR)
%INTEGER I
I=ICL9HNOUTPUTRECORD(DR)
      %IF I>0 %THENSTART
         RESULT=1
         OMFRESULT=2
         LOG(1)
         %RESULT=4
      %FINISHELSE %RESULT=I
%END
!*
!***                         ICL9CEFORTRANG
!*
%EXTERNALINTEGERFN  %C
                 FORTRAN77(%LONGINTEGER INPUT,OMF,CODE,   %C
                                GENERATIONSKEPT,RUN,PROCEDURE,   %C
                            LISTINGS,DISPLAY,MESSAGES,SAVELIST,DIAGS,%C
                                STRICT,CHECKS,RTCHECKS,EXTERNALPROCS, %C
                         SHARE,LIBPROC,LENGTHS,ITEMSONSTACK, %C
                         DFILE,DIRECTIVES,CDIAG)
%CONSTSTRING(16)  KEY=E"ICL9CECHECKS"
%OWNINTEGERARRAY LINK(0:18)
%INTEGER FLAG,FLAGS DR0,FLAGS DR1,D0,D1,J,I,RDIAG
%STRING(63) S,OPT
      %LONGINTEGERFN SET DESC(%INTEGERFN R)
      %LONGINTEGER I
         *LSD_(%LNB+5)
         *ST_I
      %RESULT=I
      %END
!*
      *STLN_I
      ENTRYLNB=I
      RESULT=0;! IN ANTICIPATION
      MCOUNT=0
      PRSUM=0;! SUMMARY FLAG
!      I=ICL9HNMONITOR(1)
      I=ENTRY LNB+20
!      %CYCLE J=0,1,37
!      PHEX(INTEGER(I))
!      NEWLINE
!      I=I+4
!      %REPEAT
!*
!*** SET UP LINK WORD,BIT LIST IN LINK 20-23 AND COMPILER ENTRY
!*
      S=CIDENT
      STRING(ADDR(LINK(6))-1)=S
      LINK(0)=X'18000015'
      LINK(1)=X'00000018'
      LINK(2)=137
      LINK(3)=X'00000030'
!*
!*** RTCHECKS AT X'0001FF80' IN LINK(15)
!*
         LINK(14)=X'C7FBFFF8'
         LINK(15)=X'07DFEFF3'
         LINK(16)=X'C6400001'
         LINK(17)=X'F0FB3300'
         LINK(18)=X'0F800000'
      LONGINTEGER(ADDR(LINK(4)))=SET DESC(COMPCTL)
      FLAG=CFLAG
      FLAGS DR0=X'18000002'
      FLAGS DR1=ADDR(FLAG)
!*
!***  CALL BPARS
!*
      BPARS(OMF,EXTERNALPROCS,CHECKS,STRICT,I)
      ->SKIP
      %IF OMFNAME#"" %THEN OMF=-1;!IN CASE CE STARTS REJECTING HOOK.NAME
SKIP:
!*
!***  COPTIONS NOW HOLDS STRING OF OPTIONS REQUESTED
!*
      COM26=0
      COM27=X'81400001'
      COM28=1;! SET CE FLAG
      COM53=0
         I=READ JS VAR(KEY,OPT)
         %IF I=0 %THEN I=PARM(OPT)
      JSVARREAD=0
      TEST4SET=0
      I=PARM(COPTIONS)
      %IF TEST4SET#0 %THEN I=PRIME CONTINGENCY(ONTRAPB)
!*
!***  CALL COMPILESUPPORT(ARG,TRACE,RDIAG,CODE-LATER)
!*
      RDIAG=-1
      J=ICL9HNCOMPILESUPPORT(FLAGS DR0,FLAGS DR1,ADDR(LINK(0)),       %C
                             INPUT,OMF,RUN,LISTINGS,MESSAGES,SAVELIST,%C
                             X'30000001',ADDR(DIAGS),RTCHECKS,SHARE,  %C
                             -1,LIBPROC,LENGTHS,-1,-1,-1,-1,%C
                           -1,-1,ITEMSONSTACK,-1,-1,-1,-1,-1,-1,-1,-1,%C
                       RDIAG,-1,-1,-1,DFILE,-1,-1,-1,-1,-1,CDIAG,%C
                       -1,-1,CODE,X'30000001',ADDR(GENERATIONSKEPT),%C
                         PROCEDURE,DIRECTIVES,-1,-1,DISPLAY,-1)
      %IF J=0 %THEN I=ICL9HNMONITOR(2)
      %IF J=-2 %THEN J=-40515
      %IF J=4 %THEN J=40517
      %RESULT=J
%END
!*
!***                         ICL9CEFORTRANG
!*
%SYSTEMROUTINE STOP
%INTEGER I
      I=ENTRYLNB
      *LLN_I
      *EXIT_-64
%END;! STOP
!*
!*
%SYSTEMINTEGERFN IOCP(%INTEGER EP, N)
%CONSTINTEGER OUTMARG2=132
%OWNBYTEINTEGERARRAY OUTPUTBUFF(0:132)=10,0(132)
%OWNINTEGER OUTPTR=1
%ROUTINESPEC OUTPUTRECORD
%INTEGER I, X, L, CH
%SWITCH SW(1:22)
            ->SW(EP)
SW(3):                                  ! PRINT SYMBOL(N)
SW(5):                                  ! PRINT CH(N)
            %IF (N=10 %OR N=12 %OR N=13) %THEN %START
               OUTPUTBUFF(OUTPTR)=N
               OUTPUTRECORD;  OUTPUTBUFF(0)=N
               ->END2
            %FINISH
            OUTPUTBUFF(OUTPTR)=N
            OUTPTR=OUTPTR+1
            %IF OUTPTR>OUTMARG2 %THEN %START
               OUTPUTBUFF(OUTPTR)=10
               OUTPUTRECORD
            %FINISH
END2:       %RESULT=0
SW(15):                                 ! RESTRICTED PRINTSTRING
                                        ! STRING MUST HAVE NO UNPRINTABLES
                                        ! OR CONTROLS (XCEPT LAST CHAR)
                                        ! AND MAY NOT EXCEED MARGINS
!
SW(7):                                  ! PRINT STRING(N) WHERE
                                        ! N IS ADDRESS OF STRING
            L=BYTEINTEGER(N)
            %IF L=0 %THEN %RESULT=0
            %CYCLE I=1,1,L
               CH=BYTEINTEGER(I+N)&X'7F'
               %IF CH=10 %THEN OUTPUT RECORD %ELSE %START
                  OUTPUTBUFF(OUTPTR)=CH
                  OUTPTR=OUTPTR+1
                  %IF OUTPTR>OUTMARG2 %THEN OUTPUT RECORD
               %FINISH
            %REPEAT
            %RESULT=0
SW(9):                                  ! SELECT OUTPUT
SW(11):                                 ! OUTPUT THE CURRENT RECORD
            OUTPTR=1
            OUTPUTBUFF(0)=10
            %RESULT=0
SW(17):                                 ! REPEATED PRINT SYMBOL
         %RESULT=0 %IF N<0 %OR N>>8=0
         %CYCLE I=1,1,N>>8
            X=IOCP(3,N&127)
         %REPEAT
         %RESULT=0
%ROUTINE OUTPUTRECORD
%INTEGER I,J,K
      I=ADDR(OUTPUTBUFF(1))
      J=OUTPTR-1
      %IF J<=0 %THENSTART
         %CYCLE K=1,1,2
            OUTPUTBUFF(K)=' '
         %REPEAT
         J=2
      %FINISH
      ITOE(I,J)
      %IF PRSUM=1 %THEN K=ICL9HNOUTPUTLINE(X'18000000'!J,I) %ELSE %C
        K=ICL9HNLOG(X'18000000'!J,I,-1)
      OUTPTR=1
      OUTPUTBUFF(0)=10
%END;! OUTPUTRECORD
%END;! IOCP
!*
%SYSTEMROUTINE WRITE(%INTEGER I,N)
%STRING(16) S
%INTEGER D0,D1,D2,D3,MINCHARS,J
      N=N&15
      %IF I=0 %THENSTART
         %IF N=0 %THEN N=1
         SPACES(N)
         PRINTSYMBOL('0')
         %RETURN
      %FINISH
      D0=X'18000010'
      D1=ADDR(S)+1
      *LD_D0
      *LSS_I
      *CDEC_0;! 15 DECIMAL DIGITS IN ACC
      *MPSR_X'20';! SET CC=0
      *SUPK_%L=15,0,32;! UNPACK 15 DIGITS, LEADING ZEROS SUPPRESSED
      *STD_D0;! DESCRIPTOR TO END OF UNPACK AREA
      *LSD_%TOS
      *ST_D2;! DESCRIPTOR TO POTENTIAL SIGN POSITION
      %IF D1-D3<3 %THENSTART;! ZERO
         MINCHARS=2
         ->SETLEN
      %FINISH
      %IF I<0 %THEN BYTEINTEGER(D3)='-'
      MINCHARS=D1-D3
SETLEN:J=IOCP(17,(N-MINCHARS+1)<<8!' ');! SPACES(N-MINCHARS+1)
      J=MINCHARS+1
      D1=D1-J
      *LD_D0
      *LDB_J;! LENGTH OF STRING
      *LB_J
      *SBB_1
      *MVL_%L=1;! INSERT LENGTH
      *MODD_1;! POINT TO FIRST DIGIT
      *MVL_%L=%DR,15,48;! SET TOP QUARTETS FOR ISO
      J=IOCP(15,D1);! FAST PRINTSTRING
%END;! WRITE
!*
%ENDOFFILE