!* modified 17/10/84
!*
%constinteger DSCALE=2
!*
!%include "bits_consts"
!*
!********************* TRIAD qualifiers ********************************
!*
%CONSTINTEGER NULL    = 0
%CONSTINTEGER LABID   = 1
%CONSTINTEGER PLABID  = 2
%CONSTINTEGER PROCID  = 3
%CONSTINTEGER STKLIT  = 4
%CONSTINTEGER GLALIT  = 5
%CONSTINTEGER SRTEMP  = 6
%CONSTINTEGER BREG    = 7
%CONSTINTEGER VALTEMP = 8
%CONSTINTEGER DESTEMP = 9
%CONSTINTEGER LSCALID =16
%CONSTINTEGER OSCALID =17
%CONSTINTEGER CSCALID =18
%CONSTINTEGER ASCALID =19
%CONSTINTEGER PSCALID =20
%CONSTINTEGER ARRID   =21
%CONSTINTEGER TMPID   =22
%CONSTINTEGER PERMID  =23
%CONSTINTEGER STFNID  =24
%CONSTINTEGER ITMPID  =22
%CONSTINTEGER RTMPID  =22
%CONSTINTEGER ETMPID  =22
%CONSTINTEGER TRIAD   =32
%CONSTINTEGER ARREL   =33
%CONSTINTEGER CHAREL  =34
%CONSTINTEGER CHVAL   =35
%CONSTINTEGER LIT     =64
%CONSTINTEGER NEGLIT  =65
%CONSTINTEGER CNSTID  =66
!*
!********************* TRIAD masks *************************************
!*
%CONSTINTEGER CONSTMASK=X'40'
%CONSTINTEGER IDMASK   =X'10'
%CONSTINTEGER TEXTMASK =X'20'
!*
!********************* other useful masks ******************************
!*
%CONSTINTEGER ARRAYBIT  = X'04'
%CONSTINTEGER CMNBIT    = X'02'
%CONSTINTEGER EQUIVBIT  = X'80'
!*
!********************* modes *******************************************
!*
%CONSTINTEGER INT2    = 0, INT4    = 1, INT8    = 2
%CONSTINTEGER REAL4   = 3, REAL8   = 4, REAL16  = 5
%CONSTINTEGER CMPLX8  = 6, CMPLX16 = 7, CMPLX32 = 8
%CONSTINTEGER LOG1    = 9, LOG2    =10, LOG4    =11
%CONSTINTEGER LOG8    =12, CHARMODE=13, HOLMODE =14
%CONSTINTEGER BYTE    =15, HEXCONST =16
!*
!********************* types *******************************************
!*
%CONSTINTEGER INTTYPE   = 1
%CONSTINTEGER REALTYPE  = 2
%CONSTINTEGER CMPLXTYPE = 3
%CONSTINTEGER LOGTYPE   = 4
%CONSTINTEGER CHARTYPE  = 5
!*
!********************* scaling factors *********************************
!*
!*
!********************* length of maximum source statement **************
!*
%CONSTINTEGER INPUT LIMIT = 1328
!*
!********************* mode to size/type *******************************
!*
%CONSTBYTEINTEGERARRAY MODETOST(0:15)=  %C
   X'41',X'51',X'61',X'52',X'62',X'72',
   X'53',X'63',X'73',X'34',X'44',X'54',X'64',5,0,X'31'
!*
!********************* mode to bytes etc. ******************************
!*
%CONSTBYTEINTEGERARRAY CSIZE(0:15)=  %c
   2,4,8,4,8,16,8,16,32,1,2,4,8,1,0,1
%CONSTBYTEINTEGERARRAY ModetoBytes(0:15)=  %c
   2,4,8,4,8,16,8,16,32,1,2,4,8,1,0,1
%CONSTBYTEINTEGERARRAY ModetoTempBytes(0:15)=  %c
   4,4,8,4,8,16,8,16,32,4,4,4,8,4,4,4
%CONSTBYTEINTEGERARRAY SETMODE(0:63)= %C
0(4),10,13,0(11),1,3,6,11,0(12),2,4,7,8,0(12),15,5,8,9,0(11)
!*
!********************** location of pseudo common record in dict *******
!*
%CONSTINTEGER PSEUDOCMN=20
!*
!********************** location of blank common record in dict ********
!*
%CONSTINTEGER BLCMPTR=96
!*
!********************** other useful consts ****************************
!*
%CONSTINTEGER NO  = 0
%CONSTINTEGER YES = 1
%CONSTINTEGER FULL= 2
!*
!********************** area identifiers *******************************
!*
%CONSTINTEGER GLA     = 2
%CONSTINTEGER SST     = 4
%CONSTINTEGER GST     = 5
%CONSTINTEGER DIAGS   = 6
%CONSTINTEGER SCALARS = 7
%CONSTINTEGER IOAREA  = 8
%CONSTINTEGER ZEROGST = 9
%CONSTINTEGER CONSTS  =10
!*
!********************** system procedures ******************************
!*
%constinteger F77AUX   = 0
%constinteger F77STOP  = 1
%constinteger F77PAUSE = 2
%constinteger F77IOA   = 3
%constinteger F77IOB   = 4
%constinteger F77IOC   = 5
%constinteger F77IOD   = 6
%constinteger F77IOE   = 7
%constinteger F77IOF   = 8
%constinteger F77FILE  = 9
%constinteger IMPSTOP  =10
%constinteger F77RTERR =11
%constinteger F77IOAR  =12
%constinteger F77IOBR  =13
%constinteger F77IOG   =14
%constinteger F77CPSTR =15
%constinteger F77CONCAT=16
%constinteger F77INDEX =17
%constinteger FIBITS   =18
%constinteger FISHFTC  =19
!*
!***********************************************************************
!***********************************************************************
!*
!*
! %include "bits_fmts"
!*
!***********************************************************************
!* Formats for accessing dictionary records                            *
!***********************************************************************
!*
%RECORDFORMAT PRECF(%BYTEINTEGER CLASS,TYPE,X0,X1,
                    %INTEGER LINK1, LINK2,
                   (%shortinteger COORD,LINK3 %OR %INTEGER LAST   %C
                        %OR %INTEGER CONSTRES %OR %INTEGER INF3),
                    %INTEGER ADDR4,
                    %shortinteger DISP,LEN,IDEN,IIN,
                    %INTEGER LINE,XREF,CMNLENGTH,CMNREFAD)
!*
%RECORDFORMAT SRECF(%INTEGER INF0, LINK1, INF2, INF3, INF4)
!*
%RECORDFORMAT RESF((%INTEGER W %OR (%shortinteger H0 %OR %shortinteger INF),
                      (%shortinteger H1 %OR %BYTEINTEGER FORM,MODE)))
!*
%RECORDFORMAT DORECF( %C
    %INTEGER LABEL, LINK1,
    %RECORD(RESF) LOOPAD, ENDREF, INDEXRD, INCRD, FINALRD, ICRD,
    %INTEGER LABLIST,LINE)
!*
%RECORDFORMAT BFMT(%INTEGER L,U,M)
!*
%RECORDFORMAT ARRAYDVF(%INTEGER DIMS, ADDRDV,ADDRZERO,  %C
            %INTEGER ZEROTOFIRST, ADFIRST, NUMELS, ELLENGTH,  %C
            %RECORD(BFMT) %ARRAY B(1 : 7))
!*
!*
%RECORDFORMAT LRECF(%INTEGER NOTFLAG,LINK1,
                    %RECORD(RESF) ORLAB,ANDLAB,
                    %INTEGER RELOP)
!*
%RECORDFORMAT IFRECF(%INTEGER TYPE,LINK1,
                     %RECORD(RESF) ENDIFLAB,FALSELAB,
                     %INTEGER LABLIST,LINE)
!*
%RECORDFORMAT LABRECF(%shortinteger BLKIND,%BYTEINTEGER X0,X1,  %C
            %INTEGER LINK1,LINK2,LINK3,ADDR4,LINK5,LAB,LINE,  %C
            %shortinteger DOSTART,DOEND,IFSTART,IFEND)
!*
%RECORDFORMAT PLABF(%shortinteger BLKIND,%BYTEINTEGER USE,X1,
                    %INTEGER INDEX,CODEAD,REF,REFCHAIN)
!*
%RECORDFORMAT IMPDORECF(%INTEGER VAL,LINK,IDEN)
!*
%RECORDFORMAT CONSTRECF(%shortinteger MODE,LENGTH,
                      (%INTEGER VALUE %OR %INTEGER LINK1),
                      %INTEGER DADDR,CADDR)
!*
%RECORDFORMAT TMPF((%BYTEINTEGER CLASS,TYPE,
                        %shortinteger LEN %OR %INTEGER W0),
                    %INTEGER LINK1,
                    %BYTEINTEGER REG,MODE,%shortinteger INDEX,
                    %shortinteger COORD,USECNT,
                    %INTEGER ADDR)
!*
%RECORDFORMAT CHARF(%INTEGER ADESC,LINK,LEN)
!*
%RECORDFORMAT FNRECF(%INTEGER FPTR,LINK1,HEAD,PCT)
!*
%RECORDFORMAT TERECF(%shortinteger MODE,LOOP,
                      %INTEGER CHAIN,DISP1,INDEX,
                      %shortinteger COORD,FLAGS)
!*
%RECORDFORMAT DTRECF(%shortinteger MODE,IDENT,
                      %INTEGER CHAIN,DISP2,
                      %shortinteger FLAGS,INDEX,
                     (%INTEGER LOOP %OR %RECORD(RESF) CONST))
!*
!*
!***********************************************************************
!* TRIAD record format                                                 *
!***********************************************************************
!*
%RECORDFORMAT TRIADF(  %C
               %BYTEINTEGER OP,
               (%BYTEINTEGER USE %OR %BYTEINTEGER VAL2),
               %shortinteger CHAIN,
               (%RECORD(RESF) RES1      %OR     %C
               (%shortinteger OPD1,%BYTEINTEGER QOPD1,MODE  %OR  %C
               (%INTEGER SLN %OR %INTEGER VAL1))),
               (%RECORD(RESF) RES2      %OR   %C
                %shortinteger OPD2,%BYTEINTEGER QOPD2,MODE2))
!*
!***********************************************************************
!***********************************************************************
!*
!*
!%include "bits_com"
!*
!***********************************************************************
!* COM record format                                                   *
!***********************************************************************
!*
!*
%RECORDFORMAT COMFMT(%INTEGER CONTROL,OPT,OPTIONS1,OPTIONS2,PTRACE,
      ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR,
      MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD,
      SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST,
      RESCOM1,RESCOM2,F77PARM,FNO,FAULTY,LINEST,CMNIIN,SFMK,
      LISTL,LISTSTREAM,DIAGSTREAM,LISTMODE,XREF,
      PACKCMN,ITSMODE,PATHANAL,CHARACTER CODE,SPACE CHAR,
      HEADINGS,ARRAYCHECKS,JBRMODE,MESSLEN,NAMESLEN,
      NEXTCH,FUNRESDISP,WARNCOUNT,INP,MAXINP,MESSCOUNT,
      UNASSPATTERN,LISTCODE,PI21INT,DOPTR,SUBPROGPTR,
      FNLST,LAB,NAMESFREE,ALGOLREF,FIRSTSTATNUM,CEXPDICT,
      COMMONBASE,FASTPROLOGUE,STATEMENT,IFPTR,
      CNSTCA,COMMENTCNT,ADIDENT,ADERRIDEN,
      ADEXT,MAXDICT,MAXNAMES,MAXOUTPUT,MAXEXT,
      ACOMP,ASUBNAMES,MAXPSTACK,
      ATRIADS,TRFILEID,TRBLOCK,CMNCNT,SCANONLY,NOISY,
      MAXANAL,MAXGEN,SAVEANAL,SAVEGEN,OPTFLAGS,NEXTBIT,
      ACMNBITS,NEXTTEMP,ASSGOTOS,TMPPTR,DESTEMPS,OBJADDR,
      AREAADDR,PASTART,ADOPTDATA,TMINDEX,VRETURN,ENTRIES,
      EQUCHK,LABWARN,LINENO,MAXIBUFF,
      COMMENTS,DIAGLEVEL,WARNNOT77,WARNLENGTH,ALLOWUNIX,ALLOWVAX,
      ONETRIP,HOST,TARGET,MONERRS,TRANSMTM,
      GLACA,PLTCA,SSTCA,GSTCA,CONSTCA,SCALARCA,IOAREACA,ZGSTCA,STACKCA,
      W1,W2,W4,STATORDERMODE,CURSTATCLASS,LISTPOINT,STACKBASE,
      NEXTTRIAD,ASAVE,MAXSAVE,SUBTAB,LASTSUBTAB,
      INHIBOP4,ARGCNT,IDCNT,LABCNT,TMLIST,MAINPROG,PROCINDEX,CONSOLE,
      NEXTSAVE)
!*
!***********************************************************************
!***********************************************************************
!*
!*
!%include "bits_subfmt"
!*
%RECORDFORMAT SUBRECF(%INTEGER LINK,FLAGS,TRIADS,DICT,NAMES,PTRS,PROG,
      LABCNT,ARGCNT,IDCNT,TRCNT,REFSCNT,TMPPTR,
      DPTR,NEXTTRIAD,NAMESFREE,NEXTBIT,SUBPROGTYPE,SUBPROGPTR,
      CBNPTR,SCPTR,CMNIIN,FUNRESDISP,CMNCNT,ASSGOTOS,VRETURN,ENTRIES,
      TMLIST,ALABS,ALHEADS,NEXTPLAB,
      %STRING(32) NAME,%INTEGERARRAY COORDS(0:15),
      %INTEGER NEXTTEMP,SPARE1,SPARE2,SPARE3)
!*
%CONSTINTEGER SUBSIZE=248
%CONSTINTEGER LABSIZE=128
%CONSTINTEGER LHEADSIZE=620
!*
!*
{%externalroutinespec Note Subname(%string(63) S)}
%externalroutinespec Lfault(%integer N)
%externalroutinespec Setbit(%integer Stripaddr,Index)
!*
%extrinsicintegerarray Asl(0:10)
!*
%ownrecord(Comfmt)%name Com
%ownrecord(Subrecf)%name Sub
%ownrecord(Subrecf)%name Csub
%ownrecord(Precf)%name Csubep
%ownstring(32) Csubname
!*
%owninteger Acom,Acopysub
!*
%CONSTBYTEINTEGERARRAY HEX(0 : 15) =   %C
 '0','1','2','3','4','5','6','7',
 '8','9','A','B','C','D','E','F'
!*
!*
%ROUTINE PRHEX(%INTEGER J)
%INTEGER K
      %CYCLE K = 28,-4,0
         PRINT SYMBOL(HEX((J>>K)&15))
      %REPEAT
%END
!*
%ROUTINE PH(%INTEGER I)
%INTEGER J,K,L
      %CYCLE J=I,1,I+3
         L=BYTEINTEGER(J)
         PRINTSYMBOL(HEX(L>>4))
         PRINTSYMBOL(HEX(L&15))
      %REPEAT
      SPACES(2)
%END
!*
%ROUTINE DICREC(%INTEGER Base,A,AN)
%RECORD(PRECF)%NAME PP
%INTEGER I
%return
      I = Base+A
      PP==RECORD(I)
      Prhex(Base);newline
      PRHEX(A)
      SPACES(6)
      PH(I)
      PH(I+4)
      SPACES(2)
      PH(I+8)
      PH(I+12)
      SPACES(2)
      NEWLINE
      WRITE(A,7)
      SPACES(6)
      PH(I+16)
      PH(I+20)
      SPACES(2)
      PH(I+24)
      PH(I+28)
      SPACES(2)
     %IF AN#0 %THENSTART
         WRITE(PP_COORD,2)
         SPACES(2)
         PRINTSTRING(STRING(AN+PP_IDEN))
      %FINISH
      NEWLINES(2)
%END
!*
%ROUTINE DICRECLIST(%INTEGER HEAD,ID)
%RECORD(PRECF) %NAME P
      %WHILE HEAD # 0 %CYCLE
         P == RECORD(COM_ADICT+HEAD)
         DICREC(Com_Adict,HEAD,ID)
         %IF ID#0 %AND P_CLASS&X'C'=4 %THEN DICREC(Com_Adict,P_ADDR4,0);! ARRAY DV
         %IF P_CLASS=12 %THEN DICREC(Com_Adict,HEAD+32,0);! common block
         HEAD = P_LINK1
      %REPEAT
%END;                                   ! DICRECLIST
!*
%INTEGERFN NEXT COORD
%integer Curbit
      %IF COM_NEXTBIT<512 %THENSTART
         CURBIT=COM_NEXTBIT
         COM_NEXTBIT=CURBIT+1
      %FINISHELSE CURBIT=3
      %RESULT=CURBIT
%END;! NEXT COORD
!*
%routine Move(%integer Length,Fbase,Tbase)
!***********************************************************************
!* copy Length bytes from fbase to tbase                               *
!***********************************************************************
%integer I
      %if Length<=0 %then %return
      %cycle I=0,1,Length-1
         byteinteger(Tbase+I)=byteinteger(Fbase+I)
      %repeat
%end;! Move
!*
%externalroutine Op4 Init(%integer Comad)
      Acom=Comad
      Com==record(Comad)
      Com_Nextsave=32
      Com_Subtab=0
      Com_Lastsubtab=0
%end;! Op4 Init
!*
%integerfn Subspace(%integer Len)
%integer I
      %if Com_Nextsave+Len>Com_Maxsave %then Lfault(346) %and %result=-1
      I=Com_Nextsave
      Com_Nextsave=Com_Nextsave+Len
      %result=I
%end;! Subspace
!*
%integerfn Preserve(%integer From,Len,%integername Saveaddress)
%integer I,J,K
      Len=((Len+3)>>2)<<2
      I=Subspace(Len)
      %if I<0 %then %result=I
      I=Com_Asave+I
      Saveaddress=I
      Move(Len,From,I)
      %result=0
%end;! Preserve
!*
%routine Reset(%integer Resetaddress,Len,Saveaddress)
      Move(Len,Saveaddress,Resetaddress)
%end;! Reset
!*
%integerfn Locate Subtab(%stringname S)
%record(Subrecf)%name Sub
%integer I
      I=Com_Subtab
      %while I#0 %cycle
         Sub==record(Com_Asave+I)
         %if S=Sub_Name %then %result=I
         I=Sub_Link
      %repeat
!*
      I=Subspace(SUBSIZE)
      %if I<0 %then %result=I;! run out of space
      Sub==record(Com_Asave+I)
      Sub_Name=S
      Sub_Flags=0
      Sub_Triads=0
      Sub_Dict=0
      Sub_Names=0
      Sub_Ptrs=0
      Sub_Prog=0
      Sub_Refscnt=0
      Sub_Link=0
      %if Com_Lastsubtab#0 %thenstart
         Sub==record(Com_Asave+Com_Lastsubtab)
         Sub_Link=I
      %finishelse Com_Subtab=I
      Com_Lastsubtab=I
      %result=I
%end;! Locate Subtab
!*
%externalintegerfn Op4 Ref(%string(63) S)
%record(Subrecf)%name Sub
%integer Asub
      Asub=Locate Subtab(S)
      %if Asub<0 %then %result=Asub
      Sub==record(Com_Asave+Asub)
      Sub_Refscnt=Sub_Refscnt+1
      %if Sub_Triads=0 %then Sub_Flags=5;! to inhibit attempt to generate a ref
      %result=0
%end;! Op4 Ref
!*
%externalintegerfn Op4 Save
%record(Precf)%name Subprog
%record(Subrecf)%name Sub
%string(32) S
%integer I,Asub
      Subprog==record(Com_Adict+Com_Subprogptr)
      S=string(Com_Anames+Subprog_Iden)
!printstring("
!Saving ".S."
!")
!*
      Asub=Locate Subtab(S)
      %if Asub<0 %then %result=Asub
!*
      Sub==record(Com_Asave+Asub)
      %if Sub_Triads#0 %then Lfault(345) %and %result=-2;! multiple defn of subprog
!*
      I=Preserve(Com_Atriads,Com_Nexttriad*12,Sub_Triads)
      %if I<0 %then %result=I
      I=Preserve(Com_Adict,Com_Dptr,Sub_Dict)
      %if I<0 %then %result=I
      I=Preserve(Com_Anames,Com_Namesfree,Sub_Names)
      %if I<0 %then %result=I
      I=Preserve(Com_Alabh,LABSIZE,Sub_Alabs)
      %if I<0 %then %result=I
      I=Preserve(Com_Adlhead,LHEADSIZE,Sub_Alheads)
      %if I<0 %then %result=I
      Sub_Flags=Com_Inhibop4
      Sub_Argcnt=Com_Argcnt
      Sub_Idcnt=Com_Idcnt
      Sub_Labcnt=Com_Labcnt+Com_Nextplab
      Sub_Trcnt=Com_Nexttriad
      Sub_Dptr=Com_Dptr
      Sub_Prog=Com_Subprogptr
      Sub_Nexttriad=Com_Nexttriad
      Sub_Namesfree=Com_Namesfree
      Sub_Nextbit=Com_Nextbit
      Sub_Subprogtype=Com_Subprogtype
      Sub_Subprogptr=Com_Subprogptr
      Sub_Cbnptr=Com_Cbnptr
      Sub_Scptr=Com_Scptr
      Sub_Cmniin=Com_Cmniin
      Sub_Funresdisp=Com_Funresdisp
      Sub_Cmncnt=Com_Cmncnt
      Sub_Assgotos=Com_Assgotos
      Sub_Vreturn=Com_Vreturn
      Sub_Entries=Com_Entries
      Sub_Tmlist=Com_Tmlist
      Sub_Nextplab=Com_Nextplab
      Sub_Tmpptr=Com_Tmpptr
      Sub_Nexttemp=Com_Nexttemp
      Move(64,Com_Acmnbits,Addr(Sub_Coords(0)))
      %result=0
%end;! Op4 Save
!*
%externalroutine Op4 Setup(%integer Copysub)
      Acopysub=Copysub
      Csub==record(Com_Asave+Copysub)
      Csubep==record(Csub_Dict+Csub_Subprogptr)
      Csubname=string(Csub_Names+Csubep_Iden)
%end;! Op4 Setup
!*
%externalroutine Op4 Restore(%integer Tabad)
%record(Subrecf)%name Sub
%record(Precf)%name PP
%integer I
%string(63) S
%conststring(12)%array Prg(0:5)=   %c
   "MAIN PROGRAM",
   "PROGRAM ",
   "FUNCTION ",
   "SUBROUTINE ",
   "",
   "BLOCKDATA"
      Sub==record(Com_ASave+Tabad)
!printstring("
!Restoring ".Sub_Name."
!")
      Com_Dptr=Sub_Dptr
      Com_Nexttriad=Sub_Nexttriad
      Com_Namesfree=Sub_Namesfree
      Com_Nextbit=Sub_Nextbit
      Com_Subprogtype=Sub_Subprogtype
      Com_Subprogptr=Sub_Subprogptr
      Com_Cbnptr=Sub_Cbnptr
      Com_Scptr=Sub_Scptr
      Com_Cmniin=Sub_Cmniin
      Com_Funresdisp=Sub_Funresdisp
      Com_Cmncnt=Sub_Cmncnt
      Com_Assgotos=Sub_Assgotos
      Com_Vreturn=Sub_Vreturn
      Com_Entries=Sub_Entries
      Com_Tmlist=Sub_Tmlist
      Com_Nextplab=Sub_Nextplab
      Com_Tmpptr=Sub_Tmpptr
      Com_Nexttemp=Sub_Nexttemp
      Reset(Com_Atriads,Com_Nexttriad*12,Sub_Triads)
      Reset(Com_Adict,Com_Dptr,Sub_Dict)
      Reset(Com_Anames,Com_Namesfree,Sub_Names)
      Reset(Com_Alabh,LABSIZE,Sub_Alabs)
      Reset(Com_Adlhead,LHEADSIZE,Sub_Alheads)
      Reset(Com_Acmnbits,64,Addr(Sub_Coords(0)))
      PP==record(Com_Adict+Com_Subprogptr)
      S=string(Com_Anames+PP_Iden)
      I=Com_Subprogtype
      %if I=1 %and S="ICL9HFMAIN" %then I=0 %and S=""
{      Note Subname(Prg(I).S)}
      %cycle I=0,1,10
         Asl(I)=0
      %repeat
%end;! Op4 Restore
!*
%externalroutine Op4 Restoretr
%integer I
      I=Com_Atriads+Com_Nexttriad*12
      Move(Csub_Nexttriad*12-12,Csub_Triads+12,I)
      byteinteger(I+1)=3;! first stat now dummy stat
      integer(I+4)=0
      integer(I+8)=0
      Com_Nexttriad=Com_Nexttriad+Csub_Nexttriad-1
%end
!*
%externalintegerfn Op4 Newrd(%integer Argid)
%record(Precf)%name PP
%record(Resf) R
      PP==record(Csub_Dict+Argid)
      Dicrec(Csub_Dict,Argid,Csub_names)
      R_H0=Argid>>DSCALE
      %if PP_Class=X'B' %thenstart;! this subprog
         R_Form=PROCID
      %finishelsestart
         %if PP_Class&X'C'=4 %then R_Form=ARRID %elsestart
            R_Form=PSCALID
         %finish
      %finish
      R_Mode=Setmode(PP_Type&X'3F')
!printstring("
! Arg res = ")
!prhex(R_W)
!newline
      %result=R_W
%end;! Op4 Newrd
!*
%integerfn Newname(%stringname S,%integer Oldrec,C,%integername Ptr)
!* C = 0  scalar required
!*     1  common required
%record(Precf)%name PP
%record(Precf)%name QQ
%integer I,J,K,L,Hash,hashhead,P
%byteintegerarray A(0:65)
      string(addr(A(0)))=S
      L=A(0)
      Hash=0
      %cycle J=1,1,L
         K=A(J)&31
         Hash=Hash+K
      %repeat
      %if L=1 %thenstart
         Hash=K+127
      %finishelsestart
         Hash=(Hash-K+K<<3)&127
      %finish
!*
      Hashhead=Com_Adlhead+Hash<<2

      P=integer(Hashhead)
      %while P#0 %cycle
         PP==record(Com_Adict+P)
         %if string(Com_Anames+PP_Iden)=S %thenstart
            %if (C=0 %and PP_Class#12) %or (C=1 %and PP_Class=12) %thenstart
               Ptr=P
               %result=0
            %finish
         %finish
         P=PP_Link1
      %repeat
!*
!* no existing entry
!*
      PP==record(Oldrec)
      J=Com_Adict+Com_Dptr
!!    Dicful %if Com_Dptr+44>Com_Diclen
      Move(44,Oldrec,Com_Adict+Com_Dptr)
      Ptr=Com_Dptr
      Com_Dptr=Com_Dptr+44
      QQ==record(Com_Adict+Ptr)
      QQ_Line=0
      QQ_Xref=0;! previous info not relevant?
!*
!!    %if Com_Namesfree+64>Com_Nameslen %then Nameful
      string(Com_Anames+Com_Namesfree)=S
      QQ_Iden=Com_Namesfree
      Com_Namesfree=Com_Namesfree+A(0)+1
!*
      QQ_Link1=integer(Hashhead)
      integer(Hashhead)=Ptr
      %if QQ_Class&X'C'=4 %thenstart;! array - copy dv
         Move(40,Csub_Dict+PP_Addr4,Com_Adict+Com_Dptr)
         QQ_Addr4=Com_Dptr
         Com_Dptr=Com_Dptr+40
      %finish
      %result=-1
%end;! Newname
!*
%externalintegerfn Op4 Newdict(%record(Resf)%name Res)
%record(Resf) R
%string(65) S
%record(Precf)%name PP
%record(Precf)%name QQ
%record(Precf)%name NewPP
%record(Precf)%name Oldcmn
%record(Precf)%name Newcmn
%record(Constrecf)%name Oldcon
%record(Constrecf)%name Newcon
%record(Tmpf)%name Tmp
%integer I,J,K,Ptr,Oldrec,Oldcmnrec,Idptr,Cmnptr,Coord
%switch F(0:66)
      R_W=Res_W
      Oldrec=R_H0<<DSCALE
!printstring("
!newdict:
!")
      Dicrec(Csub_Dict,Oldrec,Csub_Names)
      ->F(R_Form)
!*
F(*): printstring("
Form not allowed for

")
      %monitor
      %stop
!*
F(CNSTID):
      Oldcon==record(Csub_Dict+Oldrec)
      %unless Oldcon_Mode>LOG8 %then Oldcon_Length=Modetobytes(Oldcon_Mode)
      %if Oldcon_Mode=CHARMODE %or Oldcon_Mode=HOLMODE %thenstart
         I=((23+integer(Csub_Dict+Oldcon_Daddr))>>2)<<2
      %finishelse I=((16+Oldcon_Length+3)>>2)<<2
      Move(16,Csub_Dict+Oldrec,Com_Adict+Com_Dptr)
      Move(I-16,Csub_Dict+Oldcon_Daddr,Com_Adict+Com_Dptr+16)
      R_H0=Com_Dptr>>DSCALE
      Newcon==record(Com_Adict+Com_Dptr)
      Newcon_Daddr=Com_Dptr+16
      Com_Dptr=Com_Dptr+I
      %result=R_W
!*
F(ARRID):
!*
F(LSCALID):
!*
F(CSCALID):
!*
F(OSCALID):
!*
F(PSCALID):
      PP==record(Csub_Dict+Oldrec)
      S=Csubname.".".string(Csub_Names+PP_Iden)
      I=Newname(S,Csub_Dict+Oldrec,0,Idptr)
      NewPP==record(Com_Adict+Idptr)
      %if I=0 %then ->Out
      %unless NewPP_Class&X'A'=2 %thenstart
         NewPP_Coord=Next Coord
         ->Out
      %finish
      Oldcmnrec=Csub_Dict+PP_Link3<<DSCALE
      Oldcmn==record(Oldcmnrec)
      S=string(Csub_Names+Oldcmn_Iden)
      I=Newname(S,Oldcmnrec,1,Cmnptr)
      Newcmn==record(Com_Adict+Cmnptr)
      %if I<0 %thenstart;! this common has not been referenced here before
         Newcmn_Link2=0
         Coord=Next Coord
         Setbit(Com_Acmnbits,Coord)
         Newcmn_Addr4=Com_Cbnptr
         Com_Cbnptr=Cmnptr
      %finishelsestart
         %if Oldcmn_Cmnlength>Newcmn_Cmnlength %then  %c
                          Newcmn_Cmnlength=Oldcmn_Cmnlength
         %if Newcmn_Cmnrefad=0 %thenstart
            Newcmn_Cmnrefad=Oldcmn_Cmnrefad
            Coord=Nextcoord
            Setbit(Com_Acmnbits,Coord)
            Newcmn_Addr4=Com_Cbnptr
            Com_Cbnptr=Cmnptr
         %finishelsestart
            QQ==record(Com_Adict+Newcmn_Link2)
            Coord=QQ_Coord
         %finish
      %finish
      NewPP_Link3=Cmnptr>>DSCALE
      NewPP_Link2=Newcmn_Link2
      Newcmn_Link2=Idptr
      I=Idptr
      %while I#0 %cycle
         QQ==record(Com_Adict+I)
         QQ_Coord=Coord
         I=QQ_Link2
      %repeat
      Dicrec(Com_Adict,Cmnptr,Com_Anames)
      Dicrec(Com_Adict,Cmnptr+32,0)
Out:  Dicrec(Com_Adict,Idptr,Com_Anames)
      %if NewPP_Class&X'C'=4 %then Dicrec(Com_Adict,Newpp_Addr4,0);! for dv
      R_H0=Idptr>>DSCALE
!printstring("
!newdict res = ")
!prhex(R_W)
!newline
      %result=R_W
!*
F(PROCID):
      PP==record(Csub_Dict+Oldrec)
      S=string(Csub_Names+PP_Iden)
      I=Newname(S,Csub_Dict+Oldrec,0,Idptr)
      NewPP==record(Com_Adict+Idptr)
      ->Out
!*
F(PERMID):
      Idptr=Com_Dptr
      Move(20,Csub_Dict+Oldrec,Com_Adict+Idptr)
      Com_Dptr=Com_Dptr+20
      Tmp==record(Com_Adict+Idptr)
      Tmp_Coord=Next Coord
      R_H0=Idptr>>DSCALE
      %result=R_W
!*
%end;! Op4 Newdict
!*
%externalintegerfn Op4 Argcheck(%integer Actual,Formal)
!* Check whether actual and formal arguments are compatible for opt4 processing
!* result = 0  OK
!*          1  inhibit opt4
!*
%integer Aform,Fform,I
%record(Resf) Ares
%record(Resf) Fres
%record(Precf)%name Aarray
%record(Precf)%name Farray
%record(Arraydvf)%name Adv
%record(Arraydvf)%name Fdv
      Ares_W=Actual
      Fres_W=Formal
      Aform=Ares_Form
      Fform=Fres_Form
      %if Aform=PROCID %or Fform=PROCID %then %result=1
      %if Ares_Mode#Fres_Mode %then %result=1
      %if Fres_Mode=CHARMODE %then %result=1
      %if CMPLX8<=Fres_Mode<=CMPLX32 %then %result=1
      %if Aform=ARRID %and Fform#ARRID %then %result=1
      %if Fform=ARRID %thenstart
         %if Aform#ARRID %then %result=1
                                        {now check the shape}
         Aarray==record(Com_Adict+Ares_H0<<DSCALE)
         Adv==record(Com_Adict+Aarray_Addr4)
         Farray==record(Csub_Dict+Fres_H0<<DSCALE)
         Fdv==record(Csub_Dict+Farray_Addr4)
         %if Adv_Dims#Fdv_Dims %then %result=1
         %if Adv_Dims=1 %then %result=0
         %cycle I=1,1,Adv_Dims
            %if Adv_B(I)_L#Fdv_B(I)_L %then %result=1
            %if Adv_B(I)_U#Fdv_B(I)_U %then %result=1
         %repeat
         %result=0
      %finish
{insert here any other reasons for rejecting the args}
      %result=0
%end;! Op4 Argcheck
!*
%endoffile