C CMNFTN.FTN, SEGSRC, CEH-LSS-KJC, 02/22/79
C Common frequently referenced FTN subrs for SEG and LOAD
C Copyright (c) 1981, Prime Computer, Inc., Natick, MA 01760
C
C      INITNE - THE ROUTINE TO INITIALIZE A SYMBOL TABLE SEARCH
C
C      INITNE - RESETS THE POINTERS IN POINTR ACCORDING TO THE SYMBOL TYPE
C      GIVEN IN ITS ARGUEMENT LIST.  IT PUTS THIS SYMBOL TYPE (OR AN
C      APPROPRIATE ENTRY FOR ENTRY POINTS) IN POINTR(4).
C
C      CALLING SEQUENCE:  CALL INITNE(POINTR,TYPE,NAME)
C
C      WHERE:  POINTR IS THE 8 WORD ARRAY
C              TYPE IS THE SYMBOL TYPE
C              NAME IS THE NAME FIELD FOR TYPE 1 SYMBOLS
C
C      THE SYMBOL TABLE SEARCH IS INITIALIZE TO THE SPECIAL VALUE
C
C      0 => START OF SEARCH
C      THERE IS ANOTHER VALUE, MA$END=:100000, END OF SEARCH
C
       SUBROUTINE INITNE(POINTR,TYPE,NAME)
C
       INTEGER*2 POINTR(8),TYPE,NAME,PTRI,I
$INSERT LODCOM.INS.FTN
C
       POINTR(PT$BAK)=0
       POINTR(PT$CUR)=0
       POINTR(PT$FOR)=0
       POINTR(SYMPT$)=:7777
       POINTR(SYMPT$+1) = 0
       POINTR(7)=0
       POINTR(8) = 0
       POINTR(PT$TYP)=TYPE
       IF(TYPE.EQ.1) GO TO 100
       IF(CHAIN(TYPE+1).NE.0) POINTR(PT$FOR)=CHAIN(TYPE+1)
       RETURN
C
100    I=PTRI(NAME)                    /*CONVERT POSITION OF NAME TO SLOT
       POINTR(PT$FOR)=CHAIN(I)
       IF(POINTR(PT$FOR).NE.0) GO TO 200
       POINTR(PT$FOR)=CHAIN(2)
200    RETURN
       END
C      PTRI - ROUTINE TO FIND POSITION IN CHAIN FOR TYPE 1 SYMBOLS
C
C      CALLING SEQUENCE I=PTRI(NAME)
C
C      WHERE:  NAME IS THE FIRST WORD OF THE NAME FIELD
C
       INTEGER FUNCTION PTRI(NAME)
C
       INTEGER*2 NAME
C
C      LODCOM.INS.FTN IS LISTED IN INITNE
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
C
       IF(NAME.LT.:40400) GO TO 10     /*CEH 6/02/78
       PTRI=(RS(NAME-:40400,9))        /*MOVE FOR EASY USE
       IF(PTRI.GT.0) GO TO 20
10     PTRI=2
       RETURN
C
20     IF(PTRI.GT.12) PTRI=12
       PTRI=PTRI+4                     /*BEYOND OTHER SYMBOL TYPES
       RETURN
       END
C      FLUSH - ROUTINE TO DEAL WITH TENATIVELY ADDED SYMBOLS
C
C      CALLING SEQUENCE:  CALL FLUSH(IFLAG)
C
C      WHERE:  IFLAG=0, SAYS DELETE, =1, SAYS SAVE
C
       SUBROUTINE FLUSH(IFLAG)
C
       INTEGER*2 IFLAG,POINTR(8),ENTTYP,ENTCNT,STBCNT,SEGCNT,I,J
       INTEGER*4 CURRSG,SBSCRP
C
       COMMON /FLSHCT/ ENTTYP,ENTCNT,STBCNT,SEGCNT
       EQUIVALENCE (SBSCRP,POINTR(7))
C
C      LODCOM.INS.FTN IS LISTED IN INITNE
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
C
       EQUIVALENCE (CURRSG,CURSEG)
       IF(IFLAG.EQ.0) GO TO 1000
       IF(ENTCNT.EQ.0) GO TO 200
       CALL INITNE(POINTR,1,ENTTYP)    /*INIT SYMBOL TABLE SEARCH
       DO 100 I=1,ENTCNT
C
C      CHANGE SYMBOL TYPE OF TENATIVELY ADDED SYMBOLS
C
110    IF(NEXT(POINTR).EQ.0) GO TO 200
       IF(MAP1(SBSCRP).GE.0) GO TO 110
       MAP1(SBSCRP)=:500
100    CONTINUE
C
200    IF(STBCNT.EQ.0) GO TO 500
       CALL INITNE(POINTR,2,0)         /*INIT TO BASE SYMBOLS
       DO 300 I=1,STBCNT
310    IF(NEXT(POINTR).EQ.0) GO TO 500
       IF(MAP1(SBSCRP).GE.0) GO TO 310
       MAP1(SBSCRP)=XOR(MAP1(SBSCRP),:100000)
300    CONTINUE
C
500    CALL INITNE(POINTR,:21,0)       /*SET TO SEGMENT SYMBOLS
C
600    IF(NEXT(POINTR).EQ.0) GO TO 2000
       MAP1(SBSCRP)=AND(MAP1(SBSCRP),:175777) /*MASK OFF MODIFIED SEGMENT BIT
       GO TO 600
C
C      DELETE TENATIVELY ADDED SYMBOLS
C
1000   IF(ENTCNT.EQ.0) GO TO 1100
       CALL INITNE(POINTR,1,ENTTYP)    /*INIT SYMBOL TABLE SEARCH
       DO 1050 I=1,ENTCNT
1010   IF(NEXT(POINTR).EQ.0) GO TO 1100
       IF(MAP1(SBSCRP).GE.0) GO TO 1010
       CALL SYMCLR(POINTR)
1050   CONTINUE
C
1100   IF(STBCNT.EQ.0) GO TO 1500
       CALL INITNE(POINTR,2,0)         /*WORK ON BASE AREAS
       DO 1200 I=1,STBCNT
1210   IF(NEXT(POINTR).EQ.0) GO TO 1500
       IF(MAP1(SBSCRP).GE.0) GO TO 1210
       CALL SYMCLR(POINTR)
1200   CONTINUE
C
1500   CALL INITNE(POINTR,:21,0)
C
1600   IF(NEXT(POINTR).EQ.0) GO TO 2000
       J=MAP1(SBSCRP)
       IF(AND(J,:2000).EQ.0) GO TO 1600 /*NOT MODIFIED
       MAP1(SBSCRP)=XOR(MAP1(SBSCRP),:2000)
       I=MAP1(SBSCRP+A$OLD)
       IF((I.EQ.:777).AND.(AND(J,:20000).NE.0)) GO TO 1610
1605   MAP1(SBSCRP+A$TOP)=I
       GO TO 1600
1610   IF(AND(J,:4000).NE.0)  GO TO 1605         /*OK IF SPLIT SEGMENT
       IF(AND(J,:1000).EQ.0)  GO TO 1615    /*SLOT ASSIGNED?
       IF(RT(J,9)+1.NE.ISLOT) GO TO 1615    /*YES
       CURRSG = -1       /*RESET ALL ALLOCATED BUFFERS SO NO SPACE WASTED
       BUFTBL(SEGTBL(ISLOT)) = 0 /* CLEAN OUT THIS BUFFER
       SEGTBL(ISLOT) = 0      /* RESET THE SEGTBL ENTRY
       ISLOT = ISLOT - 1      /* RESET ISLOT SO SEGMENT DIRECTORY IS NOT WASTED
1615   CALL SYMCLR(POINTR)             /* EMPTY PROCEDURE SEGMENT
       POINT4(PT$CUR)=0                /* FOR SETSEG
       GO TO 1600
C
2000   ENTTYP=0
       ENTCNT=0
       STBCNT=0
       RETURN
       END
C      RDGLOB - ROUTINE TO READ IN A BUFFER FULL OF OBJECT
C
C      CALLING SEQUENCE:  CALL RDGLOB
C
       SUBROUTINE RDGLOB
C
C
       COMMON /RDCOMM/POSIT,OFFST,BUFP,CODE
C
       INTEGER*2 OFFST,BUFP,CODE,IARG,POST(2),BUFF
       INTEGER*4 POSIT
       EQUIVALENCE (POST,POSIT)
C
C      LODCOM.INS.FTN IS LISTED IN INITNE
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
$INSERT SYSCOM>KEYS.INS.FTN
$INSERT SYSCOM>ERRD.INS.FTN
C
       BUFEND=-1                       /*BE SURE THERE IS A STOPPER
       POST(2)=POST(2)+OFFST
       IF(POST(2).LT.0) GO TO 2000
C
C      WHAT IS WANTED IS NOT IN THIS BUFFER, POSIT (POST(2)) NOW CONTAINS
C      A POSITION VALUE FOR THE NEXT READ.
C
       CALL PRWF$$(K$READ,RDUNIT,LOC(BUFF),BUFSIZ,POSIT,IARG,CODE)
       IF(CODE.EQ.E$EOF) GO TO 3000
       POST(2)=-BUFSIZ
       BUFP=1
       =CODE
       RETURN
C
2000   BUFP=BUFP+OFFST
       =0
       RETURN
C
3000   IF(IARG.EQ.0) GO TO 4000
       POST(2)=-(IARG+1)
       BUFF(IARG+1)=0
       BUFP=1
       =0
       RETURN
4000   =-1
       RETURN
C
       END
C      CMRED$ - ROUTINE TO DO BOTH A CMREAD AND A RDT$$ FOR SEG
C
C      CALLING SEQUENCE: CALL CMRED$(CBUFFR,LNAME,BUFLNT,CHARLN)
C
C      WHERE:  CBUFFER IS THE 18 WORD BUFFER FOR CMREAD
C              LNAME IS A BUFFER OF LENGTH BUFLNT FOR RDTK$$
C              CHARLN IS THE NUMBER OF CHARACTERS RETURNED BY RDTK$$
C
       SUBROUTINE CMRED$(CBUFFR,LNAME,BUFLNT,CHARLN)
C
       INTEGER CBUFFR(18),LNAME,BUFLNT,CHARLN
C
       CALL CMREAD(CBUFFR)             /*READ A WHOLE COMMAND LINE
       CALL RDT$$$(CBUFFR(4),LNAME,BUFLNT,CHARLN)
       RETURN
       END
C      RDT$$$ - CALL RDTK$$ FOR THE SPECIFIED LOCATION IN CMREAD'S BUFFER
C
C      WHERE:  CBUFFR IS THE LOCATION IN CMREAD'D BUFFER
C              LNAME IS THE LONG NAME BUFFER OF LENGTH BUFLNT
C              CHARLN I THE NUMBER OF CHARACTERS RDTK$$ RETURNS
C
       SUBROUTINE RDT$$$(CBUFFR,LNAME,BUFLNT,CHARLN)
C
       INTEGER INFO(8),BUFLNT,LNAME(BUFLNT),CHARLN,CODE,CBUFFR(3)
       LOGICAL PRIMOS
       COMMON/PRIMOS/PRIMOS
$INSERT SYSCOM>KEYS.INS.FTN
$INSERT SYSCOM>ERRD.INS.FTN
C
       IF(CBUFFR(1).EQ.'  ') GO TO 1000 /*DON'T CALL RDTK$$
       CALL RDTK$$(1,INFO,LNAME,BUFLNT,CODE)
       CALL ERRPR$(K$NRTN,CODE,0,0,'RDT$$$',6)

       IF ( .NOT. PRIMOS) GO TO 500          /* THE FOLLOWING CODE APPLIES
                                             /* TO THE PRIMOS COMMAND LEVEL
       IF ((INFO(3) .NE. :020000))            /* '-LOAD'  FOR AUTOMATIC OUTPUT
     X    GO TO 500                           /* FILE NAMING OPTION
       IF(    (LNAME(1) .EQ. '-L')          /* IS THE ONLY CTL ARG PERMITTED
     X  .AND. (LNAME(2) .EQ. 'OA')          /* IN SEG.
     X  .AND. (LNAME(3) .EQ. 'D '))    GO TO 500
        CALL TNOU('This control argument is not implemented',40)
        CALL ERRPR$(K$NRTN,E$NULL,0,0,0,0)

500    CHARLN=INFO(2)                  /*GIVE USER THE CHARACTER LENGTH
       RETURN
C
1000   LNAME(1)=CBUFFR(1)
       LNAME(2)=CBUFFR(2)
       LNAME(3)=CBUFFR(3)
       LNAME(4)='  '        /* APPEND TWO BLANKS (RDTK$$ ONLY GIVES 6 CHARS)
       CHARLN=8
       RETURN
       END
C      XPUNGE - ROUTINE TO DELETE SYMBOLS FROM THE SYMBOL TABLE
C
C      CALLING SEQUENCE:  CALL XPUNGE(PAR1)
C
C      WHERE:  PAR1 IS A 2 WORD ARRAY
C              WORD 1 - 0 ALL DEFINED SYMBOLS, NON-ZERO - LEAVE COMMON
C              WORD 2 - 0 DELETE ALL BASE INFO, 1 - SAVE SECTOR 0, 2 - SAVE ALL
C
       SUBROUTINE XPUNGE(PAR1)
C
       INTEGER*2 PAR1(1),JTEMP
C
C      LODCOM.INS.FTN IS LISTED IN INITNE
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
C
       CALL INITNE(POINT1,1,0)         /*INIT FOR ENTRY POINTS
       JTEMP=:1010                     /*SAVED SYMBOL FLAG
       IF(PAR1(1).EQ.0) JTEMP=:1000    /*DELETE ALL ENTRIES, EXCEPT UNDEFINED
C
C      DELETE ENTRY POINTS AND APPROPRIATE ECBS
C
100    IF(NEXT(POINT1).EQ.0) GO TO 2000
       IF(AND(MAP1(P1SUBS),:100).EQ.0) GO TO 100 /*CHECK FOR DEFINED SYMBOL
       IF(AND(MAP1(P1SUBS),JTEMP).NE.0) GO TO 100  /*CHECK FOR COMMON
       CALL INITNE(POINT2,:20,0)       /*INIT FOR ECB'S
150    IF(NEXT(POINT2).EQ.0) GO TO 160
       IF(AND(MAP1(P2SUBS),:7777).NE.MAP1(P1SUBS+1)) GO TO 150
       IF(MAP1(P2SUBS+3).NE.MAP1(P1SUBS+2)) GO TO 150
       CALL SYMCLR(POINT2)             /*DELETE SYMBOLS
160    CALL SYMCLR(POINT1)
       GO TO 100
C
C      WORK ON BASE AREAS
C
2000   CALL INITNE(POINT1,2,0)
       JTEMP=:177777                   /*MASK FOR ALL BASE AREAS
       IF(PAR1(2)-1) 5000,4000,3000
C
C      SAVE ALL BASE AREAS
C
3000   RETURN
C
C      SAVE SCTOR 0 ONLY
C
4000   JTEMP=:177000                   /*MASKE FOR SECTOR ZERO BASE AREAS ONLY
C
C      DELETE BASE AREAS
C
5000   IF(NEXT(POINT1).EQ.0) RETURN
       IF(AND(MAP1(P1SUBS+AD$OFF),JTEMP).EQ.0) GO TO 5000
       CALL SYMCLR(POINT1)
       GO TO 5000
C
       END
C      SAVESY - ROUTINE TO FLAG SYMBOLS TO BE SAVED
C
C      CALLING SEQUENCE:  CALL SAVESY(NAME)
C
C      WHERE NAME IS THE SYMBOL TO BE FLAGGED
C
       SUBROUTINE SAVESY(NAME)
C
       INTEGER*2 NAME(1),SBSCRP,ERRSEV
       COMMON /ERRSEV/ERRSEV
C
C      LODCOM.INS.FTN IS LISTED IN INITNE
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
C
       DO 100 SBSCRP=1,NA$LEN
       NAME(SBSCRP)=AND(NAME(SBSCRP),:77577)
100    CONTINUE
C
       CALL INITNE(POINT1,1,NAME)
       IF(NAMESE(NAME,POINT1).EQ.0) GO TO 1000
       MAP1(P1SUBS)=AND(MAP1(P1SUBS),:176777)+:1000  /*FLAG TO SAVE
       RETURN
C
1000   CALL TNOU('SYMBOL NOT FOUND',16)
       CALL SS$ERR
       ERRSEV =-1                           /* WARNING
       RETURN
       END
C      HILOWA - ROUTINE TO DO ALPHA SORT
C
C      CALLING SEQUENCE:  CALL HILOWA(HLTYPE,ROUTIN)
C
C      WHERE HLTYPE IS THE SYMBOL TYPE
C      WHERE ROUTINE IN THE ADDRESS OF THE PRINT ROUTINE
C
       SUBROUTINE HILOWA(HLTYPE,ROUTIN)
C
         EXTERNAL ROUTIN
       INTEGER*2 HLTYPE,ROUTIN
C
C      LODCOM.INS.FTN IS LISTED IN INITNE
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
C
       TE3=TE$SET
       CALL INITNE(POINT1,HLTYPE,0)    /*INIT SYMBOL TALE SEARCH
C
100    IF(NEXT(POINT1).EQ.0) GO TO 200
       MAPSBC=P1SUBS                /*FORTRAN SUBSCRIPT FOR MAP1
       CALL ROUTIN
       GO TO 100
C
200    IF(TTYCNT.NE.0) CALL TYPE2(0)   /*WRITE OUT LAST LINE
       CALL TYPE2(0)                   /*A LINE FOR SPACING
       RETURN
       END
C      EP1 - ROUTINE TO PRINT ALL 'OTHER' REFERENCES
C
C      CALLING SEQUENCE:  CALL EP1
C         TE3 MUST BE SET TO TE$SET, THIS IS DONE BY HILOW AND HILOWA
C
       SUBROUTINE EP1
C
C
C      LODCOM.INS.FTN IS LISTED IN INITNE
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
C
C      MAPSBC IS SET UP BY HILOW OR HILOWA
C
       IF(MAP1(MAPSBC).LT.0) GO TO 2000 /*PROCEDURE SYMBOLS NOT PRINTES HERE
       IF(AND(MAP1(MAPSBC),:10).NE.0) RETURN /*COMMON SYMBOLS NOT PRINTED HERE
       IF(AND(MAP1(MAPSBC+AD$SEG).LT.0)) RETURN /*DIRECT ENTRY CALLS NOT PRINTED
       IF(AND(MAP1(MAPSBC),:100).EQ.0) GO TO 1000 /*PRINT UNDEFINED SYMBOLS
       CALL TYPE2('  ')                /*DEFINED SYMBOLS PRECEEDED BY BLANKS
       GO TO 1100
C
1000   CALL TYPE2('**')                /*UNDEFINED SYMBOLS PRECCEDED BY '**'
1100   CALL NAMEPR
       TE3=TE3+1
       IF(TE3.NE.0) RETURN
       IF(TTYCNT.NE.0) CALL TYPE2(0)   /*WRITE STUFF OUT
       TE3=TE$SET
       RETURN
C
2000   MAP1(MAPSBC)=AND(MAP1(MAPSBC),:77777) /*FREE ENTRY
       RETURN
       END
C      EP2 - ROUTINE TO PRINT UNDEFINED SYMBOLS ONLY
C
C      CALLING SEQUENCE:  CALL EP2
C
C      TE3 MUST BE SET TO TE$SET BEFORE THE FIRST CAL, THIS IS DONE BY HILOW
C      AND HILOWA
C
       SUBROUTINE EP2
C
C
C      LODCOM.INS.FTN IS LISTED IN INITNE
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
C
       IF(AND(MAP1(MAPSBC),:100).NE.0) RETURN
       CALL TYPE2('**')                /*UNDEFINED SYMBOLS PRECEEDED BY '**'
       CALL NAMEPR
       TE3=TE3+1
       IF(TE3.NE.0) RETURN
       IF(TTYCNT.NE.0) CALL TYPE2(0)   /*WRITE STUFF OUT
       TE3=TE$SET
       RETURN
       END
C      TOCT - ROUTINE TO PRINT 6 OCTAL DIGITS
C
C      CALLING SEQUENCE:  CALL TOCT(LOCSEG,NUM)
C
C      WHERE LOCSEG IS THE NUMBER TO BE PRINTED
C            NUM IS THE NUMBER OF WORDS OF BLANKS TO PRINT AFTER
C
       SUBROUTINE TOCT(LOCSEG,NUM)
C
       INTEGER*2 LOCSEG,NUM
       CALL TYPE2(
     +  RS(AND(LOCSEG,:100000),7)+RS(AND(LOCSEG,:70000),12)+'00')
       CALL TYPE2(
     +  RS(AND(LOCSEG,:7000),1)+RS(AND(LOCSEG,:700),6)+'00')
       CALL TYPE2(
     +  AND(LOCSEG,:7)+LS(AND(LOCSEG,:70),5)+'00')
       IF(NUM.EQ.0) RETURN
       CALL TYPE2(NUM)
       RETURN
       END
C      NAMEPR - ROUTINE TO PRINT THE NAME OF A ROUTINE AND ITS ADDRESS
C
C      CALLING SEQUENCE:  CALL NAMEPR
C
C      WHERE MAPSBC IN COMMON CONTAINS THE SUBSCRIPT FOR MAP1 TO THE
C      SYMBOL TALE ENTRY
C
       SUBROUTINE NAMEPR
C
       INTEGER*2 I,IJ
C
C
C      LODCOM.INS.FTN IS LISTED IN INITNE
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
C
       IJ=MAPSBC+NA$OFC
       DO 100 I=1,NA$LEN
       CALL TYPE2(MAP1(IJ)+:100200)
       IJ=IJ+1
100    CONTINUE
       CALL TYPE2(1)
       =MAP1(MAPSBC+1)
       CALL SEGOUT
       CALL TOCT(MAP1(MAPSBC+AD$OFF),1)
       RETURN
       END
C      WRDOUT - ROUTINE TO PRINT A FORMATED MESSAGE
C
C      CALLING SEQUENCE:  CALL WRDOUT(BUFFR)
C
C      WHERE BUFFR IS THE MESSAGE FORMATED AS FOLLOWS:
C
C        ASCII CHARACTERS ARE PRINTED
C        SMALL POSITIVE NUMBERS ARE TREATED AS A NUMBER OF BLANKS TO PRINT
C        0 TERMNATES THE MESSAGE
C        -1 TERMINATES THE MESSAGE AND CAUSES A CRLF
C
       SUBROUTINE WRDOUT(BUFFR)
C
       INTEGER*2 BUFFR(1),BUFCNT
C
       BUFCNT=0
C
10     BUFCNT=BUFCNT+1
       IF(BUFFR(BUFCNT).EQ.0) RETURN
       CALL TYPE2(BUFFR(BUFCNT))
       IF(BUFFR(BUFCNT).EQ.-1) RETURN
       GO TO 10
C
       END
C      TYPE2 - ROUTINE TO PLACE 2 CHARS IN BUFFER, OR WRITE OUT BUFFER
C
C      CALLING SEQUENCE:  CALL TYPE2(CHARS)
C
C      WHERE CHARS IS A WORD OF TWO CHARACTERS TO BE PUT IN THE BUFFER
C        IF CHARS.EQ.0 OR -1 THE BUFFER WILL BE WRITTEN OUT
C
C      IF CHARS IS A SMALL POSITIVE NUMBER, THAT MANY PAIRS OF BLANKS
C          WILL BE PRINTED OUT
C
       SUBROUTINE TYPE2(CHARS)
C
       INTEGER*2 CHARS,TTYCNT,BUFFR(41),CODE,I
C
C
C      LODCOM.INS.FTN IS LISTED IN INITNE
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
$INSERT SYSCOM>KEYS.INS.FTN
C
       IF(CHARS.EQ.0) GO TO 1000
       IF(CHARS.EQ.-1) GO TO 1000
C
       IF(CHARS.LT.0) GO TO 500
C
C      PUT CHARS PAIRS OF BLANKS IN BUFFER
C
       DO 100 I=1,CHARS
       TTYCNT=TTYCNT+1
       BUFFR(TTYCNT)='  '
       IF(TTYCNT.GT.40) GO TO 1000
100    CONTINUE
       RETURN
C
C      PUT THESE TWO CHARS IN BUFFER
C
500    TTYCNT=TTYCNT+1
       BUFFR(TTYCNT)=CHARS
       IF(TTYCNT.GT.40) GO TO 1000
       RETURN
C
C      PRINT THIS ON TERMINAL OR TO FILE
C
1000   IF(TTYSW.EQ.0) GO TO 1500
       TTYCNT=TTYCNT+1
       BUFFR(TTYCNT)=:105000           /*END LINE WITH A LINE FEED
       CALL PRWF$$(K$WRIT,WRITEU,LOC(BUFFR),TTYCNT,000000,TTYCNT,CODE)
       CALL ERRPR$(K$NRTN,CODE,0,0,'TYPE2',5)
       TTYCNT=0
       RETURN
C
1500   IF(TTYCNT.EQ.0) GO TO 1600
       CALL TNOUA(BUFFR,TTYCNT*2)
1600   CALL TONL
       TTYCNT=0
       RETURN
       END
C      LINOUT - ROUTINE TO PRINT A LINE OF OCTAL NUMBERS
C
C      CALLING SEQUENCE:  CALL LINOUT(NUMBRS,NUM)
C
C      WHERE NUMBRS IS A BUFFER CONTAINING THE NUMBERS
C            NUM IS THE NUMBER TO PRINT
C
       SUBROUTINE LINOUT(NUMBRS,NUM)
C
       INTEGER*2 NUMBRS(1),NUM,I
C
       DO 10 I=1,NUM
       CALL TOCT(NUMBRS(I),1)
10     CONTINUE
       CALL TYPE2(0)
       RETURN
       END
C      BASEOU - ROUTINE TO PRINT A BASE AREA ENTRY
C
C      CALLING SEQUENCE:  CALL BASEOUT
C
C      POINT1 MUST BE SET UP TO CONTAIN POINT1(SYMPT$)
C
       SUBROUTINE BASEOU
C
       INTEGER*2 BSE(5)
C
C      LODCOM.INS.FTN IS LISTED IN INITNE
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
C
       DATA BSE/'*BASE ',1,0/
C
       CALL WRDOUT(BSE)
       CALL LINOUT(MAP1(MAPSBC+1),MAPSIZ)
       RETURN
       END
C      COMMAP - ROUTINE TO PRINT OUT COMMON ENTRIES
C
C      CALLING SEQUENCE:  CALL COMMAP
C
C      POINT1 AND TE3 MUST BE SET UP.  TE3 IS THE NUMBER OF ENTRIES PER
C      LINE.  COMMAP THEN KEEPS IT CORRECT.
C
       SUBROUTINE COMMAP
C
       INTEGER*2 MA$COM
C
C
C      LODCOM.INS.FTN IS LISTED IN INITNE
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
       PARAMETER MA$COM=MA$SIZ-1
C
       IF(TE3.EQ.TE$SET) TE3=TE$COM
       IF(AND(MAP1(MAPSBC),:10).EQ.0) RETURN /*CHECK MAP FLAG
       IF(AND(MAP1(MAPSBC),:20).EQ.0) GO TO 10
       CALL TYPE2('**')
       GO TO 20
10     CALL TYPE2(1)                   /*PRINT A PAIR OF BLANKS
20     CALL NAMEPR                     /*PRINT NAME
       IF(MAP1(MAPSBC+MA$COM).EQ.0) GO TO 100
       CALL TOCT(MAP1(MAPSBC+MA$COM),1)
       GO TO 200
100    CALL TYPE2(4)
200    TE3=TE3+1
       IF(TE3.NE.0) RETURN
       TE3=TE$COM
       IF(TTYCNT.NE.0) CALL TYPE2(0)   /*WRITE STUFF OUT
       RETURN
       END
C IUCAS, SEG, KJC,  01/22/79
C Routine to do an unsigned integer compare
C Copyright (c) 1979, Prime Computer, Inc., Wellesley, Mass. 02181
C
      INTEGER FUNCTION IUCAS(IARGA,IARGB)
C
C     RETURNS >0 IF IARGA > IARGB
C             =0 IF IARGA = IARGB
C             <0 IF IARGA < IARGB
C
C     CALLING SEQUENCE:
C             I = IUCAS(IARGA,IARGB)
C
      INTEGER IARGA,IARGB
C
      IF (XOR(IARGA,IARGB) .LT. 0) GO TO 100  /* TEST SIGN BIT
      IUCAS = IARGA - IARGB                   /* SAME, RETURN THE DIFFERENCE
      RETURN
100   IUCAS = IARGB                           /* DIFFERENT, RETURN B
      IF (IUCAS .EQ. 0) IUCAS = 1             /* BUT NOT 0
      RETURN
      END