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