!                                                            froot1a
! 04/03/87 - set Com_Allowvax, Com_Allowunix to 0
! 25/02/87 - change Version message
!                                                              froot1
! 10/10/86 - insert include files
!                                                              ftnroot9
! 30/09/86 - set Com_Listmode non-zero if code listing only
!                                                              ftnroot8
! 10/09/86 - Com_Opt&1  normal optimisation   &2  inline subprograms
! 06/07/86 - adjust space for Output in T#Names                ftnroot7
! Modified 11/6/86 - Put in PNX table size control             ftnroot6
! Modified 05/06/86                                            ftnroot5
!
! FORTRAN 77 CTL MODULE 
!
%OWNSTRING (70) VERSION =  %c
"Amdahl Fortran77 Compiler Version 2.00"
%constinteger Rel  = 0
%constinteger Vers = 1
!*
%include "ftn_ht"
{%include "ftn_consts3"}
!* modified 23/09/86
!*
!*
%constinteger WSCALE = 2;! scale word address to byte address
%constinteger BSCALE = 0;! scaling factor for words to architectural units
%constinteger CSCALE = 0;! byte offset to architectural unit offset
%constinteger DSCALE = 2;! dict pointer scaling in RES records
!*
%constinteger W1 =  4 ;!  1 word  in architectural units
%constinteger W2 =  8 ;!  2 words in architectural units
%constinteger W3 = 12 ;!  3 words in architectural units
%constinteger W4 = 16 ;!  4 words in architectural units
!*
%constinteger TRIADLENGTH    = 12 ;! size of an individual triad
%constinteger BLRECSIZE      = 44 ;! size of a block table entry in architectural units
%constinteger LOOPRECSIZE    = 16 ;! size of a loop table entry
%constinteger PROPRECSIZE    = 12 ;! size of a propagation table entry
%constinteger CLOOPSZ        = 12 ;! size of cloop table entry
%constinteger FRSIZE         =  8 ;! size of freelist created by PUSHFREE
%constinteger TESZ           = 20
%constinteger DTSZ           = 20
%constinteger ARTICSZ        =  4
%constinteger CTSIZE         =  2 ;! used in OP3
%constinteger EXTNSIZE       =  4 ;! used in OP3
!*
!* following used in strength reduction
!*
%constinteger RDSZ           =  8
%constinteger RUSESZ         = 12
%constinteger RTESTSZ        =  4
%constinteger RDEFSZ         = 16
%constinteger USESZ          = 32
%constinteger SRUSESZ        =  2
%constinteger SRSCALE        =  2;! SR==RECORD(ABLOCKS + SRPTR<<SRSCALE)
%constinteger SRFIXED        = 36
!*
!*
%conststring(5) REG1="reg7"
%constinteger GLAOFFSET=32
%if target=ibm %thenstart
   %constinteger dvarea=7
%finishelsestart
   %constinteger DVAREA=2
%finish
!*
!***********************************************************************
!* Constants defining the size of DICT records                         *
!***********************************************************************
!*
   %constinteger IDRECSIZE    = 28;! size of dict entry reserved for a new identifier
   %constinteger CONRECSIZE   = 16
   %constinteger CNSTRECMIN   =  4
   %constinteger IMPDORECSIZE = 12;! size of DATA-implied-DO list item
   %constinteger LABRECSIZE   = 40
   %constinteger PLABRECSIZE  =  8;! N.B. this is a reduced size for compiler using Put interfaces
   %constinteger XREFSIZE     =  8
   %constinteger CMNRECEXT    = 16;! extra space on iden record for common block name
   %constinteger TMPRECSIZE   = 20
   %constinteger DVRECSIZE    = 28
   %constinteger TRIADSIZE    = 12
   %constinteger LBLKSIZE     = 520
!*
!*
!********************* TRIAD qualifiers ********************************
!*
%CONSTINTEGER NULL    = 0
%CONSTINTEGER LABID   = 1
%CONSTINTEGER PLABID  = 2
%CONSTINTEGER PROCID  = 3
%CONSTINTEGER STKLIT  = 4
%CONSTINTEGER GLALIT  = 5
%CONSTINTEGER SRTEMP  = 6
%CONSTINTEGER BREG    = 7
%CONSTINTEGER VALTEMP = 8
%CONSTINTEGER DESTEMP = 9
%CONSTINTEGER LSCALID =16
%CONSTINTEGER OSCALID =17
%CONSTINTEGER CSCALID =18
%CONSTINTEGER ASCALID =19
%CONSTINTEGER PSCALID =20
%CONSTINTEGER ARRID   =21
%CONSTINTEGER TMPID   =22
%CONSTINTEGER PERMID  =23
%CONSTINTEGER STFNID  =24
%CONSTINTEGER ITMPID  =22
%CONSTINTEGER RTMPID  =22
%CONSTINTEGER ETMPID  =22
%CONSTINTEGER TRIAD   =32
%CONSTINTEGER ARREL   =33
%CONSTINTEGER CHAREL  =34
%CONSTINTEGER CHVAL   =35
%CONSTINTEGER LIT     =64
%CONSTINTEGER NEGLIT  =65
%CONSTINTEGER CNSTID  =66
!*
!********************* TRIAD masks *************************************
!*
%CONSTINTEGER CONSTMASK=X'40'
%CONSTINTEGER IDMASK   =X'10'
%CONSTINTEGER TEXTMASK =X'20'
!*
!********************* other useful masks ******************************
!*
%CONSTINTEGER ARRAYBIT  = X'04'
%CONSTINTEGER CMNBIT    = X'02'
%CONSTINTEGER EQUIVBIT  = X'80'
!*
!********************* modes *******************************************
!*
%CONSTINTEGER INT2    = 0, INT4    = 1, INT8    = 2
%CONSTINTEGER REAL4   = 3, REAL8   = 4, REAL16  = 5
%CONSTINTEGER CMPLX8  = 6, CMPLX16 = 7, CMPLX32 = 8
%CONSTINTEGER LOG1    = 9, LOG2    =10, LOG4    =11
%CONSTINTEGER LOG8    =12, CHARMODE=13, HOLMODE =14
%CONSTINTEGER BYTE    =15, HEXCONST=16
!*
!********************* types *******************************************
!*
%CONSTINTEGER INTTYPE   = 1
%CONSTINTEGER REALTYPE  = 2
%CONSTINTEGER CMPLXTYPE = 3
%CONSTINTEGER LOGTYPE   = 4
%CONSTINTEGER CHARTYPE  = 5
!*
!********************* scaling factors *********************************
!*
!*
!********************* length of maximum source statement **************
!*
%CONSTINTEGER INPUT LIMIT = 1328
!*
!********************* mode to 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 STACK   = 0
%CONSTINTEGER GLA     = 2
%CONSTINTEGER SST     = 4
%CONSTINTEGER GST     = 5
%CONSTINTEGER DIAGS   = 6
%if target=ibm %thenstart
   %constinteger scalars=7
%finishelsestart
   %CONSTINTEGER SCALARS = 2
%finish
%CONSTINTEGER IOAREA  = 8
%CONSTINTEGER ZEROGST = 9
%CONSTINTEGER CONSTS  =10
!*
!********************** system procedures ******************************
!*
%constinteger F77AUX   = 0
%constinteger F77STOP  = 1
%constinteger F77PAUSE = 2
%constinteger F77IOA   = 3
%constinteger F77IOB   = 4
%constinteger F77IOC   = 5
%constinteger F77IOD   = 6
%constinteger F77IOE   = 7
%constinteger F77IOF   = 8
%constinteger F77FILE  = 9
%constinteger IMPSTOP  =10
%constinteger F77RTERR =11
%constinteger F77IOAR  =12
%constinteger F77IOBR  =13
%constinteger F77IOG   =14
%constinteger F77CPSTR =15
%constinteger F77CONCAT=16
%constinteger F77INDEX =17
%constinteger FIBITS   =18
%constinteger FISHFTC  =19
%constinteger F77PCHECK=20
%constinteger F77IOH   =21
%constinteger F77IOI   =22
!***********************************************************************
!*
{%include "ftn_fmts2"}
!* 09/12/85 - add recordformat SUBFMT
!* modified 14/03/85
!*
!***********************************************************************
!* Formats for accessing dictionary records                            *
!***********************************************************************
!*
%recordformat PRECF(%byteinteger CLASS,TYPE,X0,X1,
                    %integer LINK1, LINK2,
                   (%shortinteger COORD,LINK3  %OR %integer LAST   %C
                        %OR %integer CONSTRES %OR %integer INF3),
                    %integer ADDR4,
                    %shortinteger DISP,LEN,IDEN,IIN,
                    %integer LINE,XREF,CMNLENGTH,CMNREFAD)
!*
%recordformat SRECF(%integer INF0, LINK1, INF2, INF3, INF4)
!*
%recordformat RESF((%integer W %OR %shortinteger H0,
                      (%shortinteger H1 %OR %byteinteger FORM,MODE)))
!*
%recordformat DORECF( %C
    %integer LABEL, LINK1,
    %record(RESF) LOOPAD, ENDREF, INDEXRD, INCRD, FINALRD, ICRD,
    %integer LABLIST,LINE)
!*
%recordformat BFMT(%integer L,U,M)
!*
%recordformat ARRAYDVF(%integer DIMS, ADDRDV,ADDRZERO,  %C
            %integer ZEROTOFIRST, ADFIRST, NUMELS, ELLENGTH,  %C
            %record(BFMT) %ARRAY B(1 : 7))
!*
!*
%recordformat LRECF(%integer NOTFLAG,LINK1,
                    %record(RESF) ORLAB,ANDLAB,
                    %integer RELOP)
!*
%recordformat IFRECF(%integer TYPE,LINK1,
                     %record(RESF) ENDIFLAB,FALSELAB,
                     %integer LABLIST,LINE)
!*
%recordformat LABRECF(%shortinteger BLKIND,%byteinteger X0,X1,  %C
            %integer LINK1,LINK2,LINK3,ADDR4,LINK5,LAB,LINE,  %C
            %shortinteger DOSTART,DOEND,IFSTART,IFEND)
!*
%recordformat PLABF(%shortinteger BLKIND,%byteinteger USE,X1,
                    %integer INDEX,CODEAD,REF,REFCHAIN)
!*
%recordformat IMPDORECF(%integer VAL,LINK,IDEN)
!*
%recordformat CONSTRECF(%shortinteger MODE,LENGTH,
                      (%integer VALUE %OR %integer LINK1),
                      %integer DADDR,CADDR)
!*
%recordformat TMPF((%byteinteger CLASS,TYPE,
                        %shortinteger LEN %OR %integer W0),
                    %integer LINK1,
                    %byteinteger REG,MODE,%shortinteger INDEX,
                    %shortinteger COORD,USECNT,
                    %integer ADDR)
!*
%recordformat CHARF(%integer ADESC,LINK,LEN)
!*
%recordformat FNRECF(%integer FPTR,LINK1,HEAD,PCT)
!*
%recordformat TERECF(%shortinteger MODE,LOOP,
                      %integer CHAIN,DISP1,INDEX,
                      %shortinteger COORD,FLAGS)
!*
%recordformat DTRECF(%shortinteger MODE,IDENT,
                      %integer CHAIN,DISP2,
                      %shortinteger FLAGS,INDEX,
                     (%integer LOOP %OR %record(RESF) CONST))
!*
!*
!***********************************************************************
!* TRIAD record format                                                 *
!***********************************************************************
!*
%recordformat TRIADF(  %C
               %byteinteger OP,
               (%byteinteger USE %OR %byteinteger VAL2),
               %shortinteger CHAIN,
               (%record(RESF) RES1      %OR     %C
               (%shortinteger OPD1,%byteinteger QOPD1,MODE  %OR  %C
               (%integer SLN %OR %integer VAL1))),
               (%record(RESF) RES2      %OR   %C
                %shortinteger OPD2,%byteinteger QOPD2,MODE2))
!*
!***********************************************************************
!* COM record format                                                   *
!***********************************************************************
!*
%recordformat COMFMT(%integer CONTROL,OPT,OPTIONS1,OPTIONS2,PTRACE,
      ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR,
      MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD,
      SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST,
      RESCOM1,RESCOM2,F77PARM,FNO,FAULTY,LINEST,CMNIIN,SFMK,
      LISTL,LISTSTREAM,DIAGSTREAM,LISTMODE,XREF,
      PACKCMN,ITSMODE,PATHANAL,CHARACTER CODE,SPACE CHAR,
      HEADINGS,ARRAYCHECKS,JBRMODE,MESSLEN,NAMESLEN,
      NEXTCH,FUNRESDISP,WARNCOUNT,INP,MAXINP,MESSCOUNT,
      UNASSPATTERN,LISTCODE,PI21INT,DOPTR,SUBPROGPTR,
      FNLST,LAB,NAMESFREE,ALGOLREF,FIRSTSTATNUM,CEXPDICT,
      COMMONBASE,FASTPROLOGUE,STATEMENT,IFPTR,
      CNSTCA,COMMENTCNT,ADIDENT,ADERRIDEN,
      ADEXT,MAXDICT,MAXNAMES,MAXOUTPUT,MAXEXT,
      ACOMP,ASUBNAMES,MAXPSTACK,
      ATRIADS,TRFILEID,TRBLOCK,CMNCNT,SCANONLY,NOISY,
      MAXANAL,MAXGEN,SAVEANAL,SAVEGEN,OPTFLAGS,NEXTBIT,
      ACMNBITS,NEXTTEMP,ASSGOTOS,TMPPTR,DESTEMPS,OBJADDR,
      AREAADDR,PASTART,ADOPTDATA,TMINDEX,VRETURN,ENTRIES,
      EQUCHK,LABWARN,LINENO,MAXIBUFF,
      COMMENTS,DIAGLEVEL,WARNNOT77,WARNLENGTH,ALLOWUNIX,ALLOWVAX,
      ONETRIP,HOST,TARGET,MONERRS,CODECA,
      GLACA,DIAGCA,SSTCA,GSTCA,CONSTCA,SCALARCA,IOAREACA,ZGSTCA,STACKCA,
      W1,W2,W4,STATORDERMODE,CURSTATCLASS,LISTPOINT,STACKBASE,
      NEXTTRIAD,ASAVE,MAXSAVE,SUBTAB,LASTSUBTAB,
      INHIBOP4,ARGCNT,IDCNT,LABCNT,TMLIST,MAINPROG,PROCINDEX,CONSOLE)
!*
!***********************************************************************
!* record format for communicating with optimiser                      *
!***********************************************************************
!*
%recordformat OBJFMT(%string(35) MODULE,%integer MAINEP,I,J,K,
                     ADATE,ATIME,OPTIONS2,EXTPROCS,ATRIADS,MAXTRIADS,
                     ABLOCKS,MAXBLOCKS,ALOOP,MAXLOOP,ATABS,MAXTABS,
                     SRFLAGS,INHIBMASK,OPT,OPTFLAGS,OPTDESC0,OPTDESC1,
                     D1,D2,D3,D4)
!*
!***********************************************************************
!*
!*
%RECORDFORMAT SUBRECF(%INTEGER LINK,FLAGS,TRIADS,DICT,NAMES,PTRS,PROG,
      LABCNT,ARGCNT,IDCNT,TRCNT,REFSCNT,SUBSCNT,
      DPTR,NEXTTRIAD,NAMESFREE,NEXTBIT,SUBPROGTYPE,SUBPROGPTR,
      CBNPTR,SCPTR,CMNIIN,FUNRESDISP,CMNCNT,ASSGOTOS,VRETURN,ENTRIES,
      TMLIST,ALABS,ALHEADS,NEXTPLAB,
      %STRING(32) NAME,%INTEGERARRAY COORDS(0:15))
!*
%CONSTINTEGER SUBSIZE=232
%CONSTINTEGER LABSIZE=128
%CONSTINTEGER LHEADSIZE=620
!*
!*
!*
!***********************************************************************
!* Exports                                                             *
!***********************************************************************
!*
%integerfnspec FORT77 (%integer Control,Options1,Options2,F77parm,
                           Optflags,Srflags,Console,Liststream,Diagstream,
                           Diaglevel,Dsize,Tsize,Bsize,Lsize,Asize,Sp2)
%routinespec Dicful
%routinespec Namesful
%routinespec Extful
%routinespec F77abort(%integer N)
%integerfnspec Outputful
%integerfnspec Analful
%integerfnspec Genful
!*
%owninteger CurDsize,CurTsize,CurBsize,CurLsize,CurAsize,curSsize
!***********************************************************************
!* Imports                                                             *
!***********************************************************************
!*
%externalroutinespec Codegen(%integer Cgenep,
                             %record(Triadf)%arrayname Triads,
                             %integer Comad)
%externalintegerfnspec Analstart(%record(Triadf)%arrayname Triads,
                                 %integer Comad,%integername Count)
%EXTERNALROUTINESPEC INIT ALLOC (%INTEGER MODE, COMAD, REL, AVERS)
%externalroutinespec Init Num(%integer Comad)
%externalroutinespec F77area(%integer index,size,%integername ad)
%externalroutinespec Free(%integer byteaddress)
!*
%externalroutinespec Op4 Init(%integer Comad)
%externalroutinespec op4 Init1(%integer Comad)
%externalintegerfnspec Op4 Subprog
%externalroutinespec Reset Oplist
%externalroutinespec Lfault(%integer N)
%externalroutinespec Op4 Resetanal
!*
%externalroutinespec Optsource(%integer a,b,c,d,e,f)
%externalroutinespec Optctl(%integer Acom,Nexttr,Bits,Assgotos)
%if Target=gould %thenstart
   %externalroutinespec mcodeon
%finish
!*
!***********************************************************************
!* OWN variables                                                       *
!***********************************************************************
!*
%owninteger ComCONTROL,OPT,OPTIONS1,OPTIONS2,PTRACE,
      ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR,
      MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD,
      SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST,
      RESCOM1,RESCOM2,F77PARMS,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,ComHOST,ComTARGET,MONERRS,TRANSMTM,
      GLACA,PLTCA,SSTCA,GSTCA,CONSTCA,SCALARCA,IOAREACA,ZGSTCA,STACKCA,
      ComW1,ComW2,ComW4,STATORDERMODE,CURSTATCLASS,LISTPOINT,STACKBASE,
      NEXTTRIAD,ASAVE,MAXSAVE,SUBTAB,LASTSUBTAB,
      INHIBOP4,ARGCNT,IDCNT,LABCNT,TMLIST,MAINPROG,PROCINDEX,ComCONSOLE,
      NEXTSAVE
!*
%ownrecord(Objfmt) Obj
%ownrecord(Comfmt)%name Com
%owninteger Comad
!*
!*
%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
!*
!
%EXTERNALINTEGERFN FORT77 (%INTEGER CONTROL, OPTIONS1, OPTIONS2, F77PARMS, OPTFLAGS, %C  
   SRFLAGS, CONSOLE, LISTSTREAM, DIAGSTREAM, DIAGLEVEL, DSIZE, TSIZE, BSIZE, LSIZE, ASIZE, SP2)
%ownrecord(Triadf)%arrayformat Trform(0:10000)
%ownrecord(Triadf)%arrayname Triads
%integer Diclen,Maxtriads,Maxblocks,Maxloops
%integer I,J,K,F,Count
%string(63) S
!*
      Com==record(addr(ComControl))
      %if Target=gould %thenstart
         %if Control&X'4000'#0 %then mcodeon
      %finish
      Comad=addr(Com_Control)
!*
!******  Host dependent data
!*
      Com_Host=HOST
      Com_W1=W1
      Com_W2=W2
      Com_W4=W3
!*
!******
!*
      Com_Messlen=1
!*
!******* ESTABLISH Com_Options
!*
      Com_Control = Control
      Com_Options1=Options1
      Com_Options2=Options2
      F77parms=F77parms!2;! inhibit argument checks
      Com_F77parm=F77PARMS
      Com_Opt=(Com_Options1>>20)&15
      %if Com_Opt#0 %then Com_F77parm=Com_F77parm!X'17';! all checks off
      Com_Optflags=Optflags
      Obj_Srflags=Srflags
      Obj_Inhibmask=0
      %if Host=IBM %thenstart
         Com_Liststream=Liststream
         Com_Diagstream=Diagstream
         Com_Console=Diagstream
      %finishelsestart
         Com_Liststream=Liststream
         Com_Diagstream=Diagstream
         Com_Console=Console
      %finish
      Com_Noisy=1;! report routine name to diagstream
      %if Srflags#0 %thenstart
         printstring("       SRFLAGS = X")
         Prhex(Srflags)
      %finish
!*
      %if Dsize=0 %then Dsize=128
      %if Dsize<16 %then Dsize=16
      %if Dsize>128 %then Dsize=128
    CurDsize = Dsize
!*
      %if Tsize=0 %then Tsize=256
      %if Tsize<32 %then Tsize=32
!      %if Tsize>256 %then Tsize=256
     CurTsize=Tsize
!*
      %if Bsize=0 %then Bsize=128
      %if Bsize<16 %then Bsize=16
!      %if Bsize>128 %then Bsize=128
     CurBsize=Bsize
!*
      %if Lsize=0 %then Lsize=32
      %if Lsize<1 %then Lsize=1
!      %if Lsize>16 %then Lsize=16
     CurLsize=Lsize

%if asize=0 %then asize=256
%if asize<16 %then asize=16
!%if asize>256 %then asize=256
CurAsize=Asize


!*
      Diclen=Dsize<<10
      Dsize=Dsize<<10
!*
      Tsize=Tsize<<10
      Maxtriads=Tsize//12
!*
      Maxblocks=Bsize<<10
      Bsize=Bsize<<10
!*
      Maxloops=Lsize<<10
      Lsize=Lsize<<10
    asize=asize<<10

!*
      Com_Objaddr=addr(Obj)
      F77area(0,Dsize,Com_Adict);! T#DICT
      %IF COM_ADICT < 1 %THEN %RESULT = -COM_ADICT
      Com_Diclen=Diclen
      F77area(1,X'c000',Com_Anames);! T#NAMES
      %IF COM_ANAMES < 1 %THEN %RESULT = -COM_ANAMES
      Com_Nameslen=x'2000'
      Com_Adoutput=Com_Anames+X'2000'
      Com_Maxoutput=4000
      Com_Saveanal=Com_Anames+X'6000'
      Com_Maxanal=X'4000'
      Com_Savegen=Com_Anames+X'a000'
      Com_Maxgen=X'2000'
      f77area(2,Tsize,Com_Atriads);! T#TRIADS
      %IF COM_ATRIADS < 1 %THEN %RESULT = -COM_ATRIADS
      Com_Maxtriads=Maxtriads
      %if Com_Opt&1#0 %thenstart
         F77area(3,Bsize,Obj_Ablocks);! T#BLOCKS
         %IF OBJ_ABLOCKS < 1 %THEN %RESULT = -OBJ_ABLOCKS
         Obj_Maxblocks=Maxblocks
         F77area(4,asize,Obj_Atabs);! T#TABS
         %IF OBJ_ATABS < 1 %THEN %RESULT = -OBJ_ATABS
         Obj_Maxtabs=asize ;!X'8000'
         F77area(5,Lsize,Obj_Aloop);! T#LOOPS
         %IF OBJ_ALOOP < 1 %THEN %RESULT = -OBJ_ALOOP
         Obj_Maxloop=Maxloops
      %finish
      %if Com_Opt&2#0 %thenstart
         F77area(6,X'40000',Com_Asave);! T#SAVE
         Com_Maxsave=X'40000'
      %finish
      Triads==array(Com_Atriads,Trform)
!*
      Com_Allowvax=0
      Com_Allowunix=0
!*
      %if Host=IBM %thenstart
         %if Com_Control&2=0 %thenstart;! listing required
            %if Liststream>=0 %and Diagstream>=0 %then Com_Listmode=1  %c
                                                 %else Com_Listmode=2
            Com_Listl=1
         %finishelsestart
            Com_Listmode=0
            Com_Listl=0
         %finish
      %finishelsestart
         %if Com_Control&2=0 %thenstart;! listing required
            Com_Listl=1
set:        %if Diagstream>0 %and Liststream>0 %thenstart
               Com_Listmode=2
            %finishelsestart
               Com_Listmode=1
               %if Diagstream<0 %then Com_Diagstream=-Diagstream
               %if Liststream<0 %then Com_Liststream=-Liststream
            %finish
            selectoutput(Com_Liststream)
         %finishelsestart
            Com_Listl=0
            %if Com_Control&X'4000'#0 %then ->set  {code listing required}
            Com_Listmode=0
            %if Diagstream<0 %then Com_Diagstream=-Diagstream
            Com_Liststream=Com_Diagstream
            selectoutput(Com_Diagstream)
         %finish
         Com_Console=Com_Diagstream
      %finish
      Com_Xref=(Com_Control&X'800')>>11
      Com_Scanonly=(Com_Options1&X'20')>>5
      %if Com_Control&X'400000'#0 %thenstart;! EBCDIC
         Com_Character Code=1
         Com_Space Char=X'40'
      %finishelsestart;! ISO
         Com_Character Code=0
         Com_Space Char=X'20'
      %finish
      Com_Itsmode=0
      Com_Unasspattern=X'81818181'
      %if Com_Control&X'10'#0 %then Com_F77parm=(Com_F77parm)!X'7'
                                 ! nochar,noarg,nochar (NOCHECK)
      %if Com_Control&X'20'#0 %then Com_F77parm=Com_F77parm!X'10'
                                ! nobound (NOARRAY)
!*
      %if Com_F77parm&X'F'#7 %and Diaglevel<0 %then Diaglevel=0;! to ensure some diags available
      %if Diaglevel<0 %then Com_Control=Com_Control!X'10000';! to minimise overhead
      Com_Diaglevel=Diaglevel
!*
      %if Com_F77parm&X'8'#0 %then Com_Arraychecks=YES  %C
                              %else Com_Arraychecks=NO
!*
      %if Com_Options1&X'10'#0 %then Com_Optflags=Com_Optflags!32;! oplist
      Obj_Optflags=Com_Optflags
!*
      Com_Pathanal=Com_Control&X'80';! PROFILE BIT
!*
      Init Alloc(0,Comad,Rel<<16!Vers,addr(Version))
      Init Num(Comad)
!      %if Com_Listl#0 %thenstart
!         newline
!         printstring(Version)
!         newlines(2)
!      %finish
!*
      Com_Lineno=-1
      Com_Linest=0
      Com_Warncount=0;! individual counts for each subprog
      Com_Messcount=0
      Com_Commonbase=0
      Com_Headings=0
      Com_Mainprog=0;! set after a main program - used to check multiples
      Com_Procindex=0;! used to default main prog out of position for Opt3
      Com_Adoptdata=0;! will be set non-zero on entry to optimiser
!*
      Count=0
!*
      %if Com_Opt&2#0 %thenstart
         Op4 Init(Comad)
         Op4 Init1(Comad)
      %finish
!*
      I=Analstart(Triads,Comad,Count)
!*
      %if Com_Opt&2#0 %and Com_Fno=0 %thenstart
!printstring("
!Subtab  Lastsubtab  Nextsave ")
!write(Com_Subtab,4)
!write(Com_Lastsubtab,4)
!write(Com_Nextsave,4)
!newlines(2)
!dump(Com_Asave,Com_Nextsave)
         %if Obj_Optflags&32#0 %then Reset Oplist
         %cycle
            %if Com_Fno#0 %or Com_Faulty#0 %then %exit
            J=Op4 Subprog
            %if J=-3 %then Lfault(347);! recursion
            %if J<=0 %then %exit
            Op4 Resetanal
            %if Com_Opt&1#0 %thenstart
               Optctl(Comad,Com_Nexttriad,32,Com_Assgotos)
            %finish
               %IF OBJ_OPTFLAGS&X'10000'#0 %THENSTART;! DIS=OPLIST
                  SELECTOUTPUT(COM_DIAGSTREAM)
                  OPTSOURCE(COM_ADICT,COM_ANAMES,COM_ATRIADS,   %C
                            COM_DESTEMPS,COM_ADOPTDATA,COM_TMLIST)
                  SELECTOUTPUT(COM_LISTSTREAM)
               %FINISH
               %IF OBJ_OPTFLAGS&32#0 %THENSTART
                  NEWPAGE
                  COM_HEADINGS=1
                  %IF COM_TMINDEX=0 %THEN COM_TMLIST=0
                  OPTSOURCE(COM_ADICT,COM_ANAMES,COM_ATRIADS,    %C
                            COM_DESTEMPS,COM_ADOPTDATA,COM_TMLIST)
               %FINISH
            Codegen(3,Triads,Comad)
         %repeat
      %finish
!*
      %if I#0 %then Codegen(I,Triads,Comad)
!*
      %if Host=PERQPNX %thenstart
         Free(Com_Adict<<1)
         Free(Com_Anames<<1)
         %if Com_Opt&1#0 %thenstart
            Free(Obj_Ablocks<<1)
            Free(Obj_Atabs<<1)
            Free(Obj_Aloop<<1)
         %finish
      %finishelsestart
         Free(Com_Adict)
         Free(Com_Anames)
         %if Com_Opt&1#0 %thenstart
            Free(Obj_Ablocks)
            Free(Obj_Atabs)
            Free(Obj_Aloop)
         %finish
      %finish
      %if Com_Faulty=0 %then %result=Com_Linest  %c
                       %else %result=-Com_Faulty
%end;! PNXFort77
!*
%routine Abort(%string(63) S, %integer cursize,maxsize,IDletter)
      printstring("
***Compilation aborted due to ")
      printstring(S)
      printstring(" table overflow
***This may be avoided by reducing the size or complexity of the subprogram
***currently being compiled
")
   %if cursize#maxsize  %and IDletter#'s' %start
      printstring("*** Alternatively the table size may be increased from the current 
***")
    write(cursize,1)
    printstring(" Kb towards a maximum of")
    write(maxsize,1)
    printstring(" Kb by use of the compiler option -N")
    printsymbol(IDletter)
   printstring("(numKb)")
%finish
!deleteobjectfile
      newline
      %stop
%end;! Abort
!*
%externalroutine Dicful
      Abort("Dictionary",CurDsize,128,'d')
%end
!*
!*
%externalroutine Namesful
      Abort("Name",0,0,0)
%end
!*
%externalroutine Extful
      Abort("Externals",0,0,0)
%end
!*
%externalroutine F77abort(%integer N)
   %if N=1 %then Abort("Triad",CurTsize,10000,'t')
   %if N=2 %then Abort("Block",CurBsize,10000,'b')
    %if N=3 %then Abort("Loop",CurLsize,10000,'l')
   %if N=4 %then Abort("Tab",CurAsize,10000,'a')
   %if N=5 %then Abort("Com_Saveanal",0,0,0)
   %if N=5 %then Abort("Asave",Curssize,10000,'s')
   Abort("???",0,0,0)
%end;! F77abort
!*
%externalintegerfn Outputful
%result=1
%end
!*
%externalintegerfn Analful
%result=1
%end
!*
%externalintegerfn Genful
%result=1
%end
!*
!*
%endoffile