!* MODIFIED 06/03/86
!*
%include "ftn_ht"
%include "ftn_consts1"
%include "ftn_fmts1"
%include "ftn_triadops1"
!*
%include "ftn_gsynt62"
!*
!********************************* exports ****************************
!*
%integerfnspec Generate(%record(Triadf)%arrayname Triads,
                      %integername Nexttriad,
                      %integer Kgen,Path,Labrecad,Acom,
                      %integerarrayname Output)
!*
!********************************* imports ****************************
!*
%externalroutinespec Print Tr(%integer Index,Adict,Anames,Level,
                              %record(Triadf)%name Triad)
%externalintegerfnspec Coerce Const(%integer A,Oldmode,Newmode,Adict,
                                    %integername Dptr)
%externalroutinespec Const Eval(%integer Resl,Op,Resr,
                                %record(Resf)%name Res,%integer Ptr,
                                %integername Dptr)
%externalintegerfnspec Gconval(%integer Il,Op,Ir,%integername Val)
%externalroutinespec New Temp(%record(Resf)%name R,%integer M,Use)
%externalroutinespec Codegen(%integer Cgenep,
                             %record(Triadf)%arrayname Triads,
                             %integer Comad)
%externalroutinespec Freelistcell(%integername Listhead,%integer N)
%externalroutinespec Dicful
%externalintegerfnspec Genful
%externalroutinespec F77abort(%integer N)
%externalroutinespec Lfault(%integer Er)
%externalroutinespec Tfault(%integer Er,Ta,Tb)
%externalroutinespec Fault(%integer Er)
%externalroutinespec Ifault(%integer E,I)
%externalintegerfnspec Newlistcell(%integername Listhead,%integer N)
%externalintegerfnspec Freesp(%integer N)
%externalintegerfnspec Setlab(%integer Lab,%integername Labrecptr)
%externalintegerfnspec Setconrec(%record(Resf) R)
%externalintegerfnspec Conin(%integer Val)
%externalintegerfnspec Dictspace(%integer Length)
%externalroutinespec Cklab
%externalroutinespec Optctl(%integer Acom,Nexttr,Bits,Assgotos)  
%externalroutinespec Optsource(%integer A,B,C,D,E,F)             
%externalintegerfnspec Op4 Save
%externalintegerfnspec Op4 Ref(%string(63) S)
!*
!**********************************************************************
!*
%owninteger Comad
%owninteger Pathreport  ;!  0
                         !  1  FORCE UPDATE TO TABLE WHETHER OR NOT LABELLED
!*
%owninteger Stfnstart
%owninteger Loglist
%ownrecord(Resf) Res
%ownrecord(Resf) Rnull
%owninteger Dotest
%owninteger Notflag
%owninteger Relop
%owninteger Cexmode;! 'const' expression mode - 
%owninteger Tmlist
!*
%constinteger RNULLW=0
!*
%CONSTSTRING(12)%array IOSPECS(1:25)=  %C
   "UNIT=", "FMT=", "REC=", "END=", "ERR=","IOSTAT=","FILE=","STATUS=",
   "ACCESS=","FORM=","RECL=","BLANK=","EXIST=","OPENED=","NUMBER=",
   "NAMED=","NAME=","NREC=","SEQUENTIAL=","DIRECT=","FORMATTED=",
   "UNFORMATTED=","NEXTREC=","DESC=",""
!*
%CONSTSTRING(9)%array IOTYPES(1:8)=  %C
   "READ", "WRITE", "REWIND", "BACKSPACE",
   "ENDFILE", "OPEN", "CLOSE", "INQUIRE"
!*
%CONSTINTEGERARRAY IOMASKS(1:8)=  %C
   X'7E',X'6E',X'62'(3),X'1041FE2',X'1E2',X'FFFEE2'
!*
%CONSTBYTEINTEGERARRAY OPENPP(0:25)=  %C
   0(7),X'42',X'43',X'44',X'45',0,X'46',0(5),1,0(5),X'47',0
!*
%CONSTBYTEINTEGERARRAY CLOSEPP(0:25)=0(8),X'40',0(17)
!*
%CONSTBYTEINTEGERARRAY INQUIREPP(0:25)=  %C
   0(7),X'40',0,X'66',X'69',X'2C',X'4E',X'A1',X'A2',X'23',X'A4',
   X'45',X'30',X'47',X'48',X'4A',X'4B',X'2D',X'4F',0
!*
!*
!***********************************************************************
!*
!*
%EXTERNALINTEGERFN GET PLAB
!***********************************************************************
!* Provide a new dict record for a private label                       *
!***********************************************************************
%RECORD(COMFMT)%NAME COM
%RECORD(PLABF)%NAME PLAB
%RECORD(RESF) R
%INTEGER I
      COM==RECORD(COMAD)
      I=COM_DPTR
      COM_DPTR=COM_DPTR+PLABRECSIZE
      DICFUL %IF COM_DPTR>COM_DICLEN
      PLAB==RECORD(COM_ADICT+I)
      PLAB_BLKIND=0
      PLAB_USE=0
      PLAB_X1=17;! referenced in explicit GOTO
      PLAB_INDEX=COM_NEXT PLAB
      PLAB_CODEAD=0
      PLAB_REF=0
      PLAB_REFCHAIN=0
      COM_NEXT PLAB=COM_NEXT PLAB+1
      R_H0=I>>DSCALE
      R_FORM=PLABID
      R_MODE=0
      %RESULT=R_W
%END;! GET PLAB
!*
%EXTERNALINTEGERFN NEW TRIADR(%INTEGER OP,RES1W,RES2W)
%INTEGER CUR,I
%RECORD(TRIADF)%NAME TR
%record(Comfmt)%name Com
      Com==record(Comad)
      CUR = COM_NEXT TRIAD
      COM_NEXT TRIAD = CUR + 1
      TR==RECORD(COM_ATRIADS+CUR*12)
      TR_OP=OP
      TR_USE=0
      TR_RES1_W=RES1W
      TR_RES2_W=RES2W
      TR_CHAIN=COM_NEXT TRIAD
      %RESULT = CUR
%END;! NEW TRIADR
!*
%EXTERNALINTEGERFN NEW TRIAD2(%INTEGER OP,SLN,QOPD2,OPD2,VAL2)
%INTEGER CUR
%RECORD(TRIADF) %NAME TR
%record(Comfmt)%name Com
      Com==record(Comad)
      CUR = COM_NEXT TRIAD
      COM_NEXT TRIAD = CUR + 1
      TR==RECORD(COM_ATRIADS+CUR*12)
      TR_OP=OP
      TR_VAL2=VAL2
      TR_SLN=SLN
      TR_QOPD2=QOPD2
      TR_OPD2=OPD2
      TR_MODE2=0
      TR_CHAIN=COM_NEXT TRIAD
      %RESULT = CUR
%END;! NEW TRIAD2
!*
!*
%externalintegerfn Generate(%record(Triadf)%arrayname Triads,
                          %integername Nexttriad,
                          %integer Kgen,Path,Labrecad,Acom,
                          %integerarrayname Output)
!*
%routinespec ARITHOP(%record(RESF) Resl,%integer OP,%record(RESF) Resr)
%routinespec CONDC(%integer LLIST)
%routinespec LOGTOACC(%integer NOT)
%routinespec ANDOR(%integer P1)
%routinespec SETCA(%record(RESF) R)
%integerfnspec SIMPLE INT(%integer R)
%routinespec CHECK BACK LAB
%routinespec START OF DO LOOP(%integer MODE)
%routinespec END DO SUB(%integer DOREC,P)
%routinespec END OF DO LOOP(%integer Mode)
%routinespec LINK PARAM(%integer FPTR,R)
%routinespec INTRINFN(%integer FNPTR,PCT,PLINK)
%routinespec MOD LHS OP(%record(RESF) RES,%integer MODE)
%integerfnspec New Plab
%integerfnspec INSERT STFN
%integerfnspec Convert(%integer Resw,Newmode)
!{PA}  %routinespec PATHCOUNT(%integer LINE,INDEX)
!{ITS} %routinespec ITSACT(%integer ENTRY)
!*
%integer ADICT,ATRIADS,IGEN,I,J,K,L,ADJ,PTR,SPTR,PCT,CONCATLIST
%integer SAVELINK, II, KK, LL, SAVEINDEX
%integer BC,OP,DOLAB,P,P1,P2,CHResl,CHResr
%integer IOFORM,IOMODE,IOINDEX,IOCONTROLS,IOMASK,IOTYPE
%integer IOFLAGS
%integer CUR STATFN
%integer STAT TRIAD;! first triad for current statement
%integer STAT TYPE;! set non-zero for statements requiring special treatment
%integer FALSE JUMP;! triad index of last triad in logical if condition
%integer SAVECONCATS;! push CONCATLIST in PHI91 and pop in PHI92
%record(RESF) TRUE LAB;! res plabel record for true addresses in logical if
%record(RESF) LOGPTR
%record(ARRAYDVF)%name DVREC
%record(PRECF)%name PP
%record(SRECF)%name SS
%record(LRECF)%name LLL
%record(DORECF)%name DOREC
%record(PRECF)%name ARRAYREC
%record(PRECF)%name STATFN
%record(IFRECF)%name IFREC
%record(LABRECF)%name LABREC
%record(FNRECF)%name FNREC
%record(CONSTRECF)%name CON
%record(PLABF)%name PLAB
%record(RESF) Resl,Resr,CHRES
%record(COMFMT)%name COM
%record(TRIADF)%name TR
%record(OBJFMT)%name OBJ
%integer IODOINIT,IODEPTH,IOCURDIMS,IOSTARTED
%record(RESF)%array SUBSCRIPT(0:7)
%recordformat GSAVEFMT(%shortinteger II,KK,LL,SL)
%record (GSAVEFMT) %name GSAVE
%switch PHI(0 : 100)
%switch SW52(1:12)
!*
%include "ftn_copy1"
!*
!*
!***********************************************************************
!* Routines to generate triads                                         *
!***********************************************************************
!*
%routine TRIAD ERROR
      F77abort(1)
%end;! TRIAD ERROR
!*
%integerfn ADDR TRIAD(%integer INDEX)
      %if INDEX>COM_MAXTRIADS %then TRIAD ERROR
      %result=ADDR(TRIADS(INDEX))
%end;! ADDR TRIAD
!*
%routine PRINT CHTRIADS
%record(TRIADF)%name TR
%integer CH
      CH=1
      %cycle
        TR==record(ATRIADS+CH*TRIADLENGTH)
        PRINT TR(CH,COM_ADICT,COM_ANAMES,0,TR)
        CH=TR_CHAIN
      %repeat %until CH=0
%end;! PRINT CHTRIADS
!*
%routine Call Tfault(%integer Er,%string(31) S,%integer Tb)
      Tfault(Er,addr(S),Tb)
%end;! Call Tfault
!*
%integerfn NEW TRIAD(%integer OP,RES1W,%integer QOPD2,OPD2)
%integer CUR
%record(TRIADF) %name TR
      CUR = NEXT TRIAD
      NEXT TRIAD = CUR + 1
{%include "pf_gen1"}
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!+ possible architecture-dependant optimisation
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
{end "pf_gen1"}
      TR==record(ADDR TRIAD(CUR))
      TR_OP=OP
      TR_USE=0
      TR_RES1_W=RES1W
      TR_QOPD2=QOPD2
      TR_OPD2=OPD2
      TR_MODE2=0
      TR_CHAIN=NEXT TRIAD
      %result = CUR
%end;! NEW TRIAD
!*
%integerfn Triad Res(%integer MODE,OP,RES1W,RES2W)
%record(Resf) R
      R_H0=NEW TRIADR(OP,RES1W,RES2W)
      R_MODE=MODE
      R_FORM=TRIAD
      %result=R_W
%end;! Triad Res
!*
%integerfn Form Res(%integer H0,FORM,MODE)
%record(Resf) R
      R_H0=H0
      R_FORM=FORM
      R_MODE=MODE
      %result=R_W
%end;! Form Res
!*
!*
%integerfn CONOUT(%record(RESF) R)
%record(CONSTRECF)%name CON
      %if R_FORM=LIT %then %result=R_H0
      %if R_FORM=NEGLIT %then %result=-R_H0
      CON==record(COM_ADICT+R_H0<<DSCALE)
      %result=integer(COM_ADICT+CON_DADDR)
%end;! CONOUT
!*
%routine Check Do Index(%integer Rd,Dohead)
%record(Dorecf) %name Dorec
      %while Dohead#0 %cycle
         Dorec==record(Com_Adict+Dohead)
         %if Dorec_Indexrd_W=Rd %thenstart;! NESTED USE OF DO VAR
            Lfault(147)
            %return
         %finish
         Dohead=Dorec_Link1
      %repeat
%end;! Check Do Index
!*
      COMAD=ACOM;! for any other routines to map
      COM==record(ACOM)
      ADICT=COM_ADICT
      ATRIADS=ADDR(TRIADS(0))
      STAT TRIAD=NEXT TRIAD;! first triad for this statement
      STAT TYPE=0
      CONCATLIST=0
      SAVECONCATS=0
      SAVEINDEX=0
!*
      %if Path=-2 %thenstart;! subprog entry
         I = New Triad2(STMT,Com_Linest,NULL,NULL,2)
         PP==record(Adict+Labrecad);! actually the subprog record
         Resl_W=New Plab
         PP_Disp=Resl_H0
         Plab_X1=9;! explicitly referenced, entry statement
         I = New Triad2(STMT,Labrecad,PLABID,Resl_H0,0)
         %result=0
      %finish
!*
      %if Path=-3 %thenstart;! start of statement fn
         Stfnstart=Next Triad
         %result=0
      %finish
!*
      %if Labrecad # NULL %thenstart
         Labrec==record(Adict+Labrecad)
         Dolab=Labrec_X0&4
      %finishelse Dolab=0
      %if Path = 3 %then Dotest=1 %and -> Checkdo;! avoid any spurious errors when checking DO labels
      %unless Path=-1 %thenstart;! except for const eval
         %if Com_Nextch # 10 %or Path = 0 %thenstart
            %if Com_Maxinp>Com_Inp %then Com_Inp=Com_Maxinp
            Fault(100);                         ! syntax error
            Dotest=1;! to avoid spurious error report
            -> Check Do
         %finish
      %finish
      NOTFLAG = 0
      DOTEST = 0
      PCT = 0
      COM_FNLST=0
      %if KGEN<0 %thenstart
         KGEN=-KGEN
         IGEN=OUTPUT(KGEN)
      %finishelse IGEN=KGEN
!*
!******** statement triad
!*
      %if LABRECAD # NULL %thenstart
         I=LABID
         J=1
      %finishelsestart
         -> CHECK DO %if OS(IGEN)=0
         I=NULL
         J=2
      %finish
      %UNLESS PATH=-1 %thenstart
         I = NEW TRIAD2(STMT,COM_LINEST,I,LABRECAD>>DSCALE,J)
      %finish
      -> CHECK DO %if OS(IGEN) = 0;  ! NO CODE TO PLANT
!*
!******** PATH ANALYSIS
!*
!{PA}  %if COM_PATHANAL#0 %and PATH>0 %thenstart
!{PA}     %if COM_LAB#0 %or PATHREPORT#0 %then PATHCOUNT(COM_LINEST,0)
!{PA}     PATHREPORT=0
!{PA}  %finish
!*
!*
      BC=0
      LL=0
      SAVELINK=0
      II=0
      KK=0
      LL=0
      ->START
PHI(1):
PHI1: II = IGEN+1
      KK = KGEN
                                        !RHO-SYMBOL
      LL = KGEN+OS(IGEN)
PHI1A:IGEN = OUTPUT(LL)
      %if IGEN<=0 %thenstart
         KGEN = -IGEN
         IGEN = OUTPUT(KGEN)
      %finish
      SAVELINK=1
START:
{%include "pf_gen3"}
      I=SAVEINDEX
      SAVEINDEX=SAVEINDEX+W4
      %IF SAVEINDEX>=COM_MAXGEN %THENSTART
            %IF GENFUL#0 %THENSTART
               LFAULT(307)
               %result=0
               %FINISH
            %FINISH
           GSAVE==RECORD(COM_SAVEGEN+I)
      GSAVE_II=II
      GSAVE_KK=KK
      GSAVE_LL=LL
      GSAVE_SL=SAVELINK
{end "pf_gen3"}
L1:   P = OS(IGEN)
      IGEN = IGEN+1
      %if COM_PTRACE#0 %thenstart
         PRINTSTRING(" PHI")
         WRITE(P,2)
         SPACE
      %finish
      -> PHI(P)
PHI(0):
{%include "pf_gen4"}
      SAVEINDEX=SAVEINDEX-W4
      GSAVE==RECORD(COM_SAVEGEN+SAVEINDEX)
      II=GSAVE_II
      KK=GSAVE_KK
      LL=GSAVE_LL
      SAVELINK=GSAVE_SL
{end "pf_gen4"}
      %if SAVELINK=0 %thenstart
CHECK DO:%if DOLAB = 4 %then END OF DO LOOP(0)
         %result=0
      %finish
      OUTPUT(LL)=Res_W
      IGEN=II
      KGEN=KK
      ->L1
!*
PHI(2):->L1;! DUMMY
!*
PHI(3):IGEN=OS(IGEN)<<8!OS(IGEN+1)
      ->L1;! for patching
!*
PHI(10):
!***********************************************************************
!* ARITHOP WITH OP,Resl AND Resr FROM TREE                             *
!***********************************************************************
      !SETP3
      OP = OS(IGEN)
      Resl_W = OUTPUT(KGEN+OS(IGEN+1))
      Resr_W = OUTPUT(KGEN+OS(IGEN+2))
      IGEN=IGEN+3
L100:
      %if Resl_FORM=LABID %thenstart;! assigned label
         SS==record(ADICT+NEWLISTCELL(COM_ASSGOTOS,2))
         SS_INF0=Resl_H0<<DSCALE
         I=NEW TRIADR(ASGN,Resr_W,Resl_W)
         ->L1
      %finish
      %if HOLMODE>=Resl_MODE>=CHARMODE  %C
             %or HOLMODE>=Resr_MODE>=CHARMODE %thenstart
         %UNLESS Resl_MODE=CHARMODE %and Resr_MODE=CHARMODE  %C
                       %and (OP=1 %or OP=7) %thenstart
            LFAULT(132)
            %result=0
         %finish
         Res_W=Triad Res(CHARMODE,OP,Resr_W,Resl_W)
         %if COM_OPT#0 %then MOD LHS OP(Resr,0)
      %finishelse ARITHOP(Resl,OP,Resr)
      -> L1
!*
PHI(11):
!***********************************************************************
!* RES = constant integer                                              *
!***********************************************************************
      Res_W=OS(IGEN)
      IGEN=IGEN+1
      ->L1
!*
PHI(12):

!***********************************************************************
!* SAVE CURRENT OPERAND DESCRIPTOR AND OPERATOR IN GENERATE TREE       *
!***********************************************************************
      !SETP1
      PTR=FREESP(2)
      SS==record(PTR+ADICT)
      SS_INF0=OP
      SS_LINK1=Res_W
      OUTPUT(KGEN+OS(IGEN))=PTR
      IGEN=IGEN+1
      -> L1
!*
PHI(13):

!***********************************************************************
!* SET RESULT DESCRIPTOR FROM TREE ENTRY P1                            *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      Res_W = OUTPUT(KGEN+P1)
      CHRES=RES;! in case needed for substring checking
      COM_RESCOM1=Res_W;! for ANALYSE to reference const expression
      -> L1
!*
PHI(15):
!***********************************************************************
!* PLANT CODE FOR ARITHMETIC IF                                        *
!***********************************************************************
%BEGIN
%CONSTBYTEINTEGERARRAY ARITHIFMASK(0:7)= %C
   0, JIP, JIZ, JINN, JIN, JINZ, JINP, 0 ;! USED BY PHI(15) TO OPTIMISE ARITH IF BRANCHES
         %CONSTINTEGERARRAY NEXT(0:2)=1,2,0
         %integerARRAY LDESC(0:2),FL(0:2)
         %integer DEFAULT,LAST
            DEFAULT=0
            LAST=0
            %cycle I = 0,1,2
               Resl_W=OUTPUT(KGEN+I+1)
               %if Resl_W=0 %then DEFAULT=1;! some label refers to next stat
               LDESC(I) = Resl_H0
               FL(I) = 1<<I
            %repeat
            %cycle I = 0,1,2
               J=NEXT(I)
              %if LDESC(I) = LDESC(J) %thenstart
                  FL(J)=FL(J)!FL(I)
                  LDESC(I) = 0
                  FL(I)=0
               %finishelsestart
                  %if I>LAST %then LAST=I;! identifies the last jump
               %finish
            %repeat
            %cycle I = 0,1,2
               J=LDESC(I)
               %UNLESS J = 0 %thenstart
                  LABREC==record(ADICT+J<<DSCALE)
                  K=ARITHIFMASK(FL(I))
                  %if K=0 %or (DEFAULT=0 %and LAST=I) %thenstart;! ALL REMAINING LABELS THE SAME
                     Res_W=Form Res(J,LABID,0)
                     K=NEW TRIADR(GOTO,Res_W,RNULLW)
                  %finishelsestart
                     K=NEW TRIAD(K,Res_W,LABID,J)
                     %if LAST=I %thenstart;! set marker
                        TR==record(ADDR TRIAD(K))
                        TR_USE=1;! to indicate to OPT1 that this is the last triad of a block
                     %finish
{2900}               Res_FORM=NULL;! to avoid reloading acc
                  %finish
                  %if LABREC_LINE # 0 %thenstart;! BACKWARD JUMP
                     CHECK BACK LAB
                  %finishelsestart;! FORWARD REFERENCE
                     PTR=NEW LIST CELL(LABREC_LINK2,3)
                     SS==record(ADICT+PTR)
                     SS_INF0=K;! triad index
                     SS_INF2=COM_LINEST
                  %finish
               %finish
            %repeat
%end
         -> LABW
!*
PHI(16):
!***********************************************************************
!* ARITHOP WITH Resl AND OP FROM TREE, Resr=CURRENT OPERAND            *
!***********************************************************************
      P1=OS(IGEN)
      I = OUTPUT(KGEN+P1)
      IGEN=IGEN+1
      SS==record(ADICT+I)
      OP=SS_INF0
      Resl_W=SS_LINK1
      Resr_W = Res_W
      %if OP=1 %then ->L872;! to process concatenation
      FREE LIST CELL(I,2)
      -> L100
!*
PHI(17):
!***********************************************************************
!* IF UNARY - AT START OF EXPRESSION CALL ARITHOP                      *
!***********************************************************************
      %if OP=0 %or OP=10 %then ->L1;! + or none
      Resl_W = Res_W
      Resr_W = Res_W
      -> L100
!*
PHI(18):
!***********************************************************************
!* BEFORE PROCESSING STATEMENT AFTER LOGICAL IF                        *
!* SETS 'TRUE' ADDRESS BEFORE STATEMENT                                *
!* SAVE record WITH 'FALSE' ADDRESS IN LOGPTR                          *
!***********************************************************************
         NOTFLAG=NOTFLAG!!1
         CONDC(1);! PLANT JUMP IF FALSE
         FALSE JUMP=NEXT TRIAD-2
         STAT TYPE=1;! note logical if (for special case GOTO action)
         TRUE LAB=LLL_ORLAB
         SETCA(TRUE LAB);! FILL .TRUE. ADDRESSES
         LOGPTR=LLL_ANDLAB
         FREE LIST CELL(LOGLIST,5)
         LLL==record(ADICT+LOGLIST)
         RELOP=0
!{PA}     %if COM_PATHANAL#0 %then PATHCOUNT(COM_LINEST,1);! record SYMBOL 1
!{ITS}    %if COM_ITSMODE=2 %then COM_STATEMENT=0 %and ITSACT(2)
         ->L1
!*
PHI(19):

!***********************************************************************
!* FOLLOWING STATEMENT AFTER LOGICAL IF                                *
!* SETS 'FALSE' ADDRESS USING record SAVED IN LOGPTR                   *
!***********************************************************************
         SETCA(LOGPTR)
         COM_LABWARN=0
!!Z         FREE REGS
!{PA}     PATHREPORT=1
         ->L1
!*
PHI(21):

!***********************************************************************
!* AFTER .NOT.                                                         *
!* SETS NOTFLAG                                                        *
!* TIDIES UP AND/OR LISTS TO CORRECT BRACKET COUNT LEVEL               *
!***********************************************************************
         NOTFLAG=NOTFLAG!!1
!*
PHI(20):

!***********************************************************************
!* NOTE CURRENT OPERATOR CODE                                          *
!***********************************************************************
         !SETP1
         OP = OS(IGEN)
         IGEN=IGEN+1
         -> L1
!*
PHI(22):

!***********************************************************************
!* AFTER COMPARATOR (.EQ.,.NE.,.GT.,.GE.,.LT.,.LE.)                    *
!* SAVE CURRENT OPERAND DESCRIPTOR AND COMPARATOR CODE                 *
!***********************************************************************
      PTR=FREESP(2)
      SS==record(ADICT+PTR)
      SS_INF0=OUTPUT(KGEN+2);! COMPARATOR CODE
      SS_LINK1=Res_W
      RELOP=PTR
      -> L1
!*
PHI(23):

!***********************************************************************
!* AFTER .OR.                                                          *
!***********************************************************************
      ANDOR(0)
      -> L1
!*
PHI(24):

!***********************************************************************
!* AFTER .AND.                                                         *
!***********************************************************************
      ANDOR(1)
      -> L1
!*
PHI(25):
!***********************************************************************
!* COMPILES CODE AT END OF LOGICAL ASSIGNMENT OR LOGICAL               *
!* EXPRESSION AS PARAM                                                 *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      I=OUTPUT(KGEN+P1)
      -> L1 %if I = 0
      BC=I>>16
      %if RELOP#0 %or LLL_ANDLAB_W#0 %or LLL_ORLAB_W#0 %thenstart
         LOGTOACC(0)
         ->L252
      %finishelsestart
         %if NOTFLAG#0 %thenstart
            Res_H0=NEW TRIADR(NOT,Res_W,RNULLW)
            Res_FORM=TRIAD
L252:       OUTPUT(KGEN+P1+1)=Res_W
         %finish
      %finish
      NOTFLAG=LLL_NOTFLAG
      RELOP=LLL_RELOP
      FREE LIST CELL(LOGLIST,5)
      LLL==record(ADICT+LOGLIST)
      ->L1
!*
PHI(26):
!***********************************************************************
!* ACTION AT '(' FOR LOGICAL EXPRESSIONS                               *
!* PUSHES DOWN AND/OR LISTS                                            *
!* STORES BRACKET COUNT AND UPDATE IT                                  *
!***********************************************************************
         -> L1 %if BC = 0
L260:    BC = BC+1;! COMMON CODE FOR PI(34)
         PTR=NEW LIST CELL(LOGLIST,5)
         LLL==record(ADICT+LOGLIST)
         LLL_ORLAB_W=0
         LLL_ANDLAB_W=0
         LLL_NOTFLAG=NOTFLAG
         NOTFLAG=0
         LLL_RELOP=RELOP
         RELOP=0
         ->L1
!*
PHI(27):
!***********************************************************************
!* ACTION AT ')' IN LOGICAL EXPRESSIONS                                *
!* RESET BRACKET COUNT                                                 *
!* POPUP AND/OR LISTS IF NEITHER USED AND BC>1                         *
!***********************************************************************
         %if Res_FORM=TRIAD %thenstart
            I=TRIADS(Res_H0)_OP
            %UNLESS I=NEG %or I=MULT %or I=DIV %thenstart
               Res_W=Triad Res(Res_MODE,BRK,Res_W,RNULLW)
            %finish
         %finish
         -> L1 %if BC = 0
         BC = BC-1
         %if LLL_ORLAB_W=0 %and LLL_ANDLAB_W=0 %thenstart
            NOTFLAG=LLL_NOTFLAG!!NOTFLAG
         %finishelsestart
            LOGTOACC(LLL_NOTFLAG)
            NOTFLAG=0
         %finish
         %if RELOP=0 %then RELOP=LLL_RELOP
         FREE LIST CELL(LOGLIST,5)
         LLL==record(ADICT+LOGLIST)
         ->L1
!*
PHI(28):
!***********************************************************************
!* PLANT CODE FOR DO STATEMENT                                         *
!* FORM DO-LIST ENTRY                                                  *
!***********************************************************************
      I=5
L281: PTR=NEW LIST CELL(COM_DOPTR,10)
      DOREC==record(ADICT+PTR)
      DOREC_LABLIST=0
      DOREC_LINE=COM_LINEST
      Resl_W = OUTPUT(KGEN+I)
      %if Resl_W&X'7FFF'=0 %thenstart;! no label specified
         Dorec_Label=Resl_W;! includes nesting level
      %finishelsestart
         LABREC==record(ADICT+(Resl_W&X'7FFF')<<DSCALE);! LABEL record
         LABREC_X0=LABREC_X0!4;! MARK AS REFERENCED BY DO
         I=Resl_H0
         DOREC_LABEL=(Resl_W&X'FF000000')!LABREC_LAB;! DEPTH<<24!LABEL
      %finish
      %if P=94 %thenstart;! DO WHILE
         Dorec_Indexrd_W=0
         Dorec_Loopad_W=New Plab
         I=New Triad2(STMT,0,PLABID,Dorec_Loopad_H0,0)
         ->L340;! to prepare for logical expression
      %finishelsestart
         DOREC_INDEXRD_W =  OUTPUT(KGEN+4);! INDEX R.D.
         CHECK DO INDEX(DOREC_INDEXRD_W,DOREC_LINK1)
         DOREC_INCRD_W = OUTPUT(KGEN+1)
         DOREC_FINALRD_W = OUTPUT(KGEN+2)
         Resl_W = OUTPUT(KGEN+3);! INITIAL VALUE R.D.
         START OF DO LOOP(0)
!{PA}     PATHREPORT=1;! TO ENSURE FIRST STAT IN DO LOOP IS REPORTED
         -> L1
      %finish
!*
PHI(29):

!***********************************************************************
!* SET MARKER FOR STATEMENTS PERMITTED TO TERMINATE DO LOOP            *
!***********************************************************************
      DOTEST = 1
      -> L1
!*
PHI(30):
!***********************************************************************
!* COMPUTED GOTO                                                       *
!***********************************************************************
      Com_Inhibop4=1
      SPTR = OUTPUT(KGEN+2)
L300: I = NEW TRIAD(CGT,Res_W,NULL,SPTR>>DSCALE)
      %if Res_Mode>INT8 %then Lfault(131);! not an integer expression
      %WHILE SPTR#0 %cycle
         SS==record(ADICT+SPTR)
         SPTR=SS_LINK1
         LABREC==record(ADICT+SS_INF0)
         %if LABREC_LINE # 0 %thenstart;! backward jump
            CHECK BACK LAB
         %finishelsestart;! forward
            PTR=NEWLISTCELL(LABREC_LINK2,3)
            SS==record(ADICT+PTR)
            SS_INF0=I;! triad index
            SS_INF2=COM_LINEST
         %finish
      %repeat
      -> L1
!*
PHI(31):
!***********************************************************************
!* UNCONDITIONAL AND ASSIGNED GOTO                                     *
!***********************************************************************
      Res_W=OUTPUT(KGEN+1)
      %if Res_FORM=LABID %thenstart;! LABEL record
         LABREC==record(ADICT+Res_H0<<DSCALE)
         %if LABREC_LINE#0 %thenstart;! ALREADY DEFINED
            CHECK BACK LAB
         %finishelsestart;! FORWARD REFERENCE
            PTR=NEW LIST CELL(LABREC_LINK2,3);! CHAIN OF FORWARD REFS
            SS==record(ADICT+PTR)
            SS_INF0=NEXT TRIAD
            SS_INF2=COM_LINEST
         %finish
         %if STAT TYPE=1 %and COM_OPT#0 %thenstart;! logical if
            TR==record(ADDR TRIAD(FALSE JUMP))
            TR_OP=TR_OP!!1 ;! JIT <-> JIF
            TR_RES2=RES;! modify last condition to go to user label
            NEXT TRIAD=FALSE JUMP+1
            %if TRUE LAB_W#0 %thenstart
               %cycle I=STAT TRIAD,1,FALSE JUMP-1
                  TR==record(ADDR TRIAD(I))
                  %if TR_RES2_W=TRUE LAB_W %then TR_RES2=RES
               %repeat
            %finish
            %if LOGPTR_W#0 %thenstart;! check if private label for false is still needed
               PLAB==record(ADICT+LOGPTR_H0<<DSCALE)
               %if PLAB_USE<=1 %then LOGPTR=0
            %finish
            ->LABW
         %finish
      %finishelsestart;! ASSIGNED GOTO
         %if Res_MODE # 1 %then LFAULT(190);! check that this is correct error *************
      %finish
      I = NEW TRIAD(GOTO,Res_W,NULL,NULL)
LABW: COM_LABWARN = 1
         -> L1
!*
PHI(33):
!***********************************************************************
!* CALLED AFTER PHI32 TO PERFORM COMPUTED GOTO IF LABEL PARAMS         *
!***********************************************************************
      SPTR = OUTPUT(KGEN+1)
      -> L1 %if SPTR = 0;! no label params
      Res_W=0
      -> L300
!*
PHI(34):
!***********************************************************************
!* ABOUT TO COMPILE AN EXPRESSION WHICH MAY BE LOGICAL                 *
!* NO ACTION UNLESS THIS IS SO                                         *
!***********************************************************************
L340: P1=OS(IGEN)
      IGEN=IGEN+1
      I = OUTPUT(KGEN+P1)
      %if I = 0 %and BC = 0 %then -> L1;  ! NOTFLAG=0(NO LOGICAL COMPONENT)
      OUTPUT(KGEN+P1) = BC<<16!I;    ! NOW CONTAINS BC<<16!NOTFLAG
      BC = 0
      -> L260
!*
PHI(48):
!***********************************************************************
!* Call on parameterless function                                      *
!***********************************************************************
!*
PHI(35):
!***********************************************************************
!* START OF PROCESSING FN                                              *
!***********************************************************************
      FNREC==record(ADICT+NEW LIST CELL(COM_FNLST,4));! MAKE FN record AVAIL TO SETPARAM FOR INTRINS CHECK
      %if P=48 %then I=2 %ELSE I=OS(IGEN) %and IGEN=IGEN+1
      FNREC_FPTR=OUTPUT(KGEN+I);! dict record for function
      FNREC_HEAD=0
      FNREC_PCT=0
      -> L1 %UNLESS P=48
!*
PHI(36):
!***********************************************************************
!* AFTER  <IDEN> ( <PARAMLIST> )                                       *
!***********************************************************************
      PP==record(ADICT+FNREC_FPTR)
      %if PP_X0&3#0 %thenstart;! intrinsic function reference
         INTRINFN(FNREC_FPTR,FNREC_PCT,FNREC_HEAD)
         ->L36B;! to free FNLST entry
      %finish
      I=SETMODE(PP_TYPE&X'3F')
      %if I=LOG1 %then I=LOG4
!{2900} %if I=INT2 %then I=INT4
      Res_MODE=I
      I=FUN
L36A: Res_H0=FNREC_FPTR>>DSCALE
      Res_FORM=PROCID
      %if FNREC_HEAD#0 %thenstart
         Resr_W=Form Res(FNREC_HEAD,TRIAD,FNREC_PCT)
      %finishelse Resr=RNULL
      Res_H0=NEW TRIADR(I,Res_W,Resr_W)
      Res_FORM=TRIAD
      %if Com_Opt=4 %then I=Op4 Ref(string(Com_Anames+PP_Iden))
L36B: FREE LIST CELL(COM_FNLST,4)
      FNREC==record(ADICT+COM_FNLST)
      -> L1
!*
PHI(38):
!***********************************************************************
!* FOLLOWING EVALUATION OF PARAM TO EXTERNAL SUBPROG                   *
!* SET PARAM DESCRIPTOR ON STACK                                       *
!***********************************************************************
      I=KGEN+OS(IGEN)
      IGEN=IGEN+1
      LINK PARAM(FNREC_FPTR,OUTPUT(I+2))
      ->L1
!*
PHI(41):
!***********************************************************************
!* AFTER  CALL <IDEN>                                                  *
!***********************************************************************
      PP==record(ADICT+FNREC_FPTR)
      Res_MODE=NULL
      I=SUBR
      ->L36A
!*
PHI(44):
!***********************************************************************
!* RETURN I                                                            *
!***********************************************************************
      Com_Inhibop4=1
      %if COM_SUBPROGTYPE=1 %then ->L451
      Com_Vreturn=1
L440:
!{ITS} %if COM_ITSMODE#0 %then ITSACT(3);! REPORT RETURN
      OP = RET
      ->L452
!*
PHI(45):
!***********************************************************************
!* STOP                                                                *
!***********************************************************************
L451: Res_H0 = 0; Res_H1 = 0
L450:
!{ITS} %if COM_ITSMODE#0 %then ITSACT(4);! REPORT STOP 
      OP = STOP
L452: I = NEW TRIAD(OP,Res_W,NULL,NULL)
      -> LABW
!*
PHI(46):
!***********************************************************************
!* END                                                                 *
!***********************************************************************
      %if COM_SUBPROGTYPE=1 %thenstart
         OP=STOP
         I=4
      %finishelsestart
         OP=RET
         I=3
      %finish
!{ITS}  %if COM_ITSMODE#0 %then ITSACT(I)
      I=NEW TRIADR(OP,RNULLW,RNULLW)
      I=NEW TRIADR(EOT,RNULLW,RNULLW);! SUBPROGEND
      TR==record(ADDR TRIAD(I))
      TR_CHAIN=0
!*
      Cklab
!*
!****** Checklist processing (parameter arrays)
      %while Com_Checklist#0 %cycle
      SS==record(Adict+Com_Checklist)
         PP==record(Adict+SS_Inf0)
         %if PP_Class&X'60'=X'60' %thenstart
            Tfault(248,Com_Anames+PP_Iden,0)
         %finish
         Com_Checklist=SS_Link1
      %repeat
!*
      %if COM_F77PARM&X'02000000'#0 %then PRINT CHTRIADS
      %if COM_FNO=0 %and COM_SCANONLY=NO %thenstart
         %if COM_OPT#0 %and COM_SUBPROGTYPE#5 %thenstart          
            %if Com_Opt=4 %thenstart;! save all relevant info
               I=Op4 Save
               Com_Subprogtype=-1
               %result=1
            %finish
            OPTCTL(ACOM,NEXTTRIAD,32,COM_ASSGOTOS)                
            OBJ==record(COM_OBJADDR)                              
            %if OBJ_OPTFLAGS&32#0 %thenstart                      
               COM_HEADINGS=1                                     
               %if COM_TMINDEX=0 %then TMLIST=0                   
               OPTSOURCE(COM_ADICT,COM_ANAMES,COM_ATRIADS,   %    
                         COM_DESTEMPS,COM_ADOPTDATA,TMLIST)       
            %finish                                               
         %finish                                                  
         CODEGEN(3,TRIADS,ACOM);! GENERATE CODE
      %finishelsestart
         CODEGEN(4,TRIADS,ACOM)
         COM_SUBPROGTYPE=-1
      %finish
      %result=1
!*
PHI(47):

!***********************************************************************
!* RETURN                                                              *
!***********************************************************************
      %if COM_SUBPROGTYPE=1 %then ->L451
      Res_W=NULL
      ->L440
!*
PHI(49):
!***********************************************************************
!* AFTER REF TO MULTI-DIMENSIONAL ARRAY ELEMENT                        *
!***********************************************************************
      Resl_W=OUTPUT(KGEN+OS(IGEN))
      CHRES=Resl;! in case needed for substring checking
      IGEN=IGEN+1
      ARRAYREC==record(ADICT+Resl_H0<<DSCALE)
      DVREC==record(ADICT+ARRAYREC_ADDR4)
      PCT=DVREC_DIMS
      L=0
      ADJ=0
      %if ARRAYREC_CLASS&X'C0'=0 %thenstart;! not adjustable
         %cycle J=1,1,PCT
            RES=SUBSCRIPT(J)
            %if Res_MODE#INT4 %thenstart
               Res_W=Convert(Res_W,INT4)
               SUBSCRIPT(J)=RES
            %finish
            %if Res_FORM&CONSTMASK#0 %thenstart
               K=CONOUT(RES)
               %if COM_ARRAYCHECKS=FULL %thenstart
                  %UNLESS DVREC_B(J)_L<=K<=DVREC_B(J)_U %thenstart
                     TFAULT(232,COM_ANAMES+ARRAYREC_IDEN,0)
                  %finish
               %finish
            %finishelse L=1
         %repeat
      %finishelsestart
         L=1
         ADJ=1
      %finish
!*
!      %UNLESS COM_ARRAYCHECKS=FULL %and L=1 %and PCT>1 %thenstart;! ARRAYCHECKS#FULL or 1 subscript or all int
         %if PCT>1 %thenstart
            %cycle I=PCT,-1,2
               J=DVREC_B(I-1)_M
               %if J>0 %thenstart
                  Res_W=CONIN(J)
               %finishelsestart;! set R.D. to multiplier in DV
                  Res_W=Form Res(Dvrec_Addrdv+I<<2,GLALIT,INT4)
                  %if COM_OPT#0 %thenstart;! ensure multiplier info avail for optext
                     %if COM_TMINDEX=0 %then TMLIST=0
                     K=TMLIST
                     %WHILE K#0 %cycle
                        SS==record(ADICT+K)
                        %if SS_INF0=Res_W %then ->PHI49A;! entry already there
                        K=SS_LINK1
                     %repeat
                     SS==record(ADICT+NEWLISTCELL(TMLIST,3))
                     SS_INF0=Res_W
                     COM_TMINDEX=COM_TMINDEX+1
                     SS_INF2=(I<<16)!Resl_H0;! multiplier no., dict record(dscaled)
                  %finish
               %finish
PHI49A:        ARITHOP(SUBSCRIPT(I),MULT,RES)
               %UNLESS I=PCT %then ARITHOP(RES,ADD,SUBSCRIPT(I+1))
               SUBSCRIPT(I)=RES
            %repeat
            ARITHOP(RES,ADD,SUBSCRIPT(1))
         %finishelse RES=SUBSCRIPT(1)
!         %if COM_ARRAYCHECKS#NO %and L=1 %thenstart;! 1-dimensional check required
!            Res_W=Triad Res(Res_MODE,SUBS,RNULLW,Res_W)
!         %finishelsestart
            I=ARRAYREC_TYPE
            %if I=CHARTYPE %thenstart
               J=ARRAYREC_LEN
               %if J#0 %thenstart
                  Resr_W=CONIN(J)
               %finishelsestart
                  Resr=RNULL
                  Resr_MODE=INT4
                  Resr_W=Triad Res(INT4,LEN,Resr_W,Resl_W)
               %finish
               ARITHOP(RES,MULT,Resr)
            %finish
!         %finish
!      %finishelsestart;! full checks and non-const subscripts (or adj dims) and >1 subscript
!         RES=SUBSCRIPT(1)
!         Res_W=Triad Res(Res_FORM,SUBS,RNULLW,Res_W)
!         %cycle I=2,1,PCT
!            Res_W=Triad Res(SUBSCRIPT(I)_FORM,SUBS,Res_W,SUBSCRIPT(I)_W)
!         %repeat
!      %finish
      Res_W=Form Res(New Triadr(ARR,Resl_W,Res_W),ARREL,Resl_Mode)
      ->L1
!*
PHI(50):
!***********************************************************************
!* Start processing I/O statement                                      *
!* P1  (IOTYPE)  = 1  READ                                             *
!*                 2  WRITE,PRINT                                      *
!*                 3  REWIND                                           *
!*                 4  BACKSPACE                                        *
!*                 5  ENDFILE                                          *
!*                 6  OPEN                                             *
!*                 7  CLOSE                                            *
!*                 8  INQUIRE                                          *
!***********************************************************************
      Com_Inhibop4=1
      IOTYPE=OS(IGEN)
      IGEN=IGEN+1
      IOFORM=0
      IOMODE=0
      IOFLAGS=0
      %if IOTYPE<=2 %then IOMODE=X'60' %ELSESTART
         %if 3<=IOTYPE<=5 %then IOFORM=7  %C
                          %ELSE IOFORM=8
      %finish
!*
      %if IOTYPE>5 %and COM_JBRMODE#0 %then LFAULT(311);! not yet available
!*
      IOMODE=IOMODE!(1<<(IOTYPE-1));! Set sequential file as default, I/O type as spec
      IOFLAGS=IOFLAGS!(COM_CHARACTER CODE<<1);! set if EBCDIC
      %if COM_CONTROL&X'10000010'=0 %then IOFLAGS=IOFLAGS!4;! unassigned check
      IOFLAGS=IOFLAGS!8;! relaxing ANSI 
      IOCONTROLS=0;! bit significance to check multiple or conflicting control specs
      IOMASK=IOMASKS(IOTYPE)
      IODOINIT=0
      IODEPTH=0
      IOCURDIMS=0
      Res_W=NULL
      IOSTARTED=NEW TRIAD(STRTIO,Res_W,LIT,IOTYPE)
      IOINDEX=0
      ->L1
!*
PHI(51):
!***********************************************************************
!* PROCESS I/O LIST ITEM                                               *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      Res_W=OUTPUT(KGEN+P1)
      %if Res_W=0 %then ->L1;! controlled var
!* reject also if expression and input list *********************************
      %if IOTYPE=1 %and (Res_FORM=LIT %or Res_FORM=CNSTID) %thenstart
         LFAULT(298);! not valid in input list
         ->L1
      %finish
PHI51A:IOINDEX=IOINDEX+1
      %if IOTYPE=1 %thenstart
         %if Res_FORM=ARREL %then TRIADS(Res_H0)_OP=DEFARR
         I=DIOITEM
      %finishelse I=IOITEM
      I=NEW TRIAD(I,Res_W,LIT,IOINDEX)
      ->L1
!*
%integerfn CHECK DESC TO VAR(%record(RESF) RES,%integer MODE)
      %result=0
%end;! CHECK DESC TO VAR
!*
PHI(52):
!***********************************************************************
!* Process I/O specification clause                                    *
!***********************************************************************
      P1=OS(IGEN)
      P2=OS(IGEN+1)
      IGEN=IGEN+2
      Res_W=OUTPUT(KGEN+P2)
L520: %if P1<16 %thenstart
         %if P1=15 %then I=X'8000' %ELSE I=1<<P1
      %finishelsestart
         I=P1-16
         I=1<<I
         I=I<<16
      %finish
      %if IOCONTROLS&I#0 %then Call TFAULT(211,IOSPECS(P1),0);!repeated defn
      %if IOMASK&I=0 %then Call TFAULT(212,IOSPECS(P1),0);!incompatible specification
      IOCONTROLS=IOCONTROLS!I
      %if P1>6 %thenstart;! OPEN,CLOSE,INQUIRE
         %if IOTYPE=6 %then J=OPENPP(P1) %ELSESTART
            %if IOTYPE=7 %then J=CLOSEPP(P1) %ELSE J=INQUIREPP(P1)
         %finish
         %UNLESS IOTYPE=8 %then J=J!X'100'
         %if J&X'80'#0 %then I=4 %ELSESTART
            %if J&X'40'#0 %then I=5 %ELSE I=1
         %finish
         %if MODETOST(Res_MODE)&15#I %thenstart
            Call TFAULT(217,IOSPECS(P1),0);! invalid specifier
            ->L1
         %finish
L52B:    I=NEW TRIAD(IOSPEC,Res_W,P1,J)
         ->L1
      %finish
      J=0
      ->SW52(P1)
!*
SW52(1):! UNIT=
!*
      %if Res_W=0 %thenstart ;!default unit specified (table initialised for default)
         %if IOTYPE>2 %then Call TFAULT(223,IOTYPES(IOTYPE),0)
         ->L1
      %finish
!*
      %if Res_MODE=CHARMODE %or Res_FORM=ARRID %thenstart
         IOMODE=(IOMODE&X'0F')!X'50';! internal file
         %if Res_Form=PROCID %thenstart
            PP==record(Com_Adict+Res_H0<<DSCALE)
            PP_X1=PP_X1!2;! to ensure that fn unassigned is not reported
         %finish
!* check that it is not a concatenation or other expression ***********************
      %finishelsestart
         %UNLESS Res_MODE<=INT8 %thenstart
            LFAULT(213);!invalid unit or internal file specifier
            ->L1
         %finish
      %finish
      ->L52B
!*
SW52(2): ! FMT=
!*
      %if Res_W=0 %thenstart ;! list directed
         %if IOMODE&X'F0'=X'50' %then LFAULT(220);! invalid for internal file
         IOFORM = 3;! form = 3
         ->L1
      %finish
!*
      J=Res_FORM
!*
      %if J=LIT %thenstart;! format label
         K=Res_H0
L524:    IOFORM=1;! form = 1
         %UNLESS 0<K<=99999 %then IFAULT(110,K) %and ->L1;! invalid statement label
         I=SETLAB(K,PTR)
         LABREC==record(ADICT+PTR)
         %if I=0 %thenstart ;! already set or referenced
            I=LABREC_X0
            %UNLESS I=8 %or I=16 %then IFAULT(302,K) %and ->L1;! already used as a statement label
         %finish
         LABREC_X0=8
         Res_W=Form Res(PTR>>DSCALE,LABID,0)
         ->L52B
      %finish
!*
      %if LSCALID<=J<=CSCALID %thenstart ;! Scalar, must be assigned
         %if Res_MODE=CHARMODE %thenstart
            IOFORM=2
            ->L52B
         %finish
         IOFORM=1;! form=1
         %UNLESS Res_MODE<=INT8 %thenstart
L521:       LFAULT(214);! wrong type
            ->L1
         %finish
         ->L52B
      %finish
!*
      IOFORM=2;! form=2
!*
      %if J=ARRID %thenstart ;! special iden (must be character array)
         PP==record(ADICT+Res_H0<<DSCALE)
         %UNLESS PP_TYPE=5 %then LFAULT(191);! non-char array is non-standard
         ->L52B
      %finish
!*
      %if Res_MODE=CHARMODE %then ->L52B
!*
      %if J=CNSTID %thenstart
         CON==record(ADICT+Res_H0<<DSCALE)
         %if CON_MODE=INT4 %thenstart
            K=INTEGER(ADICT+CON_DADDR)
            ->L524
         %finish
         %if CON_MODE=INT8 %thenstart;! possible if I8 default chosen
            K=INTEGER(ADICT+CON_DADDR+4)
            ->L524
         %finish
      %finish
!*
      ->L521;! else error
!*
SW52(3):   ! REC=
!*
      IOMODE=IOMODE!X'70';! iotype=7 (over-riding default 6)
      %UNLESS Res_MODE<=INT8 %then LFAULT(216) %and ->L1
      ->L52B
!*
SW52(4):   ! END =
!*
SW52(5): ! ERR=
!*
      J=Res_H0
      %UNLESS Res_FORM=0 %and 0<J %thenstart
         %if Res_FORM=1 %thenstart;! INT IN DICT
            %if Res_MODE<=2 %thenstart;! INT4 or INT8
               J=INTEGER(ADICT+J<<DSCALE+4*(Res_MODE-1))
            %finish
            %if 0<J<=99999 %then ->SW525A
         %finish
         Call TFAULT(224,IOSPECS(P1),0)
         ->L1
      %finish
SW525A:I=SETLAB(J,PTR)
      LABREC==record(ADICT+PTR)
      %if LABREC_X0&8#0 %thenstart
         IFAULT(228,LABREC_LINE);! already used as format label
      %finishelsestart
         %if LABREC_X0&1#0 %thenstart
            IFAULT(225,J) ;! refers to a non-exec statement
         %finishelsestart
            LABREC_X1=LABREC_X1!4;! label in I/O statement
            %if  LABREC_LINE#0 %thenstart ;! already defined
               CHECK BACK LAB
            %finish
            Res_w=Form Res(PTR>>DSCALE,LABID,0)
            J=0
            ->L52B
         %finish
      %finish
      ->L1
!*
SW52(6): ! IOSTAT=
!*
      %unless Res_Mode=INT4 %then LFAULT(226) %and ->L1
      ->L52B
!*
!*
PHI(53):
!***********************************************************************
!* End of I/O statement processing                                     *
!***********************************************************************
      %if IOTYPE=8 %thenstart;! INQUIRE
         %if IOCONTROLS&X'82'=0 %then LFAULT(313);! UNIT or FILE required
         %if IOCONTROLS&X'82'=X'82' %then LFAULT(314);! not both
      %finish
       %if 6<=IOTYPE<=7 %thenstart;! OPEN,CLOSE
         %UNLESS IOCONTROLS&2#0 %then LFAULT(315);! UNIT required
      %finish
      Res_FORM=LIT
      Res_MODE=INT4
      Res_H0=IOMODE
      I=NEW TRIAD(ENDIO,Res_W,LIT,IOFLAGS)
      TRIADS(IOSTARTED)_QOPD1=LIT
      TRIADS(IOSTARTED)_OPD1=IOFORM;! to enable correct i/o proc to be called
      DOTEST=1;! allow I/O statements to terminate DO
      ->L1
!*
PHI(54):
!***********************************************************************
!* Process auxiliary I/O statment information clause                   *
!***********************************************************************
      I=OS(IGEN)
      P1=OUTPUT(KGEN+I+1);! control item
      Res_W=OUTPUT(KGEN+I);! expression descriptor
      IGEN=IGEN+1
      ->L520
!*
PHI(55):
!***********************************************************************
!* P1 = 0  start of implied-DO loop processing (in I/O list)           *
!*      1  end of loop processing                                      *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
!*
      IOINDEX=IOINDEX+1
      Res_FORM=P1
      Res_H0=IOINDEX
      I=NEW TRIAD(IODO,Res_W,NULL,NULL);! to ensure this is kept within the coroutine
!*
      %if P1=0 %thenstart;! start
         PTR=NEW LIST CELL(COM_DOPTR,10)
         DOREC==record(ADICT+PTR)
         DOREC_INDEXRD_W=OUTPUT(KGEN+5);! index
         %if DOREC_INDEXRD_MODE=INT2 %thenstart;! I*2 NOT ALLOWED
            LFAULT(190)
            %result=0
         %finish
         CHECK DO INDEX(I,DOREC_LINK1)
         DOREC_INCRD_W=OUTPUT(KGEN+2)
         DOREC_FINALRD_W=OUTPUT(KGEN+3)
         Resl_W=OUTPUT(KGEN+4);! initial
         DOREC_LABEL=0
         START OF DO LOOP(1)
      %finishelsestart;! end
         END DO SUB(COM_DOPTR,1)
         FREE LIST CELL(COM_DOPTR,10)
      %finish
      ->L1
!*
PHI(56):
!***********************************************************************
!* Expression or array element in I/O list                             *
!* P1 locates RES in tree                                              *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      Res_W=OUTPUT(KGEN+P1)
      %if Res_FORM=TRIAD %and IOTYPE=1 %thenstart;! look for expression in input list
         TR==record(ADDR TRIAD(Res_H0))
         I=TR_OP
         %if I#ARR %and I#ARR1 %and I#CHAR %thenstart
            LFAULT(298)
            ->L1
         %finish
      %finish
      ->PHI51A
!*
PHI(57):
!***********************************************************************
!*  Ensure that I/O related expressions are computed in the co-routine *
!***********************************************************************
      I=NEW TRIADR(IODO,RNULLW,RNULLW)
      ->L1
!*
PHI(60):
!***********************************************************************
!* COMPILES INITIAL CODE ON ENTRY TO A STATEMENT FUNCTION              *
!* SETS RESULT DESCRIPTOR                                              *
!***********************************************************************
!      COM_FAST PROLOGUE=NO
      P1=OS(IGEN)
      IGEN=IGEN+1
      CUR STATFN=OUTPUT(KGEN+P1)
      STATFN == record(ADICT+CUR STATFN)
      Res_W=STATFN_LINK2
      -> L1
!*
PHI(61):
!***********************************************************************
!* AFTER COMPILATION OF AN ASSIGNMENT TAKE FURTHER ACTION IF           *
!* IT WAS A STATEMENT FUNCTION                                         *
!* COMPILES RETURN                                                     *
!* CLEARS LIST OF PARAMETERS(SFPTR)                                    *
!* LINKS SHORTENED FORM OF PARAMETER LIST TO STATEMENT FN record       *
!* UPDATES START OF CODE ADDRESS FOR MAIN ENTRY                        *
!***********************************************************************
       -> L1 %if COM_SFMK = 0
      COM_SFMK = 0
      SPTR=0
      %if COM_SFPTR#0 %thenstart
         %WHILE COM_SFPTR#0 %cycle
            PP==record(ADICT+COM_SFPTR)
            PTR=NEW LIST CELL(SPTR,3)
            SS==record(ADICT+PTR)
            RES=RNULL
            Res_MODE=SETMODE(PP_TYPE&X'3F')
            Res_H0=PP_LEN;! in case char
            SS_INF0=Res_W
            FREE LIST CELL(COM_SFPTR,8)
         %repeat
      %finish
      STATFN==record(ADICT+CUR STATFN)
      STATFN_Link3=SPTR>>DSCALE
      Res_W=Form Res(Cur Statfn>>DSCALE,STFNID,Setmode(Statfn_Type&X'3F'))
      %if Statfn_Type=CHARTYPE %thenstart;! allow assignment to temp
         I=NEXT TRIAD-1
         TRIADS(I)_RES1_W=RES_W
         I=New Triadr(ENDSF,RNULLW,Res_W)
      %finish
      I=NEXT TRIAD-1
      TRIADS(I)_OP=ENDSF
      TRIADS(I)_RES1=RES
      STATFN_ADDR4=STFNSTART+1
      TRIADS(STFNSTART)_CHAIN=NEXT TRIAD
!{PA}     PATHREPORT=1;! ENSURE REPORTING OF FIRST ACTUAL PROG STATEMENT
         -> L1
!*
PHI(62):
!***********************************************************************
!* COMPILE CALL ON STATEMENT FUNCTION                                  *
!***********************************************************************
      I=OUTPUT(KGEN+2)
      STATFN==record(ADICT+I)
      Res_W=INSERT STFN
      -> L1
!*
PHI(66):
!***********************************************************************
!* AFTER <U>**<F>                                                      *
!***********************************************************************
      Resl_W=OUTPUT(KGEN+2)
      Resr_W=OUTPUT(KGEN+1)
      %if Resl_MODE=CHARMODE %or Resr_MODE=CHARMODE %thenstart
         LFAULT(132)
         %result=0
      %finish
      ARITHOP(Resl,8,Resr)
      -> L1
!*
PHI(68):
!***********************************************************************
!* STOP <INT>                                                          *
!***********************************************************************
      Res_W = OUTPUT(KGEN+1)
      ->L450
!*
PHI(69):
!***********************************************************************
!* PAUSE <INT>  OR  PAUSE ' <TEXT> '                                   *
!***********************************************************************
      Res_W = OUTPUT(KGEN+1)
L691: I=New Triad(PAUSE,Res_W,NULL,NULL)
      ->L1
!*
PHI(70):
!***********************************************************************
!* PAUSE                                                               *
!***********************************************************************
      Res_W = 0
      ->L691
!*
PHI(72):
!***********************************************************************
!* Coerce subscripts to I*4 if necessary                               *
!* Note R.D. for subscript in SUBSCRIPT array                          *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      Res_W=OUTPUT(KGEN+P1);! evaluated subscript
      SUBSCRIPT(OUTPUT(KGEN+P1-1))_W=SIMPLE INT(Res_W)
      ->L1
!*
PHI(73):
!***********************************************************************
!* SET FORMAT PARAM (SYSTEM4 ONLY)                                     *
!***********************************************************************
         IGEN=IGEN+1
         ->L1
!*
PHI(74):
!***********************************************************************
!* Extract R.D.s for lower and upper substring expressions             *
!***********************************************************************
      Resl_W=SIMPLE INT(OUTPUT(KGEN+2))
      Resr_W=SIMPLE INT(OUTPUT(KGEN+1))
      COM_RESCOM1=Resl_W
      CHResl=Resl_W
      COM_RESCOM2=Resr_W
      CHResr=Resr_W
      ->L1
!*
PHI(75):
!***********************************************************************
!* Obtain descriptor to substring                                      *
!***********************************************************************
      COM_INP=OUTPUT(KGEN+1)
      Resl_W=CHResl
      Resr_W=CHResr;! in case either corrupted by PHI(49) when processing array el
      PP==record(ADICT+CHRes_H0<<DSCALE)
      I=PP_LEN
      %if Resl_FORM=LIT %thenstart
         %UNLESS 1<=Resl_H0 %thenstart
PHI75A:     TFAULT(257,COM_ANAMES+PP_IDEN,0);! invalid substring value
            ->L1
         %finish
         %if Resr_FORM=LIT %thenstart
            %UNLESS Resl_H0<=Resr_H0 %then ->PHI75A;! lower > upper
            %if I#0 %and I<Resr_H0 %then ->PHI75A;! upper > max
         %finish
      %finish
      %if Resl_MODE#INT4 %then Resl_W=Convert(Resl_W,INT4)
      %if Resr_MODE#INT4 %then Resr_W=Convert(Resr_W,INT4)
      Resr_W=Triad Res(CHARMODE,SUBSTR,Resl_W,Resr_W)
      Res_W=Triad Res(CHARMODE,CHAR,Res_W,Resr_W)
      ->L1
!*
PHI(77):
!***********************************************************************
!* Constant operation with Resl and OP from tree, Resr = RES           *
!***********************************************************************
      I=KGEN+OS(IGEN)
      IGEN=IGEN+1
      OP=OUTPUT(I+1)
PHI77A:Resl_W=OUTPUT(I)
PHI77B:CONST EVAL(Resl_W,OP,Res_W,RES,COM_ADICT,COM_DPTR)
      ->L1
!*
PHI(78):
!***********************************************************************
!* Constant operation with Resl only from tree                         *
!***********************************************************************
      I=KGEN+OS(IGEN)
      IGEN=IGEN+1
      ->PHI77A
!*
PHI(79):
!***********************************************************************
!* Unary operation on constant                                         *
!***********************************************************************
      %if OP=0 %then ->L1;! + or nothing
      Resl_W=0
      Resr_W=Res_W
      ->PHI77B
!*
PHI(80):
!***********************************************************************
!* Save current RES and OP                                             *
!***********************************************************************
      I=KGEN+OS(IGEN)
      IGEN=IGEN+1
      OUTPUT(I)=Res_W
      OUTPUT(I+1)=OP
      ->L1
!*
!*
PHI(81):
!***********************************************************************
!* Assign constant expression value to constant name, checking         *
!* compatability                                                       *
!* OUTPUT(P1)   = INP value (in case of error to be reported)          *
!* OUTPUT(P1+1) = RES for constant expression                          *
!* OUTPUT(P1+2) = DICT @ of constant name record                       *
!***********************************************************************
      I=KGEN+OS(IGEN)
      IGEN=IGEN+1
      PP==record(ADICT+OUTPUT(I+2));! constant name record
      J=PP_TYPE
      K=SETMODE(J&X'3F')
      %if J=X'54' %then K=LOG4;! not given correctly by SETMODE
      Res_W=OUTPUT(I+1);! constant form of RES
      L=Res_Mode&15
      %if K=L %thenstart
         %if K=CHARMODE %thenstart
            I=PP_LEN;! name length
            J=Res_H0<<DSCALE;! dict @ of const
            K=INTEGER(ADICT+J);! length of const
            %if I#K %thenstart
               %if I=0 %thenstart;! (*) specification
                  PP_LEN=K
               %finishelsestart
                  L=Dictspace((I+7)&X'FFFC')
                  INTEGER(ADICT+L)=I
                  %if I<K %thenstart
                     COPY(I,ADICT+J,4,ADICT+L,4)
                  %finishelsestart
                     FILL(I,ADICT+L,4,COM_SPACECHAR)
                     COPY(K,ADICT+J,4,ADICT+L,4)
                  %finish
                  Res_H0=L>>DSCALE; Res_H1=X'100'!CHARMODE
               %finish
            %finish
         %finish
         PP_CONSTRES=Res_W
L811:    
         %if com_target=ICL2900 %thenstart
            %if COM_ITSMODE#0 %thenstart;! ALLOCATE CONST TO CONSTAREA (FOR POSSIBLE ITS USE)
               %if Res_W&X'F00'=0 %thenstart;! simple int
                  %if Res_W<0 %then Res_W=(Res_W>>16)!X'FFFF0000'  %C
                            %ELSE Res_W=Res_W>>16
                  L=4
                  I=ADDR(Res_W)
               %finishelsestart
                  I=Res_H0<<DSCALE;! DICT DISPACEMENT OF CONST
                  %if L=10 %thenstart;! CHAR
                     L=INTEGER(ADICT+I)
                     I=ADICT+I+4
                  %finishelsestart
                     L=MODETOBYTES(K)
                     I=ADICT+I
                  %finish
               %finish
   !!V            J=NEWCONST(L,I,K);! LENGTH, @ ,MODE
   !!V            PP_ADDR4=CONSTADDR(J)
            %finish
         %finish
         ->L1
      %finish
      %if 1<=K<=8 %and 1<=L<=8 %thenstart;! compatible arithmetic modes
         %if Res_FORM=0 %thenstart
            I=Res_H0
            %if I&X'8000'#0 %then I=I!X'FFFF0000'
            INTEGER(ADICT)=I;! integer value for coertion
            I=0
         %finishelse I=Res_H0<<DSCALE
         Res_H0=COERCE CONST(I,L,K,ADICT,COM_DPTR)>>DSCALE
         Res_Form=1; Res_Mode=K
         PP_CONSTRES=Res_W
         ->L811
      %finishelsestart;! error
         COM_INP=OUTPUT(I)
         FAULT(278);! const expression of the wrong type
      %finish
      ->L1
!*
PHI(82):
!***********************************************************************
!* Set CEXMODE to indicate type of expression being evaluated          *
!* = 0  any const expression                                           *
!*   1  int const expression                                           *
!*   2  DATA-implied D0 subscript                                      *
!*   3  dimension bound expression                                     *
!***********************************************************************
      CEXMODE=OS(IGEN)
      IGEN=IGEN+1
      ->L1
!*
PHI(84):
!***********************************************************************
!* Block IF, ELSEIF, ELSE of ENDIF statement                           *
!* P1 = 0  IF(...)THEN                                                 *
!*      1  ELSEIF(...)THEN                                             *
!*      2  ELSE                                                        *
!*      3  ENDIF                                                       *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      COM_LABWARN=0
!{PA}  PATHREPORT=1
!*
!!L      FREEREGS
      IFREC==record(ADICT+COM_IFPTR)
!*
      %if P1>0  %thenstart;! ELSEIF, ELSE, ENDIF - note label enclosures
         I=COM_LINEST
         %if P1=3 %then I=I-1;! ENDIF stat is not part of enclosure
         PTR=IFREC_LABLIST
         %WHILE PTR#0 %cycle
            SS==record(ADICT+PTR)
            LABREC==record(ADICT+SS_INF0);! label record
            LABREC_IFEND=I;! complete IF-block enclosure
            FREE LIST CELL(PTR,2)
         %repeat
         %if COM_DOPTR#0 %thenstart
            DOREC==record(ADICT+COM_DOPTR)
            I=IFREC_LINE
            %if IFREC_TYPE=0 %then I=I-1
            %if DOREC_LINE>I %then LFAULT(234)
         %finish
      %finish
!*
      %if 1<=P1<=2 %thenstart;! ELSEIF, ELSE - fill in jumps
         Ifrec_Endiflab_W=New Plab
         I=NEW TRIADR(GOTO,IFREC_ENDIFLAB_W,RNULLW);! goto ENDIF
         SETCA(IFREC_FALSELAB);! will define a private label if required
         IFREC_FALSELAB_W=0
!!! line number update needed here to give correct lineno for soft errors
      %finish
!*
      %if P1<3 %thenstart;! IF, ELSEIF, ELSE
         PTR=NEWLISTCELL(COM_IFPTR,6)
         IFREC==record(ADICT+PTR)
         IFREC_TYPE=P1
         IFREC_ENDIFLAB_W=0;! in case IF
         IFREC_FALSELAB_W=0;! in case ELSE
         IFREC_LABLIST=0
         I=COM_LINEST
         %if P1=0 %then I=I+1;! IF stat is not part of enclosure
         IFREC_LINE=I;! for start of label enclosures
      %finishelsestart
         %WHILE COM_IFPTR#0 %cycle
            IFREC==record(ADICT+COM_IFPTR)
            SETCA(IFREC_ENDIFLAB)
            SETCA(IFREC_FALSELAB)
            FREE LIST CELL(COM_IFPTR,6)
            %if IFREC_TYPE=0 %then %EXIT
         %repeat
      %finish
      ->L1
!*
PHI(85):
!***********************************************************************
!* After IF(...)THEN, ELSEIF                                           *
!* Fill in the jumps etc.                                              *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1;! note P1 not used, but available if required
      NOTFLAG=NOTFLAG!!1
      CONDC(1)
      SETCA(LLL_ORLAB);! fill true addresses
      LOGPTR=LLL_ANDLAB
      FREE LIST CELL(LOGLIST,5)
      LLL==record(ADICT+LOGLIST)
      IFREC==record(ADICT+COM_IFPTR)
      IFREC_FALSELAB=LOGPTR
      ->L1
!*
PHI(86):
!***********************************************************************
!* ELSEIF statment                                                     *
!* Check that the expression is logical and go to common code          *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      I=OUTPUT(KGEN+P1)
      %if I=0 %and BC=0 %thenstart;! not logical
         LFAULT(192);! expression must be logical
      %finish
      OUTPUT(KGEN+P1)=BC<<16!I
      BC=0
      ->L260
!*
PHI(87):
!***********************************************************************
!* process a character item which is being concatenated                *
!* check that RES is of type character                                 *
!* force RES to form 15                                                *
!* P1=0 first on chain                                                 *
!*  >0 link RES record to chain at node P1                             *
!* RES describes head of chain                                         *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      OP=1
L872: %if Res_W=0 %then ->L1;! after bracketed expression
      %if Res_MODE#CHARMODE %thenstart
         LFAULT(132);! invalid combination
         CONCATLIST=0
         ->L1
      %finish
!*
      PTR=FREESP(2)
      SS==record(ADICT+PTR)
      SS_INF0=Res_W
      SS_LINK1=CONCATLIST
      CONCATLIST=PTR
      Res_W=0;! to avoid repeated entries after bracketed expressions
!*
      ->L1
!*
PHI(88):
!***********************************************************************
!* after EQV or NEQV                                                   *
!***********************************************************************
      LOGTOACC(0)
      OUTPUT(KGEN+2)=Res_W
      ->L1
!*
PHI(89):
!***********************************************************************
!* after RHS of EQV or NEQV                                            *
!***********************************************************************
      P1=OS(IGEN)
      IGEN=IGEN+1
      LOGTOACC(0)
      %if P1=0 %then I=EQUIV %ELSE I=NEQ
      Resr_W=OUTPUT(KGEN+2)
      Res_W=Triad Res(LOG4,I,Res_W,Resr_W)
      ->L1
!*
PHI(90):
!***********************************************************************
!*  Start of processing array subscript                                *
!***********************************************************************
      Res_W=0
      %if COM_OPT=NO %then I=NEW TRIADR(BOP,Res_W,Res_W)
      ->L1
!*
PHI(91):
!***********************************************************************
!* Prior to <EX>                                                       *
!***********************************************************************
      PTR=FREESP(2)
      SS==record(ADICT+PTR)
      SS_INF0=CONCATLIST
      SS_LINK1=SAVECONCATS
      SAVECONCATS=PTR
      CONCATLIST=0
      ->L1
!*
PHI(92):
!***********************************************************************
!* After <EX> generate triads for concat if necessary                  *
!***********************************************************************
      %if CONCATLIST#0 %thenstart
         Resl_W=NULL
         %WHILE CONCATLIST#0 %cycle
            SS==record(ADICT+CONCATLIST)
            Resr_W=SS_INF0
            CONCATLIST=SS_LINK1
            %if CONCATLIST=0 %then I=CHHEAD %ELSE I=CONCAT
            Resl_W=Triad Res(CHARMODE,I,Resl_W,Resr_W)
         %repeat
         RES=Resl
      %finish
      %if SAVECONCATS#0 %thenstart
         SS==record(ADICT+SAVECONCATS)
         CONCATLIST=SS_INF0
         FREELISTCELL(SAVECONCATS,2)
      %finish
      ->L1
!*
PHI(93):
!***********************************************************************
!* Resl is actual arg in stat fn call corresponding to formal arg Resr *
!***********************************************************************
      Resl_W=OUTPUT(KGEN+OS(IGEN+1))
      Resr_W=OUTPUT(KGEN+OS(IGEN+2))
      IGEN=IGEN+3
      SS==record(Adict+Resr_W)
      Resr_W=SS_INF0
      %UNLESS Resl_MODE=Resr_MODE %then Resl_W=Convert(Resl_W,Resr_MODE)
      SS_INF2=Resl_W
      ->L1
!*
PHI(94):
!***********************************************************************
!* prior to logical expression in DO WHILE                             *
!***********************************************************************
      I=3
      ->L281
!*
PHI(95):
!***********************************************************************
!* after logical expression in DO WHILE                                *
!***********************************************************************
      NOTFLAG=NOTFLAG!!1
      CONDC(1)
      SETCA(LLL_ORLAB);! fill true addresses
      DOREC_ENDREF=LLL_ANDLAB
      FREE LIST CELL(LOGLIST,5)
      LLL==record(ADICT+LOGLIST)
      ->L1
!*
PHI(96):
!***********************************************************************
!* after END DO                                                        *
!***********************************************************************
      END OF DO LOOP(1)
      Dotest=1;! allow to terminate labelled DO
      ->L1
!*
%integerfn Insert Stfn
%integerfnspec Stfn Check(%record(Resf) R)
%record(SRECF)%name SS
%record(TRIADF)%name TT
%record(RESF) RES1,RES2
%integer I,J,DIF,NUMPLABS
%integerARRAY ARGS(0:255),PLABS(0:65),REPPLABS(0:63)
      %cycle I=0,1,63
         PLABS(I)=0
      %repeat
      NUMPLABS=0
      I=STATFN_LINK3<<DSCALE
      J=0
      %WHILE I#0 %cycle
         SS==record(ADICT+I)
         J=J+1
         RES1_W=SS_INF2
         %if RES1_FORM=TRIAD %or Res1_Form=ARREL %thenstart
            %UNLESS RES1_MODE=CHARMODE %or  %C
                       CMPLX8<=RES1_MODE<=CMPLX32 %thenstart
               NEW TEMP(RES2,RES1_MODE,1)
               RES2_FORM=PERMID
               I=NEW TRIADR(ASMT,RES2_W,RES1_W)
               RES1=RES2
            %finish
         %finish
         ARGS(J)=RES1_W
         I=SS_LINK1
      %repeat
      I=STATFN_ADDR4;! first triad of st fn
      DIF=NEXT TRIAD-I
      TT==record(ADDR(TRIADS(I)))
      %WHILE TT_OP#ENDSF %cycle
         RES1_W=STFN CHECK(TT_RES1)
         RES2_W=STFN CHECK(TT_RES2)
         %if TT_OP=STMT %thenstart
            J=NEW TRIAD2(STMT,TT_SLN,RES2_FORM,RES2_H0,TT_VAL2)
         %finishelsestart
            J=NEW TRIADR(TT_OP,RES1_W,RES2_W)
         %finish
         I=I+1
         TT==record(ADDR(TRIADS(I)))
      %repeat
      %result=STFN CHECK(TT_RES2)
!*
%integerfn Stfn Check(%record(RESF) R)
%integer I
      %if R_FORM=VALTEMP %thenstart;! arg
         %result=ARGS(R_H0)
      %finish
      %if R_FORM=PLABID %thenstart
         %if NUMPLABS#0 %thenstart
            %cycle I=1,1,NUMPLABS
               %if PLABS(I)=R_W %then %result=REPPLABS(I)                       
            %repeat
         %finish
         NUMPLABS=NUMPLABS+1
         PLABS(NUMPLABS)=R_W
         R_W=New Plab
         REPPLABS(NUMPLABS)=R_W
         %result=R_W
      %finish
      %if R_FORM&TEXTMASK#0 %thenstart
         R_H0=R_H0+DIF
      %finish
      %result=R_W
%end;! STFN CHECK
!*
%end;! INSERT STFN
!*
!*
%routine INTRINFN(%integer FNPTR,PCT,PLINK)
!***********************************************************************
!* check intrinsic fn calls have correct number of actual args         *
!* generate explicit triads for in-line fns                            *
!***********************************************************************
%ROUTINESPEC NEXTARG
%constbyteintegerarray Bitspars(0:13)= 0,
   2, 2, 2, 1, 2, 3, 2, 2, 2, 2, 2, 2, 2
%record(RESF) Resl
%record(TRIADF)%name TR
%record(PRECF)%name FN
%integer FNDETAILS,FNGROUP,INDEX,FMODE,PMODE,OP
%switch F(0:28)
!*
      FN==record(ADICT+FNPTR)
      FNDETAILS=FN_LINK2
      INDEX=FNDETAILS>>24
      FNGROUP=FN_X0&3
      FMODE=(FNDETAILS>>16)&X'F'
      PMODE=(FNDETAILS>>20)&X'F'
!*
      %if PCT=0 %thenstart
ERR:     LFAULT(139);! wrong number of params
         RES=RNULL
         %return
      %finish
!*
      %if FNGROUP=1 %thenstart;! calls on standard library fns
TYPE1:   %UNLESS PCT=FNDETAILS&3 %then ->ERR
         Resl_MODE=FMODE
         Resl_FORM=PROCID
         Resl_H0=FNPTR>>DSCALE
         Res_W=Form Res(PLINK,TRIAD,PMODE)
         Res_W=Triad Res(FMODE,IFUN,Resl_W,Res_W)
         %WHILE PLINK#0 %cycle
            TR==record(ADDR(TRIADS(PLINK)))
            TR_OP=ARG;! use only (was DARG)
            PLINK=TR_OPD2
         %repeat
         %return
      %finish
!*
      %if Index>X'C0' %thenstart;! special intrinsics
         %if Pct#Bitspars(Index-X'C0') %then ->Err
         Res_W=Triad Res(Fmode,INTRIN,Form Res(Index-X'C0',LIT,Fmode), %c
                                      Form Res(Plink,TRIAD,0))
         %return
      %finish
!*
      INDEX=INDEX&X'7F'
      TR==record(ADDR(TRIADS(PLINK)))
      TR_OP=NULL
      RES=TR_RES1
      NEXT TRIAD = NEXT TRIAD - 1;! the last (arg) triad is to be replaced
      Resl=RNULL
      Resl_MODE=FMODE
      ->F(INDEX)
!*
F(1):    {INT  IFIX  IDINT}
!*
F(3):    {REAL  FLOAT  SNGL}
!*
F(4):    {DBLE}
      %UNLESS PCT=1 %then ->ERR
      %if PMODE>=CMPLX8 %thenstart
         PMODE=PMODE-3;! complex to corresponding real
         Resl_MODE=PMODE
         Res_W=Triad Res(PMODE,REALL,Resl_W,Res_W)
      %finish
      %if FMODE=PMODE %then %RETURN
      Resl_MODE=FMODE
      Op=CVT
Setr: Res_W=Triad Res(FMODE,Op,Resl_W,Res_W)
      %RETURN
!*
F(6):    {CMPLX}
      %if PCT>2 %then ->ERR
      %if PCT=1 %thenstart
         %if FMODE=PMODE %then %RETURN
      %finishelsestart
         NEXTARG
         Resl=RES;! real part
         RES=TR_RES1;! complex part
      %finish
      %if Fmode=CMPLX16 %then Op=DCMPLX %else Op=CMPLX
      ->Setr
!*
F(9):    {AINT  DINT}
      OP=AINT
SET1: %UNLESS PCT=1 %then ->ERR
      ->Setr
!*
F(10):      {ANINT  DNINT}
      OP=ANINT
      ->SET1
!*
F(11):      {NINT  IDNINT}
      OP=NINT
      ->SET1
!*
F(12):      {ABS  IABS  CABS  DABS}
      %if PMODE>=CMPLX8 %thenstart
         FMODE=PMODE-3;! real result
         FN_LINK2=(FNDETAILS<<8)>>8!(20<<24);! to call standard fn
         FN_TYPE=FN_TYPE&X'F2';! real result of corresponding size
         Fn_X0=(Fn_X0&X'FC')!1
         Next Triad=Next Triad+1
         ->TYPE1;! to generate triad for standard fn call
      %finish
      OP=ABS
      ->SET1
!*
F(13):      {MOD  AMOD  DMOD}
      OP=MOD
SET2: %UNLESS PCT=2 %then ->ERR
      NEXTARG
      Res_W=Triad Res(FMODE,OP,Res_W,TR_RES1_W)
      %RETURN
!*
F(14):      {SIGN  ISIGN  DSIGN}
      OP=SIGN
      ->SET2
!*
F(15):      {DIM  IDIM  DDIM}
      OP=DIM
      ->SET2
!*
F(16):      {DPROD}
      OP=DMULT
      FMODE=PMODE+1;! to allow for I8=... as well as R8=... after optimisation
      ->SET2
!*
F(17):      {MAX  MAX0  AMAX1  DMAX1}
!*
F(18):      {AMAX0}
!*
F(19):      {MAX1}
      OP=MAX
SET3: %UNLESS PCT>1 %then ->ERR
      PCT=PCT-1
      %WHILE PCT>0 %cycle
         PCT=PCT-1
         NEXTARG
         Res_W=Triad Res(Pmode,Op,Res_W,Tr_Res1_W)
      %repeat
      %if FMODE=PMODE %then %RETURN
      Op=CVT
      ->Setr
!*
F(20):      {MIN  MIN0  AMIN1  DMIN1}
!*
F(21):      {AMIN0}
!*
F(22):      {MIN1}
      OP=MIN
      ->SET3
!*
F(7):    {ICHAR}
      OP=ICHAR
      ->SET1
!*
F(8):       {CHAR}
      %UNLESS Res_MODE=INT4 %then Res_W=Convert(Res_W,INT4)
      OP=TOCHAR
      ->SET1
!*
F(23):      {LEN}
      OP=LEN
      ->SET1
!*
F(24):      {INDEX}
      OP=CHIND
      ->SET2
!*
F(25):      {IMAG}
      OP=IMAG
      ->SET1
!*
F(26):      {CONJG}
      OP=CONJG
      ->SET1
!*
%routine NEXTARG
%record(TRIADF)%name T1
%integer INDEX,LINK,LAST
      INDEX=TR_OPD2
      TR==record(ADDR(TRIADS(INDEX)))
      TR_OP=NULL
      LINK=TR_CHAIN
      LAST=INDEX-1
      %WHILE LAST>0 %cycle
         T1==record(ADDR(TRIADS(LAST)))
         %if T1_CHAIN=INDEX %thenstart
            T1_CHAIN=LINK
            %RETURN
         %finish
         LAST=LAST-1
      %repeat
%end;! NEXTARG
!*
%end;! INTRINFN
!*
%integerfn DELBRK(%integer OP,%record(RESF) R)
%record(TRIADF)%name TR,TT
      %UNLESS R_FORM=TRIAD %then %result=R_W
      TR==record(ADDR(TRIADS(R_H0)))
      %UNLESS TR_OP=BRK %then %result=R_W
      %if OP>3 %or TR_QOPD1#TRIAD %thenstart;! definitely redundant
OUT:     TR_OP=NULL
         %result=TR_RES1_W
      %finish
      TT==record(ADDR(TRIADS(TR_OPD1)))
      %if TT_OP>3 %then ->OUT
      %result=R_W;! brackets needed after all
%end;! DELBRK
!*
%routine MOD LHS OP(%record(RESF) RES,%integer MODE)
!***********************************************************************
!* If optimising and arg or target of assignment is a character        *
!* substring or an array element then modify CHAR or ARR triad to      *
!* DCHAR or DARR respectively to indicate this                         *
!***********************************************************************
%record(TRIADF)%name TR
%integer FORM,INDEX
      MODE=0;! argarr gets us into all sorts of trouble
      FORM=Res_FORM
      INDEX=Res_H0
      %if FORM=CHAREL %thenstart
         TR==record(ADDR TRIAD(INDEX))
         TR_OP=DCHAR
         FORM=TR_QOPD1
         INDEX=TR_OPD1
      %finish
!*
      %if FORM=ARREL %thenstart
         TR==record(ADDR TRIAD(INDEX))
         %if MODE=0 %then TR_OP=DARR %ELSE TR_OP=ARGARR
      %finish
%end;! MOD LHS OP
!*
%routine CHECK PMODE(%integer PTR,MODE)
%integer I,J,K,L,ST
%CONSTBYTEINTEGERARRAY GENMASK(0:8)=1,1,1,2,2,2,4,4,4
%record(PRECF)%name PP
      ST=MODETOST(MODE)
      PP==record(ADICT+PTR)
      I=PP_LINK2;! FN DETAILS
      J=I>>8&X'FF';! PARAMETER SIZE/TYPE
      %if com_target=ICL2900 %thenstart
         K=I>>16&X'FF'
         %if K&X'88'=0 %and J=0 %thenstart;! no CHARACTER involved
            %if COM_OPTIONS1&10#0 %thenstart    ;!MAKE GENERIC
               J=K>>4;! PARAMETER MODE
               %if J>0 %then L=X'10'
               %if J>2 %then L=X'20'
               %if J>5 %then L=X'40'
               %if J#0 %then I=I!L
               J=0
               K=K&X'F'
               L=K
               %if (K=1 %and COM_OPTIONS1&2#0) %or   %C
                  ((K=3 %or K=6) %and COM_OPTIONS1&8#0) %thenstart
                  L=K+1
                  PP_TYPE=PP_TYPE+X'10';! MODIFY RESULT TYPE
               %finish
               I=(I&X'FF00FFFF')!L<<16
            %finish
         %finish
      %finish
      %if J=0 %thenstart;! PARAMETER MODE NOT SET (GENERIC)
         K=I>>4&15;! GENERIC RANGE
         %if MODE<=CMPLX32 %thenstart
            %if K&GENMASK(MODE)#0 %thenstart;! VALID GENERIC TYPE
               I=I!MODE<<20!ST<<8
               %if I>>16&X'F'=0 %thenstart;! FN MODE NOT SET
                  I=I!MODE<<16
                  PP_TYPE=ST
               %finish
               PP_LINK2=I
               %RETURN
            %finish
         %finish
ERR:     LFAULT(143)
      %finishelsestart
         %if J#ST %thenstart
          %UNLESS J=X'51' %and MODE<=INT4 %then ->ERR
         %finish
      %finish
      %RETURN
%end;! CHECK PMODE
!*
%routine LINK PARAM(%integer FPTR,R)
%record(RESF) RES
%record(PRECF)%name PP
%integer FORM,VAL
      Res_W=R
      VAL=FNREC_HEAD
      %if VAL#0 %thenstart
         FORM=TRIAD
      %finishelse FORM=NULL
      FNREC_HEAD=NEW TRIAD(DARG,Res_W,FORM,VAL)
      %if COM_OPT#0 %then MOD LHS OP(RES,1)
      FNREC_PCT=FNREC_PCT+1
      PP==record(ADICT+FPTR)
      %if PP_X0&7#0 %then CHECK PMODE(FPTR,Res_MODE)
%end;! LINK PARAM
!*
%integerfn Convert(%integer Resw,Newmode)
%record(RESF) R
%record(RESF) RL
%record(CONSTRECF)%name CON
%integer AD
!*
      Rl_W=Resw
      %if RL_W=0 %then %result=0;! for special use of RES (e.g. as char substring)
      %if RL_FORM&CONSTMASK#0 %and NEWMODE<CMPLX8 %thenstart
         AD=0
         %if RL_FORM=LIT %thenstart
            %if NEWMODE=INT2 %then Rl_MODE=INT2 %and %result=Rl_W
            INTEGER(ADICT)=RL_H0
            AD=0
         %finishelsestart
            %if RL_FORM=NEGLIT %thenstart
               %if NEWMODE=INT2 %then Rl_MODE=INT2 %and %result=Rl_W
               INTEGER(ADICT)=-RL_H0
               AD=0
            %finishelsestart
               CON==record(ADICT+RL_H0<<DSCALE)
               AD=CON_DADDR
            %finish
         %finish
         R_W=Form Res(Coerce Const(Ad,Rl_Mode,Newmode,Adict,Com_Dptr)>>DSCALE,
                      1,Newmode)
         %result=Form Res(Setconrec(R)>>DSCALE,CNSTID,Newmode)
      %finishelsestart
         R=RNULL
         R_MODE=NEWMODE
         %result=Triad Res(NEWMODE,CVT,R_W,Resw)
      %finish
%end;! Convert
!*
%routine ARITHOP(%record(RESF) Resl,%integer OP,%record(RESF) Resr)
!***********************************************************************
!* Resl,Resr  RESULT DESCRIPTORS FOR LEFT AND RIGHT OPERANDS WHERE REL.*
!* OP  1  COMPARE                                                      *
!*     2  +                                                            *
!*     3  -                                                            *
!*     4  *                                                            *
!*     5  /                                                            *
!*     6  UNARY -                                                      *
!*     7  ASSIGN (LEFT OPERAND TO RIGHT OPERAND LOCATION               *
!*     8  **                                                           *
!* OPERATION MODE IS MAX(OPERAND MODES)                                *
!***********************************************************************
!*
%integer LF, LA, LMODE, RF, RA, RMODE, OPMODE
%integer I
!*
!{2900}%CONSTBYTEINTEGERARRAY SETOPMODE(0:80)= %C
!{2900}X'01',X'01',X'02',X'03',X'04',X'05',X'53',X'54',X'55',
!{2900}X'01',X'01',X'02',X'03',X'04',X'05',X'53',X'54',X'55',
!{2900}X'02',X'02',X'02',X'04',X'04',X'05',X'54',X'54',X'55',
!{2900}X'03',X'03',X'04',X'03',X'04',X'05',X'63',X'64',X'65',
!{2900}X'04',X'04',X'04',X'04',X'04',X'05',X'64',X'64',X'65',
!{2900}X'05',X'05',X'05',X'05',X'05',X'05',X'65',X'65',X'65',
!{2900}X'13',X'13',X'14',X'23',X'24',X'25',X'33',X'34',X'35',
!{2900}X'14',X'14',X'14',X'24',X'24',X'25',X'34',X'34',X'35',
!{2900}X'15',X'15',X'15',X'25',X'25',X'25',X'35',X'35',X'35'
!{2900}!*
!{2900}%CONSTBYTEINTEGERARRAY CHANGEMODE(0:15) =  %C
!{2900}   0,1,2,3,4,5,6,7,8,1,0,0,0,1,2,0
!*
{PERQ}%CONSTBYTEINTEGERARRAY SETOPMODE(0:80)= %C
{PERQ}X'00',X'01',X'02',X'03',X'04',X'05',X'53',X'54',X'55',
{PERQ}X'01',X'01',X'02',X'03',X'04',X'05',X'53',X'54',X'55',
{PERQ}X'02',X'02',X'02',X'04',X'04',X'05',X'54',X'54',X'55',
{PERQ}X'03',X'03',X'04',X'03',X'04',X'05',X'63',X'64',X'65',
{PERQ}X'04',X'04',X'04',X'04',X'04',X'05',X'64',X'64',X'65',
{PERQ}X'05',X'05',X'05',X'05',X'05',X'05',X'65',X'65',X'65',
{PERQ}X'13',X'13',X'14',X'23',X'24',X'25',X'33',X'34',X'35',
{PERQ}X'14',X'14',X'14',X'24',X'24',X'25',X'34',X'34',X'35',
{PERQ}X'15',X'15',X'15',X'25',X'25',X'25',X'35',X'35',X'35'
{PERQ}!*
{PERQ}%CONSTBYTEINTEGERARRAY CHANGEMODE(0:15) =  %C
{PERQ}   0,1,2,3,4,5,6,7,8,0,0,0,0,0,0,0
!*
%CONSTBYTEINTEGERARRAY TRIADOP(0:5)= 0, 0, ADD, SUB, MULT, DIV
!*
%switch SW(6 : 8)
%switch CSW(6:8)
!*
!******  EXPAND RESULT DESRIPTOR FOR RHS OPERAND
         %if 1<OP<6 %thenstart
            Resl_W=DELBRK(OP,Resl)
            Resr_W=DELBRK(OP,Resr)
         %finish
         RA = Resr_H0
         RMODE = Resr_MODE
         RF = Resr_FORM
!******  FOR DIADIC OPERATORS EXPAND RESULT DESC FOR LEFT OPERAND
         LA = Resl_H0
         LMODE = Resl_MODE
         LF = Resl_FORM
!*
         LMODE=CHANGEMODE(LMODE)
         RMODE=CHANGEMODE(RMODE)
         OPMODE = SETOPMODE(LMODE*9+RMODE)
         %if OPMODE>15 %thenstart;! SOME COMPLEX ITEM
            OPMODE=OPMODE&15+3
            %if OP<=5 %thenstart
               Res_W=NULL
               %if LMODE#OPMODE %and LMODE#OPMODE-3 %thenstart
                  %if LMODE<CMPLX8 %thenstart
                     Res_MODE=OPMODE-3
                  %finishelsestart
                     Res_MODE=OPMODE
                  %finish
                  Resl_W=Triad Res(Res_MODE,CVT,Res_W,Resl_W)
               %finish
               %if RMODE#OPMODE %and RMODE#OPMODE-3 %thenstart
                  %if RMODE<CMPLX8 %thenstart
                     Res_MODE=OPMODE-3
                  %finishelsestart
                     Res_MODE=OPMODE
                  %finish
                  Resr_W=Triad Res(Res_MODE,CVT,Res_W,Resr_W)
               %finish
               ->SETRES
            %finishelse ->CSW(OP)
         %finish
!*
         %if OP > 5 %then -> SW(OP)
!*
      %if LF&CONSTMASK#0 %and RF&CONSTMASK#0  %C
                         %and LMODE!RMODE<=INT8 %thenstart
         %if GCONVAL(CONOUT(Resl),OP,CONOUT(Resr),I)=0 %thenstart
RESINT:     Res_W=CONIN(I)
            %if LMODE!RMODE=INT4 %then %RETURN
            %if Res_FORM#CNSTID %thenstart;! if I8 and >16 bits comput at run time
               Res_MODE=INT8
               %RETURN
            %finish
         %finish
      %finish
!*
         Res_FORM=NULL
         Res_MODE=OPMODE
         %if LMODE#OPMODE %then Resl_W=Convert(Resl_W,OPMODE)
         %if RMODE#OPMODE %then Resr_W=Convert(Resr_W,OPMODE)
         Resl_MODE=OPMODE
SETRES:  Res_W=Triad Res(OPMODE,TRIADOP(OP),Resl_W,Resr_W)
         %RETURN
!*
SW(6):   ! UNARY -
         Resr_W=DELBRK(OP,Resr)
         %if RF=LIT %thenstart
            I=-RA
            ->RESINT
         %finish
         %if RMODE=INT2 %thenstart
            Resl_FORM=NULL
            Resl_MODE=INT4
            Resr_W=Triad Res(INT4,CVT,Resl_W,Resr_W)
            RMODE=INT4
         %finish
CSW(6):  Res_H0=NEW TRIAD(NEG,Resr_W,NULL,NULL)
         Res_Form=TRIAD; Res_Mode=RMODE
         %RETURN
!*
SW(7):   ! ASSIGN LHS TO RHS
!* could perform const conversions here
!{PERQ}  %if RMODE=INT2 %and (LF=LIT %or LF=NEGLIT)  %C
!{PERQ}                               %then Resl_MODE=INT2
         %if RMODE#LMODE %thenstart
            Resl_W=Convert(Resl_W,RMODE)
            LMODE=RMODE
         %finish
CSW(7):  %if RMODE=LMODE %then I=ASMT %ELSE I=CVT
         I=NEW TRIADR(I,Resr_W,Resl_W)
         %if COM_OPT#0 %then MOD LHS OP(Resr,0)
         %RETURN
!*
SW(8):!**
         %if RMODE>5 %or LMODE>5 %thenstart
            LFAULT(134)
            Res_W=NULL
            %RETURN
         %finish
CSW(8):  %if Resr_MODE>INT4 %and Resr_MODE#OPMODE %thenstart
            Res_W=NULL
            Res_MODE=OPMODE
            Resr_W=Triad Res(OPMODE,CVT,Res_W,Resr_W)
         %finish
         %if Resl_MODE#OPMODE %thenstart
            Res_W=NULL
            Res_MODE=OPMODE
            Resl_W=Triad Res(OPMODE,CVT,Res_W,Resl_W)
         %finish
         Resl_MODE=OPMODE
         Res_W=Triad Res(OPMODE,EXP,Resl_W,Resr_W)
         %RETURN
!*
%end;                                   ! ARITHOP
!*
%routine SETCA(%record(RESF) R)
!***********************************************************************
!* define private label for conditional branches                       *
!***********************************************************************
%integer I
      %if R_W#0 %thenstart
         I=NEW TRIAD2(STMT,NULL,PLABID,R_H0,0)
      %finish
%end;! SETCA
!*
%integerfn SIMPLE INT(%integer R)
!***********************************************************************
!* Ensure that any integer expressions requiring DR are loaded and     *
!* that the result is a simple integer value                           *
!***********************************************************************
%record(RESF) RES
      %if R=0 %then %result=0
      Res_W=R
      %if Res_MODE#INT4 %thenstart
         Res_W=Convert(Res_W,INT4)
         %result=Res_W
      %finishelse %result=R
      %result=R
%end;! SIMPLE INT
!*
%routine CHECK BACK LAB
%integer I,Er
      %if Com_Allowvax=NO %then Er=205 %else Er=330;! error else warning
      I=LABREC_DOSTART
      %if I#0 %thenstart
         %UNLESS I<=COM_LINEST<=LABREC_DOEND %then  %C
                                IFAULT(Er,LABREC_LINE)
      %finish
      I=LABREC_IFSTART
      %if I#0 %thenstart
         %UNLESS I<=COM_LINEST<=LABREC_IFEND %then  %C
                             IFAULT(203,LABREC_LINE)
      %finish
%end;! CHECK BACK LAB
!*
%routine CONDC(%integer LLIST)
!***********************************************************************
!* COMPILE TESTS IN LOGICAL EXPRESSIONS
!* COMPILE LOAD AND TEST AND BC FOR LOGICAL VARS
!* IF RELOP # 0 COMPARE AND BRANCH
!***********************************************************************
%CONSTBYTEINTEGERARRAY COMPOPS(0:12) =  %C
   0,0,GT,0,LT,0,NE,0,EQ,0,GE,0,LE
%integer I,JUMPOP,CONDMASK,OPMODE
%record(RESF) R,PLABREC
%record(PLABF)%name PLAB
%record(SRECF)%name SSS
      %if LLIST=0 %thenstart
         PLABREC=LLL_ORLAB
      %finishelse PLABREC=LLL_ANDLAB
      %if PLABREC_W=0 %thenstart
         Plabrec_W=New Plab
         %if LLIST=0 %thenstart
            LLL_ORLAB=PLABREC
         %finishelse LLL_ANDLAB=PLABREC
      %finish
      PLAB==record(ADICT+PLABREC_H0<<DSCALE)
      PLAB_USE=PLAB_USE+1
      %if RELOP#0 %thenstart;! COMPARISON TO BE PERFORMED
         SSS==record(ADICT+RELOP)
         CONDMASK=SSS_INF0
         Resl_W=SSS_LINK1
         OPMODE=Resl_MODE
         %if OPMODE<Res_MODE %then OPMODE=Res_MODE
         R_W=NULL
         R_MODE=OPMODE
         %if Resl_MODE#OPMODE %thenstart
            %if OPMODE=CHARMODE %then LFAULT(132)
            Resl_W=Triad Res(OPMODE,CVT,R_W,Resl_W)
         %finish
         %if Res_MODE#OPMODE %thenstart
            %if OPMODE=CHARMODE %then LFAULT(132)
            Res_W=Triad Res(OPMODE,CVT,R_W,Res_W)
         %finish
         Res_W=Triad Res(Res_Mode,Compops(Condmask),Resl_W,Res_W);! keeping Res_MODE=char/non-char as indicator
      %finish
      %if NOTFLAG=0 %then JUMPOP=JIT %ELSE JUMPOP=JIF
      I=NEW TRIADR(JUMPOP,Res_W,PLABREC_W)
      I=NEW TRIAD2(STMT,NULL,NULL,NULL,3);! start of block
      NOTFLAG=0
      RELOP=0
%end;! CONDC
!*
%routine LOGTOACC(%integer NOTFL)
%record(RESF) Resl
%integer I,J
      %if RELOP=0 %and LLL_ANDLAB_W=0 %and LLL_ORLAB_W=0 %then %RETURN
      CONDC(0);! PLANTS JUMP IF TRUE
      SETCA(LLL_ANDLAB);! FILLS .AND. ADDRESSES
      LLL_ANDLAB_W=0
      %if NOTFL =0 %then I=0 %ELSE I=1
      NEW TEMP(RES,LOG4,2)
      Res_FORM=PERMID
      Resl_W=Form Res(I,LIT,LOG4)
      J=NEW TRIADR(ASMT,Res_W,Resl_W)
       Resr_W=New Plab
      J=NEW TRIADR(GOTO,Resr_W,RNULLW)
      SETCA(LLL_ORLAB);! FILL .TRUE. ADDRESSES
      LLL_ORLAB_W=0
      Resl_H0=I!!1
      J=NEW TRIADR(ASMT,Res_W,Resl_W)
      J=NEW TRIAD2(STMT,NULL,PLABID,Resr_H0,0)
%end;! LOGTOACC
!*
%routine ANDOR(%integer P1)
!***********************************************************************
!* COMPILE CODE FOR .AND. OR .OR. CONDITION AND SET UP AND/OR LISTS    *
!* P1 = 0  .OR.                                                        *
!*      1  .AND.                                                       *
!***********************************************************************
         NOTFLAG=NOTFLAG!!P1
         CONDC(P1)
         %if P1=0 %thenstart
            SETCA(LLL_ANDLAB)
            LLL_ANDLAB_W=0
         %finish
%end;! ANDOR
!*
%routine START OF DO LOOP(%integer PAR)
%integer M,IMODE,OP
%record(RESF) R
      %if DOREC_INDEXRD_MODE=INT4 %then M=0 %ELSE M=X'800000';! can use BREG
      %UNLESS DOREC_INCRD_MODE=INT4 %and DOREC_FINALRD_MODE=INT4  %C
         %and Resl_MODE=INT4 %and DOREC_INCRD_FORM=LIT  %C
         %and DOREC_FINALRD_FORM#NEGLIT %and Resl_FORM#NEGLIT  %C
                                        %then M=M!X'400000';! if 0 then all simpl int consts
      DOREC_LABEL=DOREC_LABEL!M;! for end of loop processing
      %if DOREC_INCRD_FORM=LIT %and DOREC_INCRD_H0=0 %thenstart;! zero increment
         LFAULT(295)
         DOREC_INCRD_H0=1
      %finish
      %if M=0 %thenstart;! simple case
         %if DOREC_FINALRD_FORM # LIT %thenstart;! final is not simple int const
            NEW TEMP(Resr,INT4,2)
            Resr_FORM=PERMID
            I = NEW TRIADR(ASMT,Resr_W,DOREC_FINALRD_W)
            DOREC_FINALRD=Resr
         %finish
         %if COM_OPT#0 %thenstart
            %UNLESS Resl_MODE=INT4 %then Resl_W=Convert(Resl_W,INT4)
            OP=ASMT
         %finishelse OP=STOD1
         I = NEW TRIADR(OP,DOREC_INDEXRD_W,Resl_W);! index, initial
         %if Com_F77parm&X'800'=0 %thenstart;! do zero trip test
            %unless Resl_FORM=LIT   %C
                       %and DOREC_FINALRD_FORM=LIT %thenstart;! unless both initial and final are const
               Dorec_Endref_W=New Plab
               %if COM_OPT=0 %thenstart
                  I=NEW TRIADR(STOD2,DOREC_FINALRD_W,DOREC_ENDREF_W)
               %finishelsestart
                  R_W=Triad Res(INT4,GT,DOREC_INDEXRD_W,DOREC_FINALRD_W)
                  I=NEW TRIADR(JIT,R_W,DOREC_ENDREF_W)
               %finish
            %finishelsestart;! compile-time decision
               %if DOREC_FINALRD_H0<Resl_H0 %thenstart;! zero trip
                  Dorec_Endref_W=New Plab
                  I = NEW TRIADR(GOTO,DOREC_ENDREF_W,RNULLW)
               %finishelse DOREC_ENDREF_W=0
            %finish
         %finishelse DOREC_ENDREF_W=0
         I = NEW TRIAD2(STMT,0,0,0,3);! to ensure a back target block
         Dorec_Loopad_W=New Plab
         I = NEW TRIAD2(STMT,NULL,PLABID,DOREC_LOOPAD_H0,0)
         %RETURN
      %finish
!*
      IMODE=DOREC_INDEXRD_MODE
      %if Resl_MODE#IMODE %then Resl_W=Convert(Resl_W,IMODE)
      I = NEW TRIADR(ASMT,DOREC_INDEXRD_W,Resl_W);! index=initial
      %if DOREC_INCRD_FORM#LIT %or DOREC_INCRD_H0#1  %C
                %or IMODE#INT4 %thenstart;! unless default int 1 and int required
         K=1
         NEW TEMP(Resr,IMODE,2)
         Resr_FORM=PERMID
         %UNLESS DOREC_INCRD_MODE=IMODE %then  %c
                     Dorec_Incrd_W=Convert(DOREC_INCRD_W,IMODE)
         I = NEW TRIADR(ASMT,Resr_W,DOREC_INCRD_W)
         DOREC_INCRD=Resr
      %finishelse K=0
!*
      %if DOREC_FINALRD_MODE#IMODE %thenstart
         R_W=NULL
         R_MODE=IMODE
         Dorec_Finalrd_W=Triad Res(IMODE,CVT,R_W,DOREC_FINALRD_W)
      %finish
      R_W=Triad Res(IMODE,SUB,DOREC_FINALRD_W,DOREC_INDEXRD_W)
      NEW TEMP(Resr,INT4,1)
      Resr_FORM=PERMID
      DOREC_ICRD=Resr
      %if K=0 %thenstart
         R_H0 = NEW TRIADR(ADD,R_W,FORM RES(1,LIT,INT4))
      %finishelsestart
         R_H0=NEW TRIADR(ADD,R_W,DOREC_INCRD_W)
         R_H0=NEW TRIADR(DIV,R_W,DOREC_INCRD_W)
      %finish
      %if R_MODE#Resr_MODE %then R_W=Convert(R_W,Resr_MODE)
      I = NEW TRIADR(ASMT,Resr_W,R_W)
      Dorec_Endref_W=New Plab
      I=NEW TRIADR(JINP,Resr_W,DOREC_ENDREF_W)
      TR==record(ADDR TRIAD(I))
      TR_USE=1;! to indicate last in block  (for OP1)
      I = NEW TRIAD2(STMT,0,0,0,3);! to ensure a back target block
      Dorec_Loopad_W=New Plab
      I = NEW TRIAD2(STMT,NULL,PLABID,DOREC_LOOPAD_H0,0)
%end;! START OF DO LOOP

!*
%routine END DO SUB(%integer DOPTR,PAR)
%integer I
%record(DORECF)%name DOREC
%record(RESF) R
      DOREC==record(ADICT+DOPTR)
      %if Dorec_Indexrd_W=0 %thenstart;! DO WHILE
         I=New Triadr(GOTO,Dorec_Loopad_W,RNULLW)
         Setca(Dorec_Endref)
         %return
      %finish
      %if DOREC_LABEL&X'C00000'#0 %thenstart;! not all int consts
         R_W=Triad Res(DOREC_INDEXRD_MODE,ADD,DOREC_INDEXRD_W,DOREC_INCRD_W)
         I = NEW TRIADR(ASMT,DOREC_INDEXRD_W,R_W)
         R_W=Form Res(1,LIT,INT4)
         R_W=Triad Res(INT4,SUB,DOREC_ICRD_W,R_W)
         I=NEW TRIADR(ASMT,DOREC_ICRD_W,R_W);! count=count-1
         I=NEW TRIADR(JIP,DOREC_ICRD_W,DOREC_LOOPAD_W)
         TR==record(ADDR TRIAD(I))
         TR_USE=1;! to indicate last in block
         I=NEW TRIAD2(STMT,NULL,NULL,NULL,3);! new block
      %finishelsestart;! all int consts
         %if COM_OPT=0 %thenstart
            I = NEW TRIADR(EOD1,DOREC_INDEXRD_W,DOREC_INCRD_W)
            I = NEW TRIADR(EOD2,DOREC_FINALRD_W,DOREC_LOOPAD_W)
         %finishelsestart
            R_W=Triad Res(INT4,ADD,DOREC_INDEXRD_W,DOREC_INCRD_W)
            I=NEW TRIADR(ASMT,DOREC_INDEXRD_W,R_W)
            R_W=Triad Res(INT4,GE,DOREC_FINALRD_W,DOREC_INDEXRD_W)
            I=NEW TRIADR(JIT,R_W,DOREC_LOOPAD_W)
            I=NEW TRIAD2(STMT,NULL,NULL,NULL,3)
         %finish
      %finish
      Setca(Dorec_Endref)
%end;! END DO SUB
!*
%routine END OF DO LOOP(%integer Mode)
!***********************************************************************
!* Mode = 0                                                            *
!*  THE LABEL ON THE CURRENT STATEMENT HAS BEEN SPECIFIED IN A DO STAT *
!*      = 1                                                            *
!*  END DO statement                                                   *
!***********************************************************************
%integer J,L,PTR
%record(DORECF)%name DOREC
%record(SRECF)%name SS
%record(IFRECF)%name IFREC
%record(LABRECF)%name LABREC
      %if Mode=0 %and DOTEST = 0 %thenstart
         LFAULT(294);! ILLEGAL STATEMENT TERMINATING DO
      %finish
      DOTEST = 0
!{PA}  J=0;! FOR PATH ANALYSIS
      %cycle
         DOREC == record(ADICT+COM_DOPTR)
         %if DOREC_INDEXRD_W&X'FF000000'#X'FF000000' %thenstart;! valid record
            L=Dorec_Label&X'FFFFF'
            %if Mode=1 %and (L#0 %and L=COM_LAB) %then %return;! dont process ENDDO
            %if Mode=1 %or (L#0 %and L=COM_LAB) %thenstart
                                         ! N.B. DO DEPTH IS IN TOP BYTE
               Mode=0;! to process only one loop for ENDDO
!{PA}           %if J#0 %and COM_PATHANAL#0 %then PATHCOUNT(COM_LINEST,J)
!{PA}            J=J+1
               %if COM_IFPTR#0 %thenstart
                  IFREC==record(ADICT+COM_IFPTR)
                  %if IFREC_LINE>DOREC_LINE %then LFAULT(234)
               %finish
               END DO SUB(COM_DOPTR,0)
!{PA}           PATHREPORT=1
            %finishelseEXIT;! FROM CYCLE
         %finish
         PTR=DOREC_LABLIST
         %WHILE PTR#0 %cycle
            SS==record(ADICT+PTR)
            LABREC==record(ADICT+SS_INF0);! label record
            LABREC_DOEND=COM_LINEST;! complete DO enclosure
            FREE LIST CELL(PTR,2)
         %repeat
         FREE LIST CELL(COM_DOPTR,10)
         %if COM_DOPTR = 0 %thenRETURN
      %repeat
!*
      I = COM_DOPTR
      %WHILE I # 0 %cycle
         DOREC == record(ADICT+I)
         %if DOREC_LABEL&X'FFFFF'=COM_LAB  %and Com_Lab#0 %thenstart
            LFAULT(148);                  ! ILLEGAL STATEMENT TERMINATING DO, OR WRONGLY N ESTED DO
            DOREC_INDEXRD_W = X'FF000000'
         %finish
         I = DOREC_LINK1
      %repeat
      PATHREPORT=1;! ENSURE NEXT STAT IS REPORTED WHEN PA IN USE
%end;                                   ! END OF DO LOOP
!*
!*
%integerfn New Plab
!***********************************************************************
!* Provide a new dict record for a private label                       *
!***********************************************************************
%integer I
      I=Dict Space(PLABRECSIZE)
      PLAB==record(ADICT+I)
      PLAB_BLKIND=0
      PLAB_USE=0
      PLAB_X1=1;! referenced in explicit GOTO
      PLAB_INDEX=COM_NEXT PLAB
      COM_NEXT PLAB=COM_NEXT PLAB+1
      %result=Form Res(I>>DSCALE,PLABID,0)
%end;! New Plab
!*
!{PA} %routine PATHCOUNT(%integer LINE,INDEX)
!{PA} %integer I
!{PA}     I = NEW TRIAD2(PA,LINE,NULL,NULL,INDEX)
!{PA} %end;! PATHCOUNT
!*
!{ITS} %routine ITSACT(%integer ENTRY)
!{ITS} %integer I
!{ITS}    I = NEW TRIAD2(ITS,ENTRY,NULL,NULL,NULL)
!{ITS} %end;! ITSACT
!*
%end;! GENERATE
!*
!*
%endoffile