PROGRAM LIBLIST INCLUDE 'LIBLISCOM' CHARACTER LIBNAM*40,TIME*20 COMMON LIBNAM,TIME NUN=0 NEN=0 CALL RDLIST(NW) PRINT *,' Library file read has length ',NW,' bytes' PRINT *,' Searching for names...' IP=1 30 IF(IP.GT.NW) GO TO 203 J=IB(IP) IP=IP+1 GO TO (201,202,203,204,205,206,207,208,209,210 +, 211,212,213,214,215,216,217,218),J CALL ERRORS('MAIN2') 201 CALL HEAD GO TO 30 202 GO TO 30 203 CALL SORT PRINT *,' Printing...' OPEN(2,FORM='PRINTER',FILE='rawlp:') WRITE(2,198)15,27,48 WRITE(2,197)LIBNAM,TIME 197 FORMAT(' Map of library $.Panoslib.',A,4X,A) 198 FORMAT('*',A1) WRITE(2,199)(ENTPNT(I),UNITS(NAMADR(I)),I=1,NEN) 199 FORMAT(6(' Entry Program ')//(6(1X,A7,1XA11))) WRITE(2,198)12,18,27,50 STOP 204 CALL DEFAREA GO TO 30 205 CALL EXPORT GO TO 30 206 CALL SETPOS GO TO 30 207 CALL STORE GO TO 30 208 CALL REPSTO GO TO 30 209 CALL IMPORT GO TO 30 210 CALL CHKUSE GO TO 30 211 CALL RELDOUBLE GO TO 30 212 CONTINUE GO TO 30 213 IP=IP+NUMB() GO TO 30 214 CALL COMMNT GO TO 30 215 CALL DEFSB GO TO 30 216 CALL ENTRY GO TO 30 217 CALL DEFHAND GO TO 30 218 IP=IP+NUMB() GO TO 30 END SUBROUTINE CHKUSE C Check Use INCLUDE 'LIBLISCOM' IP=IP+1 CALL LNAME() CALL LNAME() IP=IP+NUMB() RETURN END SUBROUTINE COMMNT C Comment CALL LNAME() RETURN END SUBROUTINE DEFAREA INCLUDE 'LIBLISCOM' C Define Areas IP=IP+5 ISIZE=NUMB() N=LNAME() RETURN END SUBROUTINE DEFHAND C Define Handler IERRHA=NUMB() RETURN END SUBROUTINE DEFSB INCLUDE 'LIBLISCOM' C Define Static Base MODE=IB(IP) IP=IP+1 GO TO (200,210,220,230),MODE+1 200 CALL ERRORS('DEFSB') 210 ISBAR=NUMB() LOCSB=NUMB() RETURN 220 CALL ERRORS('DEFSB') 230 LOCSB=NUMB() L=LNAME() RETURN END SUBROUTINE ENTRY C Define Entry INENT=NUMB() RETURN END SUBROUTINE EXPORT INCLUDE 'LIBLISCOM' C Define Entry Points MODE=IB(IP) IP=IP+1 NEN=NEN+1 IF(NEN.GT.MAXEN) CALL ERRORS('EXPORT') K=NUMB() ITYPE=0 IF(MODE.LT.128) GO TO 10 MODE=MODE-128 ITYPE=1 10 GO TO (200,210,220),MODE+1 200 CONTINUE 210 CALL ERRORS('EXPORT') 220 CONTINUE CALL LNAME() ENTPNT(NEN)=NAME NAMADR(NEN)=NUN IF(INDEX(NAME,' ').GT.8) ENTPNT(NEN)(7:7)='*' IF(ITYPE.GT.0) IP=IP+NUMB() RETURN END SUBROUTINE HEAD INCLUDE 'LIBLISCOM' DIMENSION IHF(4) DATA IHF/80,98,69,50/ DO 10 I=1,4 IF(IB(IP).NE.IHF(I)) CALL ERRORS('HEAD1') 10 IP=IP+1 NUN=NUN+1 IF(NUN.GT.MAXUN) CALL ERRORS ('HEAD2') ITYPE=IB(IP) IP=IP+1 IF(MOD(ITYPE,2).GT.0) CALL NUMB() L=LNAME() UNITS(NUN)=NAME IF(L.GT.11) UNITS(NUN)(11:11)='*' L=LNAME() C SOURCE FIELD IS PRESENT IF(MOD(ITYPE,32).GT.15) L=LNAME() C "INFO" FIELD L=LNAME() C Language field IF(MOD(ITYPE,16).GT.7) CALL NUMB() RETURN END FUNCTION IB(IP) PARAMETER(MAXL=100000) CHARACTER*1 BUF(MAXL) CHARACTER NAME*40,TIME*20 COMMON NAME,TIME,BUF DIMENSION ICAT(4),ITIM(2) IB=ICHAR(BUF(IP)) RETURN ENTRY RDLIST(NW) 10 PRINT 101 101 FORMAT('* Enter library name ') READ 102,NAME 102 FORMAT(A) IF(INDEX(NAME,'-').EQ.0) THEN J=INDEX(NAME,' ') IF(J.EQ.0.OR.J.GT.37) GO TO 10 NAME(J:J+3)='-lib' ENDIF IRES=IFGETFILEINFORMATION(ICAT,ITIM,'$.PANOSLIB.'//NAME) IF(IRES.NE.1) THEN PRINT *,'Can''t find file $.PANOSLIB.',NAME GO TO 10 ENDIF IRES=IFTEXTUALTIMEOFBINARYTIME(TIME,20,ITIM) IF(IRES.LT.0) THEN PRINT *,'Can''t decode time and date' TIME=' ' ENDIF NW=ICAT(3) LUNIN=IFFINDINPUT('$.PANOSLIB.'//NAME) IF(LUNIN.LT.0) THEN PRINT *,' failed to open file for reading' STOP ENDIF IRES=IFXSBLOCKREADC(LUNIN,NW,BUF) IF(IRES.NE.NW) THEN PRINT *,' Wrong number of bytes read',IRES STOP ENDIF RETURN END SUBROUTINE IMPORT INCLUDE 'LIBLISCOM' C Define External References IEXTNO=NUMB() MODE=IB(IP) IP=IP+1 GO TO (200,210,220,230,240,250,260,270),MODE+1 200 CALL ERRORS('IMPORT1') 210 INEXT=NUMB() INAREA=NUMB() RETURN 240 L=LNAME() L=LNAME() RETURN 220 CONTINUE 230 CONTINUE 250 CONTINUE 260 CONTINUE 270 CALL ERRORS('IMPORT2') END FUNCTION LNAME() INCLUDE 'LIBLISCOM' LNAME=IB(IP) NAME=' ' DO 10 I=1,LNAME IP=IP+1 NAME(I:I)=CHAR(IB(IP)) 10 CONTINUE IP=IP+1 RETURN END FUNCTION NUMB() C GETS VARIABLE FORMAT NUMBER STARTING AT IP INCLUDE 'LIBLISCOM' IX=IB(IP) IF(IX.GT.127) GO TO 10 C SIMPLE BYTE NUMB=IX IF(NUMB.GT.63) NUMB=NUMB-128 IP=IP+1 RETURN 10 IF(IX.GT.191) GO TO 20 NUMB=(IX-128)*256+IB(IP+1) IF(IX.GT.159) NUMB=NUMB-16384 IP=IP+2 RETURN 20 IF(IX.GT.223) GO TO 30 NUMB=(((IX-192)*256+IB(IP+1))*256+IB(IP+2))*256+IB(IP+3) IF(IX.GT.207) NUMB=NUMB-536870912 IP=IP+4 RETURN 30 IF(IX.NE.224) CALL ERRORS('NUMB') NUMB=IB(IP+1)+256*(IB(IP+2)+256*(IB(IP+3)+256*(IB(IP+4)))) IP=IP+5 RETURN END SUBROUTINE RELDOUBLE INCLUDE 'LIBLISCOM' C Relocate Doubleword MODE=IB(IP) IP=IP+1 GO TO (200,210,220,230,240,250,260,270),MODE+1 200 CALL ERRORS('RELDUB') 210 N=NUMB() IA=NUMB() RETURN 240 L=LNAME() L=LNAME() RETURN 250 N=NUMB() RETURN 220 CONTINUE 230 CONTINUE 260 CONTINUE 270 CALL ERRORS('RELDUB') END SUBROUTINE REPSTO INCLUDE 'LIBLISCOM' I=NUMB() IP=IP+NUMB() RETURN END SUBROUTINE SETPOS C SET POSITION IN AREA IAREA=NUMB() IOFSET=NUMB() RETURN END SUBROUTINE SORT C SORT NAMES INCLUDE 'LIBLISCOM' CHARACTER*7 JJ PRINT *,' Sorting, please be patient...' I=1 10 IF(I.GE.NEN) RETURN 20 IF(ENTPNT(I).GT.ENTPNT(I+1)) GO TO 40 30 I=I+1 GO TO 10 40 J=NAMADR(I) NAMADR(I)=NAMADR(I+1) NAMADR(I+1)=J JJ=ENTPNT(I) ENTPNT(I)=ENTPNT(I+1) ENTPNT(I+1)=JJ I=MAX0(1,I-1) GO TO 10 END SUBROUTINE STORE INCLUDE 'LIBLISCOM' C POINTERS FOR BLOCK STORE IP=IP+NUMB() RETURN END SUBROUTINE ERRORS(NAM) CHARACTER*(*) NAM INCLUDE 'LIBLISCOM' PRINT *,' ERROR IN ROUTINE ',NAM PRINT *,' IP = ',IP PRINT 101,(IB(IP+I-4),I=1,10) 101 FORMAT(' IB(IP-3 to IP+6) '/10(1X,Z)) STOP END