PROGRAM RDIR C BYTE FILNAM(10),STATUS(9),CC,FF DIMENSION IOPT(4,4),ISPEC(39),MSEG(3),ICSTW(6),IDEF(3) DOUBLE PRECISION DEFEXT,STAT C DATA LDSK /3RLD / C DATA IDEF /3RRDI,3RR ,3RDIR/ DATA DEFEXT,LUN,ITT /6RDSKDIR,10,2RTT/ DATA IOPT /80,0,0,0,83,0,0,0,69,0,0,0,72,0,0,0/ DATA CFIL /0/ C BYTE PROMPT(82),STRING(82),CHANGE,CFIL DIMENSION IBUFF(520) DOUBLE PRECISION PSTAT(5) COMMON ICHAN,IBUFF,IENT,IBLOK,ISEG,NSEG, * PSTAT,PROMPT,STRING,CHANGE,CFIL C 1 FORMAT(A1,'SEGMENT NUMBER:',T22,I6// * ' NUMBER OF SEGMENTS:',T22,I6/' NEXT SEGMENT:',T22,I6/ * ' HIGH SEGMENT:',T22,I6/' EXTRA BYTES:',T22,I6/ * ' START BLOCK:',T22,I6// * ' ENTRY',T10,'STATUS',T24,'FILENAME',T40, * 'STARTBL',T50,'LENGTH',T60,'DATE'/) 2 FORMAT(A1,I2,T10,9A1,T24,10A1,T39,I6,T49,I6,T60,8A1) 3 FORMAT(X) 7 FORMAT(' Invalid number of directory segments,'/X, * 'ensure this device has a directory.'/X, * 'Use the "/P" option to patch the correct number.') C ICHAN=IGETC() IERROR=1 IF (ICHAN.LT.0) GOTO 999 8 IERROR=7 CALL PUTSTR(7,'*','$',0) 14 CALL GETSTR(5,STRING,80,I) IF (I) GOTO 999 IF (STRING(1).NE.'@') GOTO 9 IERROR=8 IF (CFIL) GOTO 999 CLOSE(UNIT=5) OPEN(UNIT=5,NAME=STRING(2),TYPE='OLD',ERR=999) CFIL=.TRUE. GOTO 8 13 CLOSE(UNIT=5) CFIL=.FALSE. GOTO 14 C 9 IF (I.AND.CFIL) GOTO 13 D CALL SCCA(IFLAG) IF (CFIL) CALL PUTSTR(7,STRING,'+',0) IF (I) GOTO 999 IF (STRING(1).EQ.0) GOTO 999 IF (ICSI(ISPEC,DEFEXT,STRING,IOPT,4)) GOTO 999 IERROR=4 IF (IFETCH(ISPEC(16)).LT.0) GOTO 999 IERROR=2 IF (LOOKUP(ICHAN,ISPEC(16)).LT.0) GOTO 999 IF (IOPT(2,1)) GOTO 100 C IF (ISPEC(1).EQ.0) ISPEC(1)=ITT FF='1' IF (ISPEC(1).EQ.ITT) FF='0' CALL FILASC(ISPEC,STRING,IDEF) IERROR=6 OPEN(UNIT=LUN,NAME=STRING,TYPE='NEW',ERR=999, * CARRIAGECONTROL='FORTRAN') C ISEG=1 IF (IOPT(2,2).EQ.2) ISEG=IOPT(4,2) IBLOK=4+2*ISEG IERROR=3 IF (IREADW(3,MSEG,6,ICHAN).NE.3) GOTO 999 IF (MSEG(1).GT.0) GOTO 12 WRITE(LUN,7) GOTO 200 12 IF (IOPT(2,3).EQ.2) MSEG(1)=IOPT(4,3) IF (IOPT(2,4)) MSEG(1)=MSEG(3) C CALL DATE(STRING) STRING(10)=' ' CALL TIME(STRING(11)) STRING(19)=0 CALL PUTSTR(LUN,STRING,FF,0) C CALL ICSTAT(ICHAN,ICSTW) ISPEC(16)=ICSTW(6)+ICSTW(5)+"36 CALL SCOPY('DIRECTORY SEGMENTS OF ',STRING) CALL FILASC(ISPEC(16),STRING(23),0) IF (ICSTW(6).NE.LDSK) GOTO 11 IF (LOGDSK(ICSTW(5),ISPEC,ISIZE,IWLOCK,IAVAIL).LT.0) GOTO 11 IF (ISPEC(1).EQ.0) GOTO 11 CALL CONCAT(STRING,' (=',STRING) CALL FILASC(ISPEC,STRING(LEN(STRING)+1),0) CALL CONCAT(STRING,')',STRING) 11 CALL PUTSTR(LUN,STRING,' ',0) IFIRST=-1 C 10 IF (ISEG.GT.MSEG(1)) GOTO 200 IF (ICTRLZ()) GOTO 150 IERROR=3 IF (IREADW(512,IBUFF,IBLOK,ICHAN).NE.512) GOTO 999 IFILBL=IBUFF(5) IENT=1 IERROR=5 CC=FF IF (IFIRST) FF='0' IFIRST=0 WRITE(LUN,1,ERR=999) FF,ISEG,(IBUFF(I),I=1,5) FF=CC DO 30, IWORD=6,512,7+IBUFF(4)/2 IF (ICTRLZ()) GOTO 150 CALL R50ASC(9,STAT(IBUFF(IWORD)),STATUS) CALL R50ASC(9,IBUFF(IWORD+1),FILNAM) DO 20, I=10,8,-1 FILNAM(I)=FILNAM(I-1) 20 CONTINUE FILNAM(7)='.' CALL DATASC(IBUFF(IWORD+6),STRING) CC=' ' IF (IENT.EQ.37) CC=FF WRITE(LUN,2,ERR=999) CC,IENT,STATUS,FILNAM, * IFILBL,IBUFF(IWORD+4),(STRING(I),I=1,8) IFILBL=IFILBL+IBUFF(IWORD+4) IENT=IENT+1 30 CONTINUE ISEG=ISEG+1 IBLOK=IBLOK+2 IF (FF.EQ.'0') TYPE 3 GOTO 10 C 100 CALL DIRPAT GOTO 300 150 CLOSE(UNIT=5) CFIL=.FALSE. 200 CLOSE(UNIT=LUN) 300 CALL CLOSEC(ICHAN) 400 CONTINUE D CALL SCCA GOTO 8 C 999 CALL ERRTXT(IERROR) CLOSE(UNIT=5) CFIL=.FALSE. IF (IERROR.EQ.1) CALL EXIT IF (IERROR.EQ.2) GOTO 400 IF (IERROR.EQ.6) GOTO 300 IF (IERROR.EQ.7) GOTO 400 IF (IERROR.EQ.8) GOTO 400 CALL ERRTST(24,I) IF (I.EQ.1) BACKSPACE LUN GOTO 200 END SUBROUTINE DATASC(IDATE,DSTR) BYTE DSTR(1) DIMENSION NDAY(12) DATA NDAY/31,28,31,30,31,30,31,31,30,31,30,31/ C BYTE PROMPT(82),STRING(82),CHANGE,CFIL DIMENSION IBUFF(520) DOUBLE PRECISION PSTAT(5) COMMON ICHAN,IBUFF,IENT,IBLOK,ISEG,NSEG, * PSTAT,PROMPT,STRING,CHANGE,CFIL C IYEAR=IDATE.AND."37 IYEAR=IYEAR+72 IMONTH=IDATE.AND."76000 IMONTH=IMONTH/1024 IDAY =IDATE.AND."1740 IDAY =IDAY/32 IF (IYEAR.EQ.72.AND.IMONTH.EQ.0.AND.IDAY.EQ.0) GOTO 2 NDAY(2)=28 IF (MOD(IYEAR,4).EQ.0) NDAY(2)=29 IF ((IMONTH.LE.0.OR.IMONTH.GT.12) *.OR.(IDAY.LE.0.OR.IDAY.GT.NDAY(IMONTH))) GOTO 2 ENCODE(8,1,DSTR) IDAY,'-',IMONTH,'-',IYEAR 1 FORMAT(I2,A1,I2,A1,I2) DSTR(1)=DSTR(1).OR."60 DSTR(4)=DSTR(4).OR."60 RETURN 2 DO 3, I=1,8 3 DSTR(I)=32 RETURN END DOUBLE PRECISION FUNCTION STAT(ISTAT) C BYTE PROMPT(82),STRING(82),CHANGE,CFIL DIMENSION IBUFF(520) DOUBLE PRECISION PSTAT(5) COMMON ICHAN,IBUFF,IENT,IBLOK,ISEG,NSEG, * PSTAT,PROMPT,STRING,CHANGE,CFIL C DATA PSTAT/9RTENTATIVE,5REMPTY,9RPERMANENT,9RPROTECTED,3REND/ C STAT=0D0 IF (ISTAT.EQ. "400) STAT=PSTAT(1) IF (ISTAT.EQ. "1000) STAT=PSTAT(2) IF (ISTAT.EQ. "2000) STAT=PSTAT(3) IF (ISTAT.EQ."102000) STAT=PSTAT(4) IF (ISTAT.EQ. "4000) STAT=PSTAT(5) RETURN END SUBROUTINE DIRPAT BYTE H1,H2,PATHD DIMENSION ISTAT(5) DOUBLE PRECISION STAT DATA ISTAT /"400,"1000,"2000,"102000,"4000/ DATA LPR /24/ C BYTE PROMPT(82),STRING(82),CHANGE,BACK,CFIL DIMENSION IBUFF(520) DOUBLE PRECISION PSTAT(5) COMMON ICHAN,IBUFF,IENT,IBLOK,ISEG,NSEG, * PSTAT,PROMPT,STRING,CHANGE,CFIL C 1 FORMAT('0SEGMENT # ',I2'; ENTRY # ',I2) 2 FORMAT(I6) 3 FORMAT(/'0HEADER OF SEGMENT # ',I2) 4 FORMAT(I2,A1,I2,A1,I2) 5 FORMAT(X) 6 FORMAT('+',I6) 7 FORMAT('0LAST ENTRY OF SEGMENT # ',I2/ * ' Status: ',9A1/'$Set status "END" ? ') C 8 IERROR=3 IF (IREADW(1,NSEG,6,ICHAN).NE.1) GOTO 999 IF (NSEG.GT.0) GOTO 10 9 CALL PUTSTR(7,'Invalid number of directory segments: ','$',0) TYPE 6,NSEG CALL PUTSTR(7,'Enter desired number of segments: ','$',0) 14 CALL GETSTR(5,STRING,2,I) IF (.NOT.(I.AND.CFIL)) GOTO 13 CLOSE(UNIT=5) CFIL=.FALSE. GOTO 14 13 IF (CFIL) CALL PUTSTR(7,STRING,'+',0) IF (STRING(1).EQ.0) GOTO 400 DECODE(LEN(STRING),2,STRING,ERR=9) NSEG IERROR=5 IF (IWRITW(1,NSEG,6,ICHAN).NE.1) GOTO 999 GOTO 8 C 10 CHANGE=.FALSE. BACK=.FALSE. TYPE 5 CALL PUTSTR(7,'Segment nr. ? ','$',0) ! input segment number 16 CALL GETSTR(5,STRING,2,I) IF (.NOT.(I.AND.CFIL)) GOTO 15 CLOSE(UNIT=5) CFIL=.FALSE. GOTO 16 15 IF (CFIL) CALL PUTSTR(7,STRING,'+',0) IF (STRING(1).EQ.0) GOTO 10 IF (STRING(1).EQ.'#') GOTO 400 DECODE(LEN(STRING),2,STRING,ERR=10) ISEG IF (ISEG.GT.0.AND.ISEG.LE.NSEG) GOTO 20 CALL PUTSTR(7,'Segment number out of range','0',0) GOTO 10 C 20 CALL PUTSTR(7,'Entry nr. ? ','$',0) ! input entry number 25 CALL GETSTR(5,STRING,2,I) IF (.NOT.(I.AND.CFIL)) GOTO 26 CLOSE(UNIT=5) CFIL=.FALSE. GOTO 25 26 IF (CFIL) CALL PUTSTR(7,STRING,'+',0) IF (STRING(1).EQ.0) GOTO 20 IF (STRING(1).EQ.'#') GOTO 400 IF (STRING(1).EQ.'$') GOTO 400 DECODE(LEN(STRING),2,STRING,ERR=10) IENT C 21 IERROR=3 IF (IREADW(5,IBUFF,4+2*ISEG,ICHAN).NE.5) GOTO 999 NENT=507/(7+IBUFF(4)/2) IWMAX=6+NENT*(7+IBUFF(4)/2) IF (IENT.LT. 0) GOTO 22 ! valid entry number ? IF (IENT.GT.NENT) GOTO 24 GOTO 30 22 IENT=IENT+NENT+1 ISEG=ISEG-1 IF (ISEG.LE.0) GOTO 30 GOTO 21 24 IENT=IENT-NENT-1 ISEG=ISEG+1 IF (ISEG.GT.NSEG) GOTO 30 GOTO 21 C 30 IF (ISEG.GT.0.AND.ISEG.LE.NSEG) GOTO 40 CALL PUTSTR(7,'Segment number out of range','0',0) GOTO 10 C 40 IBLOK=4+2*ISEG CHANGE=.FALSE. TYPE 5 IERROR=3 IF (IREADW(512,IBUFF,IBLOK,ICHAN).NE.512) GOTO 999 NENT=507/(7+IBUFF(4)/2) IWMAX=6+NENT*(7+IBUFF(4)/2) IF (.NOT.BACK) GOTO 100 IENT=NENT BACK=.FALSE. IF (IWMAX.GT.512) GOTO 100 IF (IBUFF(IWMAX).EQ."4000) GOTO 100 CALL R50ASC(9,STAT(IBUFF(IWMAX)),STRING) TYPE 7,ISEG,(STRING(I),I=1,9) 41 CALL GETSTR(5,STRING,80,I) IF (.NOT.(I.AND.CFIL)) GOTO 42 CLOSE(UNIT=5) CFIL=.FALSE. GOTO 41 42 IF (CFIL) CALL PUTSTR(7,STRING,'+',0) IF (STRING(1).EQ.'#') GOTO 400 IF (STRING(1).EQ.'^') GOTO 300 IF (STRING(1).EQ.'$') GOTO 400 IF (STRING(1).EQ.'Y') IBUFF(IWMAX)="4000 CHANGE=.TRUE. C 100 IF (.NOT.CFIL) GOTO 101 IF (ICTRLZ().EQ.0) GOTO 101 CLOSE(UNIT=5) CFIL=.FALSE. C 101 IF (IENT.GT.0) GOTO 102 TYPE 3,ISEG H1=PATHD() NENT=507/(7+IBUFF(4)/2) IWMAX=6+NENT*(7+IBUFF(4)/2) IF (H1) 300,200,400 C 102 IWORD=6+(IENT-1)*(7+IBUFF(4)/2) TYPE 1,ISEG,IENT C CALL R50ASC(9,IBUFF(IWORD+1),STRING) DO 130, I=10,8,-1 130 STRING(I)=STRING(I-1) STRING(7)='.' STRING(11)=0 CALL TRIM(STRING) DO 138, I=1,LEN(STRING) 134 IF (STRING(I).EQ. 0 ) GOTO 140 IF (STRING(I).NE.' ') GOTO 138 DO 136, J=I,LEN(STRING) STRING(J)=STRING(J+1) 136 CONTINUE GOTO 134 138 CONTINUE C 140 CALL SCOPY('Filename: ',PROMPT) CALL CONCAT(PROMPT,STRING,PROMPT) CALL STRPAD(PROMPT,LPR) CALL CONCAT(PROMPT,'>',PROMPT) CALL PUTSTR(7,PROMPT,'$',0) 143 CALL GETSTR(5,STRING,10,I) IF (.NOT.(I.AND.CFIL)) GOTO 144 CLOSE(UNIT=5) CFIL=.FALSE. GOTO 143 144 IF (CFIL) CALL PUTSTR(7,STRING,'+',0) IF (STRING(1).EQ.0) GOTO 120 IF (STRING(1).EQ.'#') GOTO 400 IF (STRING(1).EQ.'^') GOTO 300 IF (STRING(1).EQ.'$') GOTO 400 DO 141, I=1,3 141 IBUFF(IWORD+I)=0 IF (STRING(1).EQ.'.') GOTO 142 INAM=LEN(STRING) IDOT=INDEX(STRING,'.') IF (IDOT) INAM=IDOT-1 CALL IRAD50(INAM,STRING,IBUFF(IWORD+1)) IBUFF(IWORD+3)=0 IEXT=IDOT+1 IF (IDOT) CALL IRAD50(LEN(STRING(IEXT)),STRING(IEXT),IBUFF(IWORD+3)) 142 CHANGE=.TRUE. C 120 CALL R50ASC(9,STAT(IBUFF(IWORD)),STRING) STRING(10)=0 CALL TRIM(STRING) CALL SCOPY('Status: ',PROMPT) CALL CONCAT(PROMPT,STRING,PROMPT) CALL STRPAD(PROMPT,LPR) CALL CONCAT(PROMPT,'>',PROMPT) 110 CALL PUTSTR(7,PROMPT,'$',0) 111 CALL GETSTR(5,STRING,9,I) IF (.NOT.(I.AND.CFIL)) GOTO 112 CLOSE(UNIT=5) CFIL=.FALSE. GOTO 111 112 IF (CFIL) CALL PUTSTR(7,STRING,'+',0) IF (STRING(1).EQ.0) GOTO 150 IF (STRING(1).EQ.'#') GOTO 400 IF (STRING(1).EQ.'^') GOTO 300 IF (STRING(1).EQ.'$') GOTO 400 KK=ICHECK(5,PSTAT,STRING) IF (KK.LE.0) GOTO 110 IBUFF(IWORD)=ISTAT(KK) CHANGE=.TRUE. C 150 ENCODE(6,2,STRING) IBUFF(IWORD+4) STRING(7)=0 DO 152, I=1,6 IF (STRING(I).NE.' ') GOTO 154 152 CONTINUE 154 CALL SCOPY('Length: ',PROMPT) CALL CONCAT(PROMPT,STRING(I),PROMPT) CALL STRPAD(PROMPT,LPR) CALL CONCAT(PROMPT,'>',PROMPT) 160 CALL PUTSTR(7,PROMPT,'$',0) 161 CALL GETSTR(5,STRING,6,I) IF (.NOT.(I.AND.CFIL)) GOTO 162 CLOSE(UNIT=5) CFIL=.FALSE. GOTO 161 162 IF (CFIL) CALL PUTSTR(7,STRING,'+',0) IF (STRING(1).EQ.0) GOTO 170 IF (STRING(1).EQ.'#') GOTO 400 IF (STRING(1).EQ.'^') GOTO 300 IF (STRING(1).EQ.'$') GOTO 400 DECODE(LEN(STRING),2,STRING,ERR=160) IBUFF(IWORD+4) CHANGE=.TRUE. C 170 CALL DATASC(IBUFF(IWORD+6),STRING) STRING(9)=0 CALL SCOPY('Date: ',PROMPT) CALL CONCAT(PROMPT,STRING,PROMPT) CALL STRPAD(PROMPT,LPR) CALL CONCAT(PROMPT,'>',PROMPT) 180 CALL PUTSTR(7,PROMPT,'$',0) 181 CALL GETSTR(5,STRING,8,I) IF (.NOT.(I.AND.CFIL)) GOTO 182 CLOSE(UNIT=5) CFIL=.FALSE. GOTO 181 182 IF (CFIL) CALL PUTSTR(7,STRING,'+',0) IF (STRING(1).EQ.0) GOTO 200 IF (STRING(1).EQ.'*') GOTO 190 IF (STRING(1).EQ.'#') GOTO 400 IF (STRING(1).EQ.'^') GOTO 300 IF (STRING(1).EQ.'$') GOTO 400 IF (STRING(1).EQ.'0'.AND.STRING(2).EQ.0) GOTO 192 DECODE(8,4,STRING,ERR=180) IDAY,H1,IMONTH,H2,IYEAR IF (H1.NE.'-'.OR.H2.NE.'-') GOTO 180 IBUFF(IWORD+6)=(IMONTH*32+IDAY)*32+(IYEAR-72) CHANGE=.TRUE. GOTO 200 190 IBUFF(IWORD+6)=ISPY("262) CHANGE=.TRUE. GOTO 200 192 IBUFF(IWORD+6)=0 CHANGE=.TRUE. C 200 IENT=IENT+1 IF (IENT.LE.NENT) GOTO 100 IF (IWMAX.GT.512) GOTO 210 IF (IBUFF(IWMAX).EQ."4000) GOTO 210 CALL R50ASC(9,STAT(IBUFF(IWMAX)),STRING) TYPE 7,ISEG,(STRING(I),I=1,9) 201 CALL GETSTR(5,STRING,80,I) IF (.NOT.(I.AND.CFIL)) GOTO 202 CLOSE(UNIT=5) CFIL=.FALSE. GOTO 201 202 IF (CFIL) CALL PUTSTR(7,STRING,'+',0) IF (STRING(1).EQ.'#') GOTO 400 IF (STRING(1).EQ.'^') GOTO 300 IF (STRING(1).EQ.'$') GOTO 400 IF (STRING(1).EQ.'Y') IBUFF(IWMAX)="4000 GOTO 212 C 210 IF (.NOT.CHANGE) GOTO 230 212 IERROR=5 IF (IWRITW(512,IBUFF,IBLOK,ICHAN).NE.512) GOTO 999 C 230 ISEG=ISEG+1 IENT=0 GOTO 30 C 300 IENT=IENT-1 IF (IENT.LT.0) GOTO 310 GOTO 100 C 310 IF (.NOT.CHANGE) GOTO 330 IERROR=5 IF (IWRITW(512,IBUFF,IBLOK,ICHAN).NE.512) GOTO 999 C 330 ISEG=ISEG-1 BACK=.TRUE. GOTO 30 C 400 IF (.NOT.CHANGE) GOTO 410 IERROR=5 IF (IWRITW(512,IBUFF,IBLOK,ICHAN).NE.512) GOTO 999 410 IF (STRING(1).EQ.'$') GOTO 8 TYPE 5 RETURN C 999 CALL ERRTXT(IERROR) CLOSE(UNIT=5) CFIL=.FALSE. RETURN END BYTE FUNCTION PATHD C BYTE PROMPT(82),STRING(82),CHANGE,CFIL DIMENSION IBUFF(520) DOUBLE PRECISION PSTAT(5) COMMON ICHAN,IBUFF,IENT,IBLOK,ISEG,NSEG, * PSTAT,PROMPT,STRING,CHANGE,CFIL C 1 FORMAT(I2) 2 FORMAT(I5) C CALL SCOPY('Number of segments: ',PROMPT) ENCODE(2,1,PROMPT(21)) IBUFF(1) CALL SCOPY(' >',PROMPT(23)) 10 CALL PUTSTR(7,PROMPT,'$',0) 11 CALL GETSTR(5,STRING,2,I) IF (.NOT.(I.AND.CFIL)) GOTO 12 CLOSE(UNIT=5) CFIL=.FALSE. GOTO 10 12 IF (CFIL) CALL PUTSTR(7,STRING,'+',0) IF (STRING(1).EQ.0) GOTO 20 IF (STRING(1).EQ.'#') GOTO 100 IF (STRING(1).EQ.'^') GOTO 200 IF (STRING(1).EQ.'$') GOTO 100 DECODE(LEN(STRING),1,STRING,ERR=10) IBUFF(1) IF (ISEG.EQ.1) NSEG=IBUFF(1) CHANGE=.TRUE. C 20 CALL SCOPY('Next segment: ',PROMPT) ENCODE(2,1,PROMPT(21)) IBUFF(2) CALL SCOPY(' >',PROMPT(23)) 30 CALL PUTSTR(7,PROMPT,'$',0) 31 CALL GETSTR(5,STRING,2,I) IF (.NOT.(I.AND.CFIL)) GOTO 32 CLOSE(UNIT=5) CFIL=.FALSE. GOTO 31 32 IF (CFIL) CALL PUTSTR(7,STRING,'+',0) IF (STRING(1).EQ.0) GOTO 40 IF (STRING(1).EQ.'#') GOTO 100 IF (STRING(1).EQ.'^') GOTO 200 IF (STRING(1).EQ.'$') GOTO 100 DECODE(LEN(STRING),1,STRING,ERR=30) IBUFF(2) CHANGE=.TRUE. C 40 CALL SCOPY('High segment: ',PROMPT) ENCODE(2,1,PROMPT(21)) IBUFF(3) CALL SCOPY(' >',PROMPT(23)) 50 CALL PUTSTR(7,PROMPT,'$',0) 51 CALL GETSTR(5,STRING,2,I) IF (.NOT.(I.AND.CFIL)) GOTO 52 CLOSE(UNIT=5) CFIL=.FALSE. GOTO 51 52 IF (CFIL) CALL PUTSTR(7,STRING,'+',0) IF (STRING(1).EQ.0) GOTO 60 IF (STRING(1).EQ.'#') GOTO 100 IF (STRING(1).EQ.'^') GOTO 200 IF (STRING(1).EQ.'$') GOTO 100 DECODE(LEN(STRING),1,STRING,ERR=50) IBUFF(3) CHANGE=.TRUE. C 60 CALL SCOPY('Extra bytes: ',PROMPT) ENCODE(5,2,PROMPT(18)) IBUFF(4) CALL SCOPY(' >',PROMPT(23)) 70 CALL PUTSTR(7,PROMPT,'$',0) 71 CALL GETSTR(5,STRING,5,I) IF (.NOT.(I.AND.CFIL)) GOTO 72 CLOSE(UNIT=5) CFIL=.FALSE. GOTO 71 72 IF (CFIL) CALL PUTSTR(7,STRING,'+',0) IF (STRING(1).EQ.0) GOTO 80 IF (STRING(1).EQ.'#') GOTO 100 IF (STRING(1).EQ.'^') GOTO 200 IF (STRING(1).EQ.'$') GOTO 100 DECODE(LEN(STRING),2,STRING,ERR=70) IBUFF(4) CHANGE=.TRUE. C 80 CALL SCOPY('Start block: ',PROMPT) ENCODE(5,2,PROMPT(18)) IBUFF(5) CALL SCOPY(' >',PROMPT(23)) 90 CALL PUTSTR(7,PROMPT,'$',0) 91 CALL GETSTR(5,STRING,5,I) IF (.NOT.(I.AND.CFIL)) GOTO 92 CLOSE(UNIT=5) CFIL=.FALSE. GOTO 91 92 IF (CFIL) CALL PUTSTR(7,STRING,'+',0) IF (STRING(1).EQ.0) GOTO 99 IF (STRING(1).EQ.'#') GOTO 100 IF (STRING(1).EQ.'^') GOTO 200 IF (STRING(1).EQ.'$') GOTO 100 DECODE(LEN(STRING),2,STRING,ERR=90) IBUFF(5) CHANGE=.TRUE. C 99 PATHD=0 RETURN C 100 PATHD=1 RETURN C 200 PATHD=-1 RETURN END SUBROUTINE ERRTXT(IERROR) CALL PUTSTR(7,'?RDIR-F-','$',0) GOTO (10,20,30,40,50,60,70,80) IERROR 10 CALL PUTSTR(7,'No channel available','+',0) RETURN 20 CALL PUTSTR(7,'Input device or file not found','+',0) RETURN 30 CALL PUTSTR(7,'Read error','+',0) RETURN 40 CALL PUTSTR(7,'Unable to load input device handler','+',0) RETURN 50 CALL PUTSTR(7,'Write error','+',0) RETURN 60 CALL PUTSTR(7,'Unable to open output file','+',0) RETURN 70 CALL PUTSTR(7,'Invalid input','+',0) RETURN 80 CALL PUTSTR(7,'Unable to open input file','+',0) RETURN END SUBROUTINE FILASC(ISPEC,STRING,IDEF) BYTE STRING(16) DIMENSION ISPEC(4),IDEF(3) C DO 10, I=1,16 10 STRING(I)=0 CALL R50ASC(3,ISPEC(1),STRING) CALL TRIM(STRING) CALL CONCAT(STRING,':',STRING) L=LEN(STRING)+1 IF (ISPEC(2).EQ.0) GOTO 20 CALL R50ASC(6,ISPEC(2),STRING(L)) CALL TRIM(STRING) CALL CONCAT(STRING,'.',STRING) L=LEN(STRING)+1 CALL R50ASC(3,ISPEC(4),STRING(L)) CALL TRIM(STRING) RETURN C 20 IF (IDEF(1).EQ.0) RETURN CALL R50ASC(6,IDEF(1),STRING(L)) CALL TRIM(STRING) CALL CONCAT(STRING,'.',STRING) L=LEN(STRING)+1 CALL R50ASC(3,IDEF(3),STRING(L)) CALL TRIM(STRING) RETURN END FUNCTION ICHECK(NC,RC,LW) ! (c) H.Reints, 1983 BYTE LW(1),LC(14) DOUBLE PRECISION RC(NC) ICHECK=0 IF (NC.EQ.0) GOTO 50 KK=0 CALL TRIM(LW) LLW=LEN(LW) ! length of word DO 20, IC=1,NC ! check all possibilities CALL R50ASC(12,RC(IC),LC) ! convert to ASCII CALL TRIM(LC) CALL SCOMP(LC,LW,IDIF) ! compare IF (IDIF.EQ.0) GOTO 40 ! exactly equal IF (IDIF.LT.0) IDIF=-IDIF ! absolute value IF (IDIF.LE.LLW) GOTO 20 ! abbreviation 10 IF (KK.NE.0) GOTO 30 ! already found KK=IC ! set pointer 20 CONTINUE ! try next possibility ICHECK=KK ! OK or not found return GOTO 50 30 ICHECK=-1 ! ambiguous return GOTO 50 40 ICHECK=IC 50 RETURN END