!* 26/11/85 use Com_Statordermode to identify missing ends
!*
{\VAX}%include "ftn_ht"
{\VAX}%include "ftn_fmts1"
{\VAX}%include "ftn_consts2"
{\VAX}%include "ebits_ecodes1"
{\VAX}%include "ebits_especs1"
!*
!{VAX}%include "ht.inc"
!{VAX}%include "fmts1.inc"
!{VAX}%include "consts1.inc"
!{VAX}%include "ecodes1.inc"
!{VAX}%include "especs1.inc"
!*
!***********************************************************************
!* Exports                                                             *
!***********************************************************************
!*
%routinespec Initend(%integer Ep,Info)
%routinespec Subprogend(%integer Mode,Epilogue)
%routinespec Finish(%integer Mode)
!*
!***********************************************************************
!* Imports                                                             *
!***********************************************************************
!*
%externalintegerfnspec Newlistcell(%integername Head,%integer N)
%externalroutinespec Lfault(%integer Er)
%externalintegerfnspec Stack Space(%integer Len)
%externalroutinespec Alloc(%integer Ptr)
%externalintegerfnspec Tidy Data(%integer Ep,IIN,Len)
%externalroutinespec Map(%integer Attr,Xref,Maps,Area5offset,Comad)
%externalroutinespec Tfault(%integer Er,Adid,Ader)
!*
%routinespec Copypars(%integer Arec,Inout,%integername Stackptr)
!*
!***********************************************************************
!* own variables                                                       *
!***********************************************************************
!*
%ownrecord(Comfmt)%name Com
%owninteger Adict,Anames
!*
%owninteger Result Words
%owninteger Param Words
%owninteger Linenoword
!*
%ownbyteintegerarray Tplate(0:255)
!*
%ownintegerarray Areasizes(0:10)
!*
%externalroutine Init End(%integer Ep,Info)
%integer I
      %if Ep=0 %thenstart;! at start of compilation
         Com==record(Info)
         Adict=Com_Adict
         Anames=Com_Anames
         %cycle I=0,1,10
            Areasizes(I)=0
         %repeat
         %return
      %finish
      %if Ep=1 %thenstart;! at start of procedure
         Linenoword=Info
         %return
      %finish
%end;! Init End
!*
!%integerfn Setmode(%integer T)
!***********************************************************************
!* convert size/type to mode                                           *
!***********************************************************************
!%constbyteintegerarray Mode(0:40) = 0(8),
!   0(3),15, 0, 1, 2, 0,  {byte,integer}
!   0(5),       3, 4, 5,  {real}
!   0(5),       6, 7, 8,  {complex}
!   0(3), 9,10,11,12, 0,  {logical}
!   13                    {character}
!*
!      %result=Mode((T&7)<<3!T>>4)
!%end {Setmode}
!*
!******************************************************************************
!*                                                                            *
!*        OBJECT FILE RED TAPE AND DIAGNOSTIC TABLES                          *
!*                                                                            *
!******************************************************************************
!*
%routine Putdiag(%integer N)
      Ed4(DIAGS,Com_Diagca,N)
      Com_Diagca=Com_Diagca+4
%end;! Putdiag
!*
%routine Putdiag22(%integer H1,H2)
      Ed4(DIAGS,Com_Diagca,(H1<<16)!H2)
      Com_Diagca=Com_Diagca+4
%end;! Putdiag
!*
%routine Diagbytes(%integer Ad,L)
      Edbytes(DIAGS,Com_Diagca,L,Ad)
      Com_Diagca=Com_Diagca+L
%end;! Diagbytes
!*
%routine Loaddata
%routinespec Putname(%integer Ad)
%integerfnspec Getlen
%integerfnspec Getaddr
%integer  I, J, K, REFAD, STARTST,DIAGLEVEL,H0,H1
%integer QPTR,PPTR,CNT,CNTLOC,Scale
%integer PTR
%integer AD,LEN
%record(SRECF)%name SS
%record(PRECF)%name PP
%record(PRECF)%name QQ
%record(ARRAYDVF)%name DVREC
!*
      %IF COM_FNO#0 %THEN %RETURN;! avoid possibility of size errors if > 32K
!*
      Diaglevel=Com_Diaglevel
!*
      %if Diaglevel<0 %then %return
!*
!******* SYMBOL TABLES
!*
      %IF COM_SUBPROGTYPE=5 %THEN %return;! BLOCKDATA
      Putdiag(M'####')
      PUTDIAG(Linenoword);! @ ON STACK OF CURRENT LINE NO
      Putdiag(0);! for flags
      PP == RECORD(ADICT+COM_SUBPROGPTR)
      %if Diaglevel>2 %then I=Diaglevel %else I=0
      PUTDIAG22(I,(PP_TYPE<<8)!COM_SUBPROGTYPE)
      PUTNAME(PP_IDEN)
      CNTLOC=Com_Diagca
{      PUTDIAG(0);! FOR LOCAL IDEN COUNTS}
      Com_Diagca=Com_Diagca+4
      CNT=0
      %if Diaglevel>0 %thenstart;   ! FULL DIAG TABLES REQUESTED
         %IF COM_SUBPROGTYPE=2 %THENSTART;! FUNCTION, SO PUT ENTRY IN DIAGS LIST
            PUTDIAG22(PP_TYPE<<8!PP_IIN,Getlen)
            Putdiag(Getaddr)
            PUTNAME(PP_IDEN)
            CNT=CNT+1
         %FINISH
         PTR = COM_SCPTR
         %WHILE PTR # 0 %CYCLE;      ! THROUGH LOCAL SCALAR LIST
            PP == RECORD(ADICT+PTR)
            I=PP_TYPE<<8
            %IF PP_CLASS&4#0 %THENSTART;! ARRAY
               %unless Diaglevel>2 %then -> Locals Loop
               DVREC==RECORD(ADICT+PP_ADDR4)
               H0=I!X'0020'!SCALARS;! array, desc in SCALARS
               H1=Getlen
               J=DVREC_ADDRDV
            %FINISHELSESTART; !SCALAR
               H0=I!PP_IIN
               H1=Getlen
               %if PP_Class=1 {%and PP_X0&1=0} %thenstart;! param by reference
                  H0=H0!X'0080'
                  Scale=0
               %finish
               J=Getaddr
            %FINISH
            Putdiag22(H0,H1)
            PUTDIAG(J)
            PUTNAME(PP_IDEN)
            CNT=CNT+1
Locals Loop:PTR = PP_LINK2
         %REPEAT
         Ed4(DIAGS,CNTLOC,CNT);! LOCALS COUNT
         CNT=0
!*       O/P COMMON SCALARS
         %if Diaglevel>1 %thenstart
            QPTR = COM_CBNPTR
            %WHILE QPTR # 0 %CYCLE;     ! THROUGH COMMON BLOCKS
               QQ == RECORD(ADICT+QPTR)
               %IF QQ_CMNREFAD=0 %OR QQ_LINK2=0 %THEN ->NEXTCMN2
               PUTDIAG(M'****')
               PUTDIAG(QQ_CMNREFAD)
               PUTNAME(QQ_IDEN)
               CNTLOC=Com_Diagca
{               PUTDIAG(0);! FOR COMMON BLOCK IDEN COUNT}
               Com_Diagca=Com_Diagca+4
               PPTR = QQ_LINK2;          ! LINK TO FIRST ITEM
               %WHILE PPTR # 0 %CYCLE;   ! UNTIL LAST ITEM
                  PP==RECORD(ADICT+PPTR)
                  I=PP_TYPE<<8
                  %IF PP_X1&1#0 %THENSTART
                     %IF PP_CLASS&4 # 0 %THENSTART;  ! ARRAY
                        %unless Diaglevel>2 %then ->Cmn Loop
                        DVREC==RECORD(ADICT+PP_ADDR4)
                        H0=I!X'0020'!SCALARS;! array, desc in SCALARS
                        H1=Getlen
                        J=DVREC_ADDRDV
                        %IF J=0 %THEN ->Cmn Loop
                     %FINISHELSESTART; !SCALAR
                        H0=I!11
                        H1=Getlen;! pseudo-iin to simplify diags
                        J=Getaddr
                     %FINISH
                     Putdiag22(H0,H1)
                     PUTDIAG(J)
                     PUTNAME(PP_IDEN)
                     CNT=CNT+1
                  %FINISH
Cmn Loop:          PPTR = PP_LINK2;       ! LINK TO NEXT ITEM IN COMMON
               %REPEAT
               Ed4(DIAGS,CNTLOC,CNT)
               CNT=0
NEXTCMN2:      QPTR = QQ_ADDR4;          ! LINK TO NEXT COMMON BLOCK
            %REPEAT
         %finish
      %finish
      Putdiag(-1)
      %return
!*
%ROUTINE PUTNAME(%INTEGER AD)
%STRING(63) S
%INTEGER I
      AD=ANAMES+AD
      S=STRING(AD)
    {  S=Lowstring(S)  }
      I=LENGTH(S)
      I=((I+4)>>2)<<2
      DIAGBYTES(AD,I)
%END;! PUTNAME
!*
%integerfn Getlen
%integer L
      Scale=0
      %if PP_Type=CHARTYPE %then %result=PP_Len
      L=ModetoBytes(Setmode(PP_Type&X'3F'))
      %if PP_Type&X'F'=CMPLXTYPE %then L=L>>1
      %unless L=1 %then Scale=1
      %result=L
%end;! Getlen
!*
%integerfn Getaddr
      %result=PP_Addr4
%end;! Getaddr
%end;! Loaddata
!*
%ROUTINE TOTALS
%integer I,J
      Areasizes(1)=(Areasizes(1)+7)&(-8)
      PRINTSTRING("

Code ")
      WRITE(Areasizes(1),1)
      PRINTSTRING(" bytes   Gla ")
      J=0
      %cycle I=2,1,8
         J=J+Areasizes(I)
      %repeat
      J=J+Areasizes(10)
      WRITE(J,1)
      PRINTSTRING(" bytes   Total ")    
      Write(J+Areasizes(1),1)
      PRINTSTRING(" bytes

")
%END;! TOTALS
!*
%ROUTINE REPORT(%INTEGER I)
      NEWLINE
      %IF COM_FAULTY#0 %THENSTART
         WRITE(COM_FAULTY,3)
         PRINTSTRING(" error")
         %IF COM_FAULTY>1 %THEN PRINTSYMBOL('s')
         NEWLINE
      %FINISHELSESTART
         %IF I=1 %THENSTART;! listing file
            PRINTSTRING("  No errors")
            NEWLINE
         %FINISH
      %FINISH
      %IF COM_WARNCOUNT#0 %THENSTART
         WRITE(COM_WARNCOUNT,3)
         PRINTSTRING(" warning")
         %IF COM_WARNCOUNT>1 %THEN PRINTSYMBOL('s')
         NEWLINE
      %FINISH
      %IF COM_COMMENTCNT#0 %THENSTART
         WRITE(COM_COMMENTCNT,3)
         PRINTSTRING(" comment")
         %IF COM_COMMENTCNT>1 %THEN PRINTSYMBOL('s')
         NEWLINE
      %FINISH
      NEWLINE
      %IF COM_SCANONLY=YES %THENSTART
         PRINTSTRING("Syntax check ")
         %IF COM_FAULTY = 0 %THENSTART
            PRINTSTRING("successful

")
         %FINISHELSESTART
            PRINTSTRING("failed

")
         %FINISH
      %FINISH
%END;! REPORT
!*
%externalroutine Finish(%integer Mode)
!***********************************************************************
!* OUTPUT FINAL LPUT RECORD AND SUMMARY TO LISTING FILE AND STOP       *
!* MODE = 0  BETWEEN MODULES
!*        1  GENUINE END
!***********************************************************************
%INTEGER I,ER
!*
      %IF MODE=2 %THEN ->FAIL;! FOR AN EMPTY FILE
      %IF COM_SCANONLY=YES %THEN ->REP
!*
!********* SATISFY LOCAL REFS
      I=Tidy Data(2,0,0)
!*
      Areasizes(1)=Com_Codeca
      Areasizes(2)=Com_Glaca
      Areasizes(3)=0
      Areasizes(4)=Com_Sstca
      Areasizes(5)=Com_Gstca
      Areasizes(6)=Com_Diagca
      Areasizes(7)=Com_Scalarca
      Areasizes(8)=Com_Ioareaca
!*
!*
!!-- check if following is an adequate test -----------------
      %if Com_Statordermode>0 %thenstart
Fail:    Lfault(303);! END STATEMENT MISSING
      %finish
      COM_FAULTY = COM_FAULTY+COM_FNO
      COM_FNO=0
      %IF COM_FAULTY=0 %THENSTART
         Eterminate(addr(Areasizes(1)))
      {   %IF COM_LISTL#0 %THEN} TOTALS
      %FINISH
REP:  %if Com_Listmode=2 %thenstart
         selectoutput(Com_Liststream)
         Report(1)
      %finish
      SELECTOUTPUT(Com_Console)
      REPORT(0)
%end;! Finish
!*
%externalroutine Subprogend(%integer Mode,Epilogue)
!***********************************************************************
!* called from phi(46) following recognition of end statement          *
!***********************************************************************
%record(PLABF)%name Plab
!*
%integer I,J,K,Curptr,Area,Ptr,Pptr,Er,Plab1,Fntype,Stackptr
%integer Epindex,Entryno Word,Pstart
%record(PRECF)%name PP
%record(PRECF)%name QQ
%record(SRECF)%name SS
%record(ARRAYDVF)%name Dvrec
%record(PRECF)%name Cmnblk
%string(63) S
      %if Com_Scanonly=YES %then %return
!*
!*
{      %if Com_Entries>0 %thenstart;! there are side entries }
{         Elabel(Epilogue)                                   }
{         Entryno Word=Stack Space(4)                        }
{         Estkdir(0,Entryno Word,0,4)                        }
{         Eswitch(0,Com_Entries,999999,-1,Com_Sstca)         }
{         Efswitchjump(999999)                               }
{      %finish                                               }
!*
      %unless Com_Subprogtype=5 %thenstart;! prologue,epilogue
!*
         Elabel(Epilogue);! Adequate at this point unless copy-in, copy-out
         Copypars(Com_Subprogptr,1,Stackptr);! to set result of functions
         Eop(RETURN)
!*
!******  process each entry point
!*
         Curptr = Com_Subprogptr
         Epindex=0
         %while Curptr#0 %cycle
            PP==record(Adict+Curptr)
            Stackptr=0
            I=PP_Type
            Fntype=I&15
            %if Com_Subprogtype=2 %thenstart;! fn
               %if Fntype=CHARTYPE %then Stackptr=8 %elsestart
                  %if Fntype=CMPLXTYPE %then Stackptr=4 
               %finish
            %finish
            Pstart=Stackptr
            S=string(Com_Anames+PP_Iden)
            { S=Lcstring(S)}
            %if Epindex=0 %thenstart
               Elabel(100000);! start of prologue of main entry
            %finish
            Eentry(Epindex,-1,-1,Com_Stackca,Com_Diagca,S)
            Epindex=Epindex+1
!*
            %unless Com_Subprogtype=1 %then Copypars(Curptr,0,Stackptr);! copy in
{            %if Com_Entries>0 %thenstart                    }
{               Estklit(Epindex)                             }
{               Estkdir(0,Entryno Word,0,4)                  }
{               Eop(Estore)                                  }
{            %finish                                         }
            Plab==record(Adict+PP_Disp<<DSCALE)
            Ejump(JUMP,Plab_Index+100000);! to start of executable code
{            %if Com_Entries>0 %thenstart                    }
{               Elabel(1000000+Epindex)                      }
{               Eswitchlabel(999999,Epindex,1000000+Epindex) }
{               Epindex=Epindex+1                            }
{            %finishelse Elabel(Epilogue)                    }
{            %if Com_Subprogtype#1 %thenstart                }
{               Stackptr=Pstart                              }
{               Copypars(Curptr,1,Stackptr);! copy out       }
{            %finish                                         }
{            Eop(RETURN)                                     }
            Curptr=PP_Link3<<DSCALE;! to next entry point
         %repeat
      %finish
!*
!*****COMMON AREAS - DEFINE IN BLOCKDATA, OTHERWISE REFERENCE
!*
      I=Com_Equchk
      %while I#0 %cycle
         SS==record(Adict+I)
         Alloc(SS_Inf0)
         I=SS_Link1
      %repeat
!*
      PPTR = COM_CBNPTR
      %WHILE PPTR # 0 %CYCLE
         PP == RECORD(ADICT+PPTR);    ! MAPS TO COMMON BLOCK RECORD
         PTR = PP_LINK2;             ! LINK TO FIRST ITEM IN COMMON AREA
         %IF PTR#0 %THENSTART;! CHECK NEC. IN CASE ERR IN DECL.
            QQ==RECORD(ADICT+PTR)
            ALLOC(PTR)
            PP == RECORD(ADICT+PPTR);    ! BACK TO COMMON BLOCK
            I=Tidy Data(1,QQ_IIN,(PP_CMNLENGTH+7)&X'FFFFF8')
         %FINISH
         PPTR = PP_ADDR4;              ! LINK TO NEXT COMMON BLOCK NAME
      %REPEAT
!*
   {  %if Com_F77parm&x'10000000'#0 %then Sdbdata  }
      Loaddata
      %unless Com_Subprogtype=5 %then Eprocend(Com_Stackca,Com_Diagca,-1)  
!*
      Com_Subprogtype = -1
      Com_Statordermode=0;! to allow 'missing end' test
!*
      %if Com_Control&X'8800'#0 %thenstart;! ATTR/XREF
         Map(1,Com_Xref&1,0,0,Addr(Com_Control))
      %finish
!*
      {possible statement map}
!*
%end;! Subprogend
!*
%routine Copypars(%integer Arec,Inout,%integername Stackptr)
{%routinespec Set Entry Template(%integer Arec) }
%routinespec Param Array(%integer Stackptr,Paramrec,Lenptr)
%routinespec Set P Desc(%integer Op)
%record(Precf)%name Entry
%record(Precf)%name Param
%record(Srecf)%name SS
%record(Precf)%name PP
%integer I,J,K,Short,Complex,Op,Ptr,Mode,IIN
%integer Descad,Match,Pclass,Ad,Ptype,Pct,Lct,Bytes
%integer Arraylist
%switch R(0:15)
!*
     {%if Inout=0 %and Com_F77parm&2=NO %then Set Entry Template(Arec) }
      Arraylist=0
     %if Inout=1 %and  Com_Vreturn#0 %thenstart
         Ef77op(EFSETVR)
         Eop(EINTRES)
      %finish
      Entry==record(Adict+Arec)
      %if Inout=0 %thenstart;! using ref only copy-in is required
         K=Entry_Link2;! link to param pointers
         %while K#0 %cycle
            SS==record(Adict+K);! 2-word param ptr chain
            K=SS_Link1
            Ptr=SS_Inf0
            Param==record(Adict+Ptr)
            Alloc(Ptr)
            IIN=Param_IIN
            Pclass=Param_Class
            Ptype=Param_Type
            %if Pclass=9 %thenstart;! procedure param
               %if Inout=0 %thenstart
                  %if IIN#0 %thenstart;! provided there is some reference
                     Estkpar(1,Stackptr,0,4)
                     Estkdir(IIN,Param_Addr4,0,4)
                     Eop(ESTORE)
                  %finish
               %finish
               ->next
            %finish
            %if Ptype=CHARTYPE %and Param_x0&1=0 %thenstart;! char scalar param
               %if Inout=0 %thenstart
                  %if IIN#0 %thenstart;! provided there is some reference
                     Estkpar(1,Stackptr+4,0,4);! @ (Amdahl)
                     Estkdir(IIN,Param_Addr4,0,4)
                     Eop(ESTORE)
                     Estkpar(1,Stackptr,0,4)
                     Ef77op(Earglen)
                     Estkdir(IIN,Param_Addr4+4,0,4);! len (Amdahl)
                     Eop(ESTORE)
                  %finish
               %finish
               Stackptr=Stackptr+4
               ->next
            %finish
            %if Pclass&4#0 %thenstart;! array
               %if Inout=0 %thenstart;! defer array processing until scalars
                                        ! have been dealt with. this allows
                                        ! for arrays with subs. params as
                                        ! adjustable dimensions
                  SS==record(Adict+Newlistcell(arraylist,3))
                  %if Ptype=CHARTYPE %thenstart
                     SS_Inf0=(Stackptr<<16)!(Stackptr+4);! len offset<<16 ! @ offset
                  %finishelse SS_Inf0=Stackptr
                  SS_Inf2=Ptr
               %finish
               %if Ptype=CHARTYPE %then Stackptr=Stackptr+4
               ->Next
            %finish
            Ad=Param_Addr4
%if target#GOULD %thenstart
            %if Param_x1&2#0 %or Param_X0&2#0 %thenstart;! ref or assignment
                Estkpar(1,Stackptr,0,4)
                Estkdir(IIN,Param_Addr4,0,4)
                Eop(ESTORE)
            %finish
%finishelsestart
   Param_Addr4=Stackptr
   Param_IIN=7
%finish
!*
Next:       Stackptr=Stackptr+4
         %repeat;! for all params
!*
         %while Arraylist#0 %cycle
            SS==record(Com_Adict+Arraylist)
            Param Array(SS_Inf0&X'FFFF',SS_Inf2,SS_Inf0>>16)
            Arraylist=SS_Link1
         %repeat
      %finish
!*
      %if Com_Subprogtype=2 %thenstart;! fn
         Ad=Com_Funresdisp
         IIN=Entry_IIN
         %if Inout=0 %thenstart;! copy in
            %if Entry_Type=CHARTYPE %thenstart;! 
               Estkpar(1,4,0,4);! @ for result (Amdahl)
               Estkdir(IIN,Entry_Addr4,0,4)
               Eop(ESTORE)
               Estkpar(1,0,0,4)
               Ef77op(Earglen)
               Estkdir(IIN,Entry_Addr4+4,0,4);! len (Amdahl)
               Eop(ESTORE)
            %finish
         %finishelsestart;! copy back
            Mode=Setmode(Entry_Type&X'3F')
            Bytes=Modetobytes(Mode)
            %if Mode=CHARMODE %then %return
            Estkdir(IIN,Entry_Addr4,0,Bytes)
            ->R(Mode)
!*
R(9):       ! l*1
R(15):      ! byte
R(0):       ! i*2
R(10):      ! l*2
R(1):       ! i*4
R(11):      ! l*4
            Eop(EINTRES)
            ->Set
R(3):       ! r*4
R(4):       ! r*8
R(5):       ! r*16
            Eop(EREALRES)
            ->Set
R(6):       ! c*8
R(7):       ! c*16
R(8):       ! c*32
            Estkparind(1,0,0,Bytes)
            Eop(ESTORE)
Set:
R(*):
         %finish
      %finish
      %return
!*
!*
!%routine Set Entry Template(%integer Arec)
!%integer Prec,Pcount,I,J,Class,Next,Tstart
!%record(Precf)%name Entry
!%record(Precf)%name PP
!%record(Srecf)%name SS
!      Entry==record(Adict+Arec)
!      %if Com_Subprogtype=3 %then I=1 %else I=Entry_Type
!      Tplate(1)=1;! mk no. to allow for future variations
!      Tplate(2)=I
!      Prec=Entry_Link2
!      Pcount=2
!      %while Prec#0 %cycle
!         SS==record(Adict+Prec)
!         %if SS_Inf0#0 %thenstart;! except for labels pro tem
!            PP==record(Adict+SS_Inf0)
!            Pcount=Pcount+1
!            I=PP_Type
!            %if PP_Class&8#0 %then I=X'80';! subprog
!            %if Pcount<256 %then Tplate(Pcount)=I
!         %finish
!         Prec=SS_Link1
!      %repeat
!      %if Pcount>255 %then Pcount=255
!      Tplate(0)=Pcount
!      %if Pcount&1=0 %thenstart
!         Pcount=Pcount+1
!         Tplate(Pcount)=0;! ensure 0 in byte which may fill to word boundary
!      %finish
!      Pcount=((Pcount+3)>>2)<<2;! round to 32 bit boundary
!      J=Com_Ioareaca
!      Pdbytes(IOAREA,J,Addr(Tplate(0)),Pcount)
!      Com_Ioareaca=Com_Ioareaca+Pcount
!!      PfixI(LGAW,IOAREA,J)
!!      PI(IPUSH)
!!      PI1(ILL,0);! link to calling stackframe
!!      PI(IPUSH)
!!      Parcheck
!%end;! Set Template
!*
%routine Param Array(%integer Stackptr,Paramrec,Lenptr)
!* following code is analogous to 2900 version, with
!*   ETOS   == Breg
!*   ETOS-1 == acc
%routinespec Dimop(%integer D,Mode)
%record(Arraydvf)%name Dvrec
%integer I,J,L,U,Adjust,Pct,Dvad,Ptype,Sum,M
%integer LC,UC,OP,Sum2,Bused,Accused,Chlen
      Param==record(Adict+Paramrec)
      Dvrec==record(Adict+Param_Addr4)
      Dvad=Dvrec_Addrdv
      Pct=Dvrec_Dims
      Ptype=Param_Type
!*
      Adjust=NO
      Bused=0
      Accused=0
      I=Dvrec_Numels
      %IF Ptype=CHARTYPE %thenstart
         Chlen=Param_Len
         %if Chlen=0 %thenstart
            Estkpar(1,Lenptr,0,4);! stack offset of length word
            Ef77op(Earglen)
            Estkdir(DVAREA,Dvad-8,0,4);! for transmitted el length
            %if Param_Class&X'40'=0 %thenstart;! no adj dims
               Eop(EDUPSTORE)
               Estklit(Dvrec_Numels)
               Eop(IMULT)
               Estkdir(DVAREA,Dvad+4,0,4);! save total size (bytes)
            %finish
            Eop(ESTORE)
         %finish
      %finish
!*
      %if Param_Class&X'40'=0 %then ->Setzeroad;! no adj dims
!*
      Adjust=YES
!*
      Sum=1;Sum2=0
      %cycle I=1,1,Pct
         %if Bused#0 %thenstart
            Estkdir(DVAREA,Dvad+I<<2,0,4)
            Eop(EDUPSTORE)
         %finish
         L=Dvrec_B(I)_L
         U=Dvrec_B(I)_U
         %if L>>30=2 %then LC=1 %else LC=0;! VAR ELSE CONST
         %if U>>30=2 %then UC=1 %else UC=0
         %if LC=0 %thenstart
            %if Bused=0 %thenstart
               %if I=1 %then Sum2=L %else Sum2=Sum2+L*Dvrec_B(I)_M
            %finishelsestart
               %if Accused=0 %thenstart
                  Eop(DUPL);! {acc=B}
                  %unless L=1 %thenstart
                     Estklit(L)
                     Eop(IMULT)
                  %finish
                  %unless Dvrec_Zerotofirst=0 %thenstart
                     Estklit(Dvrec_Zerotofirst)
                     Eop(IADD)
                  %finish
                  Eop(EXCH)
                 { acc=Sum2+B*lower }
               %finishelsestart
                  Estklit(L)
                  EF77op(EFDVACC);! acc=acc+B*lower; retain B
               %finish
               Accused=1
            %finish
            %if UC=0 %thenstart;! both const
               %if Bused#0 %thenstart;! already computing
                  Estklit(U-L+1)
                  Eop(IMULT);! B=B*(upper-lower+1)
               %finishelsestart
                  Sum=Sum*(U-L+1)
               %finish
            %finishelsestart;! upper is var
               %if U>>29=5 %then ->Star
               Dimop(U,0)
               %unless L=1 %thenstart
                  Estklit(L-1)
                  Eop(ISUB);! upper-lower+1
               %finish
               ->Eval B
            %finish
         %finishelsestart
            %if Accused=0 %thenstart
               %if I=1 %then Dimop(L,0) %else Estklit(SUM2)
               %if Bused#0 %then Eop(EXCH)
            %finish
            %if I#1 %thenstart
               %if Bused=0 %then Estklit(DVREC_B(I)_M)
               Dimop(L,0)
               Ef77op(EFDVACC)
            %finish;! acc=acc+B*lower
            Accused=1
            %if UC=0 %thenstart
               Estklit(U+1)
            %finishelsestart
               %IF U>>29=5 %then ->Star
               Dimop(U,0)
               Estklit(1)
               Eop(IADD)
            %finish
            Dimop(L,0)
            Eop(ISUB)
Eval B:     %if Bused=0 %thenstart
               %if I>1 %thenstart
                  Estklit(Sum)
                  Eop(IMULT);! B*Sum
               %finish
               Bused=1
            %finishelsestart
               Eop(IMULT)
            %finish
         %finish
      %repeat
!*
Star:
!*
      %if Bused#0 %thenstart
         %if Ptype=5 %thenstart
            Chlen=Param_Len
            %unless Chlen=1 %thenstart
               %if Chlen=0 %thenstart
                  Estkdir(DVAREA,Dvad-8,0,4)
               %finishelse Estklit(Chlen)
               Eop(IMULT)
            %finish
         %finish
         Estkdir(DVAREA,Dvad+4,0,4);! save total size (bytes)
         Eop(ESTORE)
      %finish
!*
Setzeroad:
!*
      Estkpar(1,Stackptr,0,4);! @ first
      Estkdir(DVAREA,Dvad,0,4);! @ first
      Eop(EDUPSTORE)
      %if Accused#0 %thenstart
         Eop(EXCH)
         %if Ptype=CHARTYPE %and Param_Len=0 %then I=12 %else I=8
         Estkdir(DVAREA,Dvad-I,0,4);! zerotofirst (els)    
         Eop(EDUPSTORE)                                     
         %if Ptype=CHARTYPE %thenstart
            Chlen=Param_Len
            %if Chlen#1 %thenstart
               %if Chlen=0 %thenstart
                  Estkdir(DVAREA,Dvad-8,0,4);! transmitted el len
               %finishelse Estklit(Chlen)
               Eop(IMULT)
            %finish
         %finishelsestart
            I=Dvrec_Ellength
            %if I>1 %thenstart
               Estklit(I)
               Eop(IMULT)
            %finish
         %finish   
         Eop(ISUB)
      %finishelsestart
         %if Ptype=CHARTYPE %thenstart
            Chlen=Param_Len
            %if Dvrec_Zerotofirst#0 %thenstart
               %if Chlen=0 %thenstart
                  Estkdir(DVAREA,Dvad-8,0,4);! transmitted el len
                  %if Dvrec_Zerotofirst#1 %thenstart
                     Estklit(Dvrec_Zerotofirst)
                     Eop(IMULT)
                  %finish 
               %finishelsestart
                  Estklit(Dvrec_Zerotofirst*Chlen) 
               %finish 
               Eop(ISUB)
            %finish 
         %finishelsestart
            I=Dvrec_Zerotofirst*Dvrec_Ellength
            %if I#0 %thenstart
               Estklit(I)   
               Eop(ISUB)
            %finish
         %finish
      %finish
      Estkdir(DVAREA,Dvad-4,0,4);! @ zero el
      Eop(ESTORE)
!*
      %return
!*
%routine Dimop(%integer Resw,Mode)
%routinespec Dimeval(%integer Disp)
%integer F,A,M,I,J,K,Ptr,Size
%record(Srecf)%name SS
%record(Precf)%name PP
%record(Resf) R
%switch S(0:7)
%string(32) Identifier,Erriden
      R_W=Resw
      %if Resw>>30#2 %thenstart
         M=0
         A=Resw
      %finishelsestart
         R_H0=R_H0&X'7FFF'
         A=R_H0
      %finish
      R_Form=R_Form&15
!*
      ->S(R_Form)
!*
S(1): A=integer(Adict+Resw);! int in dict
!*
S(0):      ! simple int
      Estklit(A)
      %return
!*
S(3):      ! param
S(4):      ! common scalar
S(5):      ! param or common (unknown when processed)
      A=A<<DSCALE
      Alloc(A)
      PP==record(Adict+A)
      Erriden=string(Anames+PP_Iden)
      Identifier=string(Anames+Param_Iden)
      %if PP_Class&2#0 %thenstart;! in common
         R_Form=CSCALID
      %finishelsestart
         R_Form=3;! in case it was 5
         Ptr=Entry_Link2;! param list
         %while Ptr#0 %cycle
            SS==record(Adict+Ptr)
            Ptr=SS_Link1
            %if A=SS_Inf0 %then ->Goodpar
         %repeat
         Tfault(250,addr(Identifier),addr(Erriden));! dim not param or in common
         %return
Goodpar:
      %finish
!*
      %if R_Mode>INT4 %thenstart
         Tfault(196,addr(Identifier),addr(Erriden));! adjustable dimension not integer
         %return
      %finish
!*
      %if R_Mode=INT2 %then Size=2 %else Size=4
      %if R_Form=3 %thenstart;! param
         Estkind(PP_IIN,PP_Addr4,0,Size)
      %finishelsestart
         Estkdir(PP_IIN,PP_Addr4,0,Size)
      %finish
      %if R_Mode=INT2 %thenstart
         Estklit(4)
         Eop(CVTII)      
      %finish      
      %return
!*
S(6):  ! temp loc
      Estkdir(0,A,0,4)
      %if Mode#0 %then Eop(ESTORE) 
      %return
!*
S(7): !dimension expression
      Dimeval(A<<DSCALE)
      %return
!*
%routine Dimeval(%integer Disp)
%constintegerarray Op(0:7)=0(2),IADD,ISUB,IMULT,IDIV,INEG,EPOWERI
%integer Cur,End,Ad
      Cur=Disp
      End=Cur+integer(Adict+Cur)
      Cur=Cur+W1
      %while Cur<End %cycle
         Ad=Adict+Cur
         Dimop(integer(Ad),0)
         Dimop(integer(Ad+W2),0)
         %if integer(Ad+W1)=7 %then Estklit(0);! for I ** I
         Eop(Op(integer(Ad+W1)))
         Cur=Cur+W4
         %if Cur<End %then Dimop(integer(Ad+W3),1);! store
      %repeat
%end
!*
%end;! Dimop
!*
%end;! Param Array
!*
%end;                                   ! Copypars
!*
!*
%endoffile