!                                                                       fmap1
! 10/10/86 - insert include files
!                                                                       ftnmap5
! 12/08/86 - NAMELIST to lower case
!                                                                       ftnmap4
!* modified 27/11/85
!*
%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                                                             *
!***********************************************************************
!*
%routinespec Map(%integer Attr,Xref,Maps,Area5offset,Comad)
!*
%OWNINTEGER ANAMES
%OWNINTEGER ADICT
%OWNSTRING(32) AREANAME
!************************************************** SATISFY REFS*****
!*
!*
%EXTERNALROUTINE MAP(%INTEGER ATTR,XREF,MAPS,AREA5 OFFSET,COMAD)
%INTEGER I, J, K
%INTEGERARRAY ALPHA, COUNT('A' : 'Z')
%RECORD(PRECF) %NAME PP
%ROUTINESPEC SORT
%ROUTINESPEC QKSORT(%STRING(*)%ARRAYNAME X, %C
        %INTEGERARRAYNAME PL, %INTEGER A, B)
%ROUTINESPEC PRINTOUT(%INTEGER L)
%INTEGER LHEAD
%RECORD(COMFMT)%NAME COM
      COM==RECORD(COMAD)
      LHEAD=COM_ADLHEAD
      ADICT=COM_ADICT
      ANAMES=COM_ANAMES
      NEWLINES(3)
      PRINTSTRING("Identifier          Attributes")
      %IF XREF#0 %THEN   %C
         PRINTSTRING("                               References")
      NEWLINE
      %CYCLE I = 'A',1,'Z'
         ALPHA(I) = 0
         COUNT(I) = 0
      %REPEAT
      SORT;                          ! TO ALPHABETIC LISTS
      K = 0;                         ! COUNT OF NO OF ENTRIES PRINTED ON CURRENT LINE
      %CYCLE I = 'A',1,'Z'
         J = COUNT(I)
         %IF J # 0 %THENSTART
         %BEGIN
         %INTEGER NEXTID,P
         %INTEGERARRAY PLACE(0 : J)
         %STRING (32) %ARRAY IDEN(0 : J)
                  P = 0
                  NEXTID = ALPHA(I)
                  %WHILE NEXTID # 0 %CYCLE
                     PP == RECORD(ADICT+NEXTID)
                     P = P+1
                     PLACE(P) = NEXTID
                     IDEN(P) = STRING(ANAMES+PP_IDEN)
                     NEXTID = PP_LINK1
                  %REPEAT
                  QKSORT(IDEN,PLACE,1,P)
                  %CYCLE J = 1,1,P
                     PRINTOUT(PLACE(J))
                  %REPEAT
         %END
            %FINISH
         %REPEAT
         NEWLINE
         %RETURN
%ROUTINE SORT
%INTEGER I, J, NEXTID, K
%stringname S
            %CYCLE I = 0,1,154
               NEXTID = integer(Lhead)
               integer(Lhead)=0
               Lhead=Lhead+W1
               %WHILE NEXTID # 0 %CYCLE
                  PP == RECORD(ADICT+NEXTID)
                  %UNLESS NEXTID=BLCMPTR %THENSTART
                     S==string(Anames+PP_Iden)
                     J=charno(S,1)
                     K = NEXTID
                     NEXTID = PP_LINK1
                     PP_LINK1 = ALPHA(J)
                     ALPHA(J) = K
                     COUNT(J) = COUNT(J)+1
                  %FINISHELSE NEXTID=PP_LINK1
               %REPEAT
            %REPEAT
            LHEAD=COM_ADLHEAD
            %CYCLE I=0,1,25
               integer(LHEAD)=ALPHA(I+'A');! IN CASE MAP IS CALLED TWICE
               Lhead=Lhead+W1
            %REPEAT
%END;                                   ! SORT
            %ROUTINE QKSORT(%STRING(*)%ARRAYNAME X, %C
                            %INTEGERARRAYNAME PL, %INTEGER A, B)
%STRING (32) D
%INTEGER L, U, E
            %RETURNIF A >= B
            L = A;  
            U = B
            D = X(U)
            E = PL(U)
            -> FIND
UP:         L = L+1
            -> FOUND %IF L = U
FIND:       -> UP %UNLESS X(L) > D
            X(U) = X(L)
            PL(U) = PL(L)
DOWN:       U = U-1
            -> FOUND %IF L = U
            -> DOWN %UNLESS X(U) < D
            X(L) = X(U)
            PL(L) = PL(U)
            -> UP
FOUND:      X(U) = D
            PL(U) = E
            QKSORT(X,PL,A,L-1)
            QKSORT(X,PL,U+1,B)
%END;                                   ! QKSORT
%ROUTINE PRINTOUT(%INTEGER L)
%INTEGER T, C, I, J, K, S, LEN
%STRING (32) ID
%RECORD(PRECF) %NAME PP
%RECORD(SRECF) %NAME SS
%ROUTINESPEC PUT(%STRING(20) S)
%ROUTINESPEC WRIT(%INTEGER I)
%CONSTSTRING(2)%ARRAY SIZE(3:8)="1 ","2 ","4 ","8 ","16","32"
%CONSTSTRING(10)%ARRAY TYPE(1:5)=  %C
   "integer*","real*","complex*","logical*","character*"
%CONSTSTRING(10)%ARRAY SUBPROG(0:3)=  %C
   "program","function","subroutine","entry"
%CONSTSTRING(18)%ARRAY SPECIAL(10:13)=  %C
   "namelist","","common block","statement function"
!*
      PP==RECORD(ADICT+L)
      %RETURN %IF PP_X1>>4=15;! STANDARD FUNCTION
      NEWLINE
      ID=STRING(ANAMES+PP_IDEN)
      PRINTSTRING(ID)
      LEN=LENGTH(ID)
      I=12-LEN
      %IF I<=0 %THEN I=1
      SPACES(I)
      LEN=LEN+I
      C=PP_CLASS&X'1F'
      T=PP_TYPE&15
      S=PP_TYPE>>4
      %IF C<7 %THENSTART;! VARIABLE OR ARRAY
         %IF C&1#0 %THEN PUT("parameter ")
         %IF C&2#0 %AND PP_X0&X'10'=0  %THEN PUT("common ")
         %IF PP_X1&X'80'#0 %THEN PUT("equivalenced ")
         %IF C&4#0 %THEN PUT("array, ")  %C
                   %ELSE PUT("variable, ")
T:       %IF PP_X0&8=0 %THEN PUT("implicit ")
         PUT(TYPE(T))
         %IF T=5 %THENSTART;! CHARACTER
            %IF PP_LEN=0 %THEN PUT("(*)") %ELSE WRIT(PP_LEN)
         %FINISHELSESTART
            %IF T=3 %THEN S=S+1
            PUT(SIZE(S))
         %FINISH
      %FINISHELSESTART;! SPECIAL IDEN
         %IF C=16 %THENSTART
            PUT("constant, ")
            ->T
         %FINISH
         %IF C<10 %OR C=11 %THENSTART;! SUBPROGRAM
           %IF C#11 %THEN PUT("external ")
            PUT(SUBPROG((PP_X1>>4)&3))
         %FINISHELSESTART
            PUT(SPECIAL(C))
         %FINISH
      %FINISH
      %RETURN %IF XREF=0;! NOXREF
      SPACES(51-LEN)
      SPACE
      I=PP_XREF;! LISTHEAD OF REFS
      J=0
      %WHILE I#0 %CYCLE;! REVERSE LIST
         K=I
         SS==RECORD(ADICT+I)
         I=SS_LINK1
         SS_LINK1=J
         J=K
      %REPEAT
      PP_XREF=J
      J=L+IDRECSIZE
      K=0;! FOR NOTE OF LAST LINE WRITTEN
      L=5
      %WHILE J#0 %CYCLE
         SS==RECORD(ADICT+J)
         I=SS_INF0
         %IF I#K %THENSTART
            K=I
            %IF L=0 %THEN NEWLINE %AND SPACES(52) %AND L=5
            L=L-1
            WRITE(I,4)
         %FINISH
         J=SS_LINK1
      %REPEAT
      %RETURN
%ROUTINE PUT(%STRING(20) S)
      PRINTSTRING(S)
      LEN=LEN+LENGTH(S)
%END;! PUT
%ROUTINE WRIT(%INTEGER A)
%CONSTINTEGERARRAY M(0:3)=10000,1000,100,10
%INTEGERARRAY B(0:4)
%INTEGER I,J
         %CYCLE I=0,1,3
            B(I)=A//M(I)
            A=A-B(I)*M(I)
         %REPEAT
         B(4)=A
         J=0
         %CYCLE I=0,1,4
            %IF B(I)#0 %OR J#0 %OR I=4 %THENSTART
               PRINTSYMBOL(B(I)+'0')
               LEN=LEN+1
               J=1
            %FINISH
         %REPEAT
         %RETURN
%END;! WRIT
%END;                                   ! PRINTOUT
!*
%END;                                   ! MAP
!*
%ENDOFFILE