C S E R V E R O N L Y K E R M I T C C written in January, 1986 by Skip Russell using Harris Fortran 77 C C C This program implements the "server" portion of the "Kermit" C protocol, as described in version 3 of the protocol manual (see C reference below). It is intended to facilitate the tranfer C of files between a Harris computer and other machines. It C incorporates mechanisms to maintain the integrity of data, even C over noisy phone lines, etc. Only the basic server functions C have been implemented in this initial version, i.e. send and C receive of text (7 bit ascii) files, and the "Finish" command. C Other functions/enhancements may be added to future versions C and will be documented under "revision history" below. C C I wrote this program especially for use on Harris computers C which are configured with a "MUX" as opposed to the more recent C CNP or DMACP I/O processors. As such, I have not taken advantage C of many of the special features offered by those devices (notably C timeouts and buffered I/O via "hot read"), but have opted instead C for simpler, albeit less efficient, modes of communication. In C any case, this program should work properly on a Harris machine C in any configuration. C C This program was written using Harris Fortran on a Harris C H100-1 computer (VOS 4.1.1 operating system). It was tested C at up to 9600 baud against Columbia University's "MSKERMIT" C version 2.27 (see below) on an IBM PC/AT running DOS 3.0. C C C -- REFERENCES -- C C For a complete discussion of the Kermit design philosophy and C detailed descriptions of Kermit commands, see the "KERMIT USER'S C GUIDE" by Frank da Cruz, Daphne Tzoar, and Bill Catchings. C C For a detailed description of the Kermit protocol, see the C "KERMIT PROTOCOL MANUAL" by Frank da Cruz and Bill Catchings. C C These two documents, as well as general information about Kermit, C MSKERMIT and other implementations of Kermit, are available for C the cost of distribution, from: C C KERMIT Distribution C Columbia University Center for Computing Activities C 612 West 115th Street C 7th Floor C New York, NY 10025 C C or send electronic mail to: Info-Kermit-Request@CU20B.ARPA C C C Address questions, fixes, comments about this implementation to: C C Skip Russell C Washington University School of Medicine C Division of Biostatistics C Box 8087, 660 South Euclid Avenue C St. Louis, Missouri 63110 C C electronic mail address: c04689sr@WUVMD.BITNET C C C -- REVISION HISTORY -- C C (change version number and date in header line if changes are made) C C version 1.00 Jan, 1986, by S.R. : initial release C C version 1.01 Feb, 1986, by S.R. : C brought up to version 5 of the protocol manual (dated April 1984) C and tested using MSKERMIT version 2.28; also implemented the C following remote commands: C -- HELP command to issue summary of available remote commands C -- LOGOUT ("bye") command to log off the Harris job C -- DIRECTORY command to issue information about a single disk C area (for now; plan to add wildcard match in future) C C version 1.02 Sept, 1986, by S.R. : C -- implemented full DIRECTORY command (wildcard character "?") C -- tested using MSKERMIT version 2.29 (dated 26 May 86) C -- moved to non-SAU Fortran 77 compiler for portablity C C version 1.03 Nov, 1986, by S.R. : C -- brought up to VOS 5.1.0 (required changes in interpretation of C file access bits in "REMOTE DIRECTORY" command handler) C -- fixed logic in RECVSW to correctly respond to error packets C C version 1.04 April, 1987, by S.R. : C -- added code to allow GETs of file groups using the "?" wildcard C character. C C version 1.05 May, 1987, by S.R. : C -- Corrected error in SWOPEN. GETs of file groups failed in C cases where the qualifier contained trailing blanks. The fix C consisted of enclosing the file name in quotes. C C version 1.06 June, 1987, by S.R. : C -- Added code in RDISK to distinguish between EOF and EOT. Harris C disk areas containing embedded EOFs can now be sent without C truncating trailing records. The EOF is sent as a record C containing the string "". C C C --------------------------------------------------------------------- C COMMON BLOCKS USED: LOGICAL DEBUG COMMON /DBGCOM/ DEBUG INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME INTEGER MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME COMMON /RCVCOM/ MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME INTEGER MXDATA PARAMETER (MXDATA=89) INTEGER DATA(MXDATA),NDATA,NSEQ,ISTAT,MAXTRY CHARACTER TYPE*1 WRITE (3,*) 'HARRIS KERMIT SERVER -- version 1.06 (June 87) SR' WRITE (3,*) C DEFINE DEFAULT SEND AND RECEIVE SPECS CALL KSTART MAXTRY = 10 C WAIT FOR A PACKET TO COME IN, THEN RESPOND 100 CALL RCVPKT(MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT) C WE GOT GARBAGE, NAK IT AND TRY AGAIN IF (ISTAT .NE. 0) THEN NDATA = 0 CALL SNDNAK(NSEQ) C WE GOT INIT IN ADVANCE OF SOME FUTURE COMMAND, JUST EXCHANGE INFO ELSE IF (TYPE .EQ. 'I') THEN CALL INIT(MXDATA,DATA,NDATA,NSEQ) C LOCAL "SEND" COMMAND (THEY WANT TO SEND A FILE TO US) ELSE IF (TYPE .EQ. 'S') THEN CALL RECVSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY) C LOCAL "GET" COMMAND (THEY WANT A FILE FROM US) ELSE IF (TYPE .EQ. 'R') THEN CALL SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY) C 'GENERIC' COMMAND (THEY WANT US TO LOG OFF OR SOMETHING) ELSE IF (TYPE .EQ. 'G') THEN CALL COMMND(MXDATA,DATA,NDATA,NSEQ,MAXTRY,ISTAT) IF (ISTAT .NE. 0) GO TO 999 C WE GOT AN ERROR PACKET, JUST ACKNOWLEDGE IT ELSE IF (TYPE .EQ. 'E') THEN NDATA = 0 CALL SNDACK(DATA,NDATA,NSEQ) C ANYTHING ELSE IS AN ERROR, AS FAR AS WE'RE CONCERNED ELSE CALL SNDERR('server command not implemented',MXDATA,DATA,NSEQ) END IF GO TO 100 999 CALL KFINSH END SUBROUTINE KSTART C--- C--- DEFINE DEFAULT SEND AND RECEIVE SPECS C--- LOGICAL DEBUG COMMON /DBGCOM/ DEBUG INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME INTEGER MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME COMMON /RCVCOM/ MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME INTEGER IOPT C HANDLE DEBUG MODE (SPECIFIED USING "KERMIT.D") CALL OPTION(IOPT) IF ((IOPT.AND.2**3) .GT. 0) THEN ! OPTION "D" SPECIFIED DEBUG = .TRUE. IOPT = IOPT .XOR. 2**3 ELSE ! NOT SPECIFIED DEBUG = .FALSE. END IF IF (IOPT.NE.0) STOP "*ERROR* valid option is 'D' for debug mode" IF (DEBUG) THEN WRITE (3,*) '[writing packet contents to LO for debugging]' ELSE WRITE (3,*) '[logging names of send/receive files to LO]' END IF WRITE (3,*) C DEFAULT SEND SPECS MSPSIZ = 94 ! BIGGEST PACKET THEY CAN RECEIVE NSTIME = 0 ! WHEN THEY WANT TIMEOUT NSPAD = 0 ! HOW MUCH PADDING TO SEND THEM NSPCHR = 0 ! PAD CHARACTER TO USE NSEOL = 13 ! EOL TO SEND THEM (CR) NSQUOT = ICHAR('#') ! INCOMING DATA QUOTE CHARACTER C DEFAULT RECEIVE SPECS MRPSIZ = 78 ! BIGGEST PACKET I CAN RECEIVE MYTIME = 13 ! WHEN I WANT TIMEOUT MYPAD = 0 ! HOW MUCH PADDING TO SEND ME MYPCHR = 10 ! PAD CHARACTER TO USE (LINEFEED) MYEOL = 13 ! EOL TO SEND ME (CR) MYQUOT = ICHAR('#') ! QUOTE CHARACTER I WILL SEND THEM CCCC WARN ABOUT XON/XOFF IF CONTROL/S IS AN ABORT CHAR ON THIS CCCC MACHINE CCC CCC WRITE (3,*) 'DO NOT USE XON/XOFF (SET FLOW NONE)' WRITE (3,*) WRITE (3,*) 'SERVER MODE ENABLED -- type the appropriate key' WRITE (3,*) 'sequence to escape back to your local Kermit...' END SUBROUTINE KFINSH C--- C--- CLOSE UP C--- INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME CALL PUT1CW(NSEOL,1) CLOSE (UNIT=6) CLOSE (UNIT=7) CLOSE (UNIT=50) END SUBROUTINE INIT(MXDATA,DATA,NDATA,NSEQ) C--- C--- HANDLE INITIAL PACKET, RESPOND WITH ACK AND OUR PARAMETERS C--- INTEGER MXDATA,DATA(*),NDATA,NSEQ C READ THEIR PACKET CALL RPAR(DATA,NDATA) C ACK WITH OUR INIT PACKET CALL SPAR(MXDATA,DATA,NDATA) CALL SNDACK(DATA,NDATA,NSEQ) END C TRANSMIT SUBROUTINES C C SENDSW -- STATE TABLE SWITCHER FOR SENDING FILES C SOPEN -- OPENS FILE TO SEND TO RECEIVING KERMIT C SINIT -- EXCHANGE SEND/RECEIVE INFO WITH RECEIVING KERMIT C SFILE -- SENDS FILE NAME TO RECEIVING KERMIT C SDATA -- SENDS FILE CONTENTS TO RECEIVING KERMIT C SEOF -- SENDS "END-OF-FILE" PACKET TO RECEIVING KERMIT C SBREAK -- SENDS "BREAK" PACKET TO RECEIVING KERMIT C RDISK -- READS A SINGLE CHARACTER FROM A DISK FILE C SWINIT -- EXPANDS LIST OF WILDCARD FILE NAMES C SWOPEN -- OPENS THE NEXT FILE IN A LIST OF WILDCARD FILENAMES C SWCLOS -- CLOSES THE LIST OF WILDCARD FILE NAMES C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY) C--- C--- THIS IS THE STATE TABLE SWITCHER FOR SENDING FILES. C--- IT LOOPS UNTIL EITHER IT IS FINISHED OR A FAULT IS ENCOUNTERED. C--- INTEGER MXDATA,DATA(*),NDATA,NSEQ,MAXTRY LOGICAL DEBUG COMMON /DBGCOM/ DEBUG CHARACTER STATE*1 INTEGER NUMTRY,ISTAT C ASSIGN THE FILE CALL SOPEN(MXDATA,DATA,NDATA,NSEQ,ISTAT) IF (ISTAT .NE. 0) GO TO 800 STATE = 'S' NSEQ = 0 100 CONTINUE FOR NUMTRY=1,MAXTRY IF (STATE .EQ. 'S') THEN ! SEND INIT PACKET CALL SINIT(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT) ELSE IF (STATE .EQ. 'F') THEN ! SEND FILE-HEADER PACKET CALL SFILE(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT) ELSE IF (STATE .EQ. 'D') THEN ! SEND FILE-DATA PACKET CALL SDATA(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT) ELSE IF (STATE .EQ. 'Z') THEN ! SEND EOF PACKET CALL SEOF(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT) ELSE IF (STATE .EQ. 'B') THEN ! SEND BREAK (EOT) PACKET CALL SBREAK(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT) ELSE IF (STATE .EQ. 'C') THEN ! COMPLETE GO TO 900 ELSE IF (STATE .EQ. 'A') THEN ! ABORT GO TO 800 ELSE WRITE (*,*) 'FATAL ERROR: INVALID STATE IN "SENDSW"' STOP END IF IF (ISTAT .EQ. 0) GO TO 500 END FOR CALL SNDERR('too many retries',MXDATA,DATA,NSEQ) GO TO 800 500 NSEQ = MOD( NSEQ+1, 64 ) GO TO 100 800 IF (DEBUG) WRITE (*,*) '--- ABORT ---' RETURN 900 IF (DEBUG) WRITE (*,*) '=== SEND COMPLETE ===' RETURN END SUBROUTINE SOPEN(MXDATA,DATA,NDATA,NSEQ,ISTAT) C--- C--- OPEN FILE TO SEND THEM C--- INTEGER MXDATA,DATA(*),NDATA,NSEQ,ISTAT LOGICAL DEBUG COMMON /DBGCOM/ DEBUG CHARACTER FILNAM*19 LOGICAL QMARK INTEGER I FILNAM = ' ' QMARK = .FALSE. FOR I=1,MIN( NDATA, LEN(FILNAM) ) FILNAM(I:I) = CHAR( DATA(I) ) IF ( DATA(I) .EQ. ICHAR('?') ) QMARK = .TRUE. END FOR C CHECK FOR VALID WILDCARD FILE NAME AND OPEN THE FIRST FILE IF (QMARK) THEN CALL SWINIT(FILNAM,MXDATA,DATA,NDATA,NSEQ,ISTAT) ELSE CALL SWCLOS() C CHECK FOR VALID FILE NAME AND OPEN THE FILE WRITE (*,*) 'OPENING ', FILNAM(1:NDATA), ' FOR SEND' OPEN (UNIT=50, FILE=FILNAM, STATUS='OLD', IOSTAT=ISTAT) IF (ISTAT .NE. 0) THEN CALL SNDERR('can''t find specified file',MXDATA,DATA,NSEQ) END IF END IF END SUBROUTINE SINIT(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT) C--- C--- SEND INIT PACKET AND GET THEIRS IN RESPONSE C--- CHARACTER STATE*1 INTEGER NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT INTEGER NDATA,RSEQ C SEND OUR INIT PACKET CALL SPAR(MXDATA,DATA,NDATA) CALL SNDPKT(DATA,NDATA,NSEQ,'S') C GET THEIR INIT PACKET IN RESPONSE CALL RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT) IF (ISTAT .LT. 0) GO TO 800 ! RECEIVED ERR IF (ISTAT .NE. 0) GO TO 810 ! RECEIVED NAK 100 CALL RPAR(DATA,NDATA) GO TO 900 800 ISTAT = -1 ! ABORT STATE = 'A' RETURN 810 ISTAT = 1 ! UNSUCCESSFUL RETURN 900 ISTAT = 0 ! SUCCESSFUL STATE = 'F' RETURN END SUBROUTINE SFILE(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT) C--- C--- SEND FILE HEADER PACKET C--- CHARACTER STATE*1 INTEGER NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT LOGICAL DEBUG COMMON /DBGCOM/ DEBUG CHARACTER FILNAM*17 LOGICAL OPENED,NAMED INTEGER NDATA,MXRCV,C,I C SEND FILE NAME IF (NUMTRY .EQ. 1) THEN INQUIRE (UNIT=50, OPENED=OPENED, NAMED=NAMED, NAME=FILNAM) IF (.NOT. (OPENED .AND. NAMED) ) THEN CALL SNDERR('read file error',MXDATA,DATA,NSEQ) GO TO 800 END IF NDATA = 0 FOR I=9,16 ! AREANAME C = ICHAR( FILNAM(I:I) ) DATA(I-8) = C IF (C .NE. ICHAR(' ')) NDATA = I-8 END FOR CCC CCC THE FOLLOWING LINES ARE COMMENTED OUT. THEY CAN BE RESTORED CCC IF ONE DESIRES TO USE THE FIRST THREE ALPHABETIC CHARACTERS CCC OF THE QUALIFIER AS THE FILENAME EXTENSION, E.G. FOR DOS MACHINES. CCC CCC NDATA = NDATA + 1 CCC DATA(NDATA) = ICHAR('.') CCC FOR I=5,7 ! PART OF QUALIFIER CCC C = ICHAR( FILNAM(I:I) ) CCC IF (C .NE. ICHAR(' ')) THEN CCC NDATA = NDATA + 1 CCC DATA(NDATA) = C CCC END IF CCC END FOR CALL SNDPKT(DATA,NDATA,NSEQ,'F') ELSE CALL RESEND END IF C GET THEIR RESPONSE MXRCV = 0 CALL RCVACK(MXRCV,DATA,NDATA,NSEQ,ISTAT) IF (ISTAT .LT. 0) GO TO 800 ! RECEIVED ERR IF (ISTAT .NE. 0) GO TO 810 ! RECEIVED NAK C PREPARE TO READ FILE CALL RDINIT(ISTAT) IF (ISTAT .NE. 0) GO TO 910 GO TO 900 800 ISTAT = -1 ! ABORT STATE = 'A' RETURN 810 ISTAT = 1 ! UNSUCCESSFUL RETURN 900 ISTAT = 0 ! SUCCESSFUL STATE = 'D' RETURN 910 ISTAT = 0 ! SUCCESSFUL BUT EMPTY FILE STATE = 'Z' RETURN END SUBROUTINE SDATA(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT) C--- C--- SEND FILE DATA PACKET C--- CHARACTER STATE*1 INTEGER NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT INTEGER MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME COMMON /RCVCOM/ MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME LOGICAL ISCTRL INTEGER CTL LOGICAL EOF INTEGER NDATA,NEWCHR,MXRCV C GET NEXT PACKETFULL OF DATA AND SEND IT IF (NUMTRY .EQ. 1) THEN NDATA = 0 EOF = .FALSE. C GET NEXT CHARACTER FROM THE DISK FILE 100 IF (EOF .OR. NDATA+2 .GT. MXDATA) GO TO 200 CALL RDISK(NEWCHR,ISTAT) IF (ISTAT .NE. 0) EOF = .TRUE. C QUOTE IF SPECIAL CHARACTER, THEN COPY TO THE PACKET BUFFER IF ( ISCTRL(NEWCHR) .OR. (NEWCHR .EQ. MYQUOT) ) THEN NDATA = NDATA + 1 DATA(NDATA) = MYQUOT IF ( NEWCHR .NE. MYQUOT ) NEWCHR = CTL(NEWCHR) SR 9/86 END IF NDATA = NDATA + 1 DATA(NDATA) = NEWCHR GO TO 100 200 CALL SNDPKT(DATA,NDATA,NSEQ,'D') ELSE CALL RESEND END IF C GET THEIR RESPONSE MXRCV = 0 CALL RCVACK(MXRCV,DATA,NDATA,NSEQ,ISTAT) IF (ISTAT .LT. 0) GO TO 800 ! RECEIVED ERR IF (ISTAT .NE. 0) GO TO 810 ! RECEIVED NAK IF (EOF) GO TO 910 GO TO 900 800 ISTAT = -1 ! ABORT STATE = 'A' RETURN 810 ISTAT = 1 ! UNSUCCESSFUL RETURN 900 ISTAT = 0 ! SUCCESSFUL RETURN 910 ISTAT = 0 ! SUCCESSFUL AND AT END-OF-FILE STATE = 'Z' RETURN END SUBROUTINE SEOF(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT) C--- C--- SEND END-OF-FILE PACKET C--- CHARACTER STATE*1 INTEGER NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT LOGICAL WLDSND COMMON /SWCOM/ WLDSND INTEGER NDATA C CLOSE FILE AND SEND EMPTY "Z" PACKET IF (NUMTRY .EQ. 1) THEN CALL RDCLOS NDATA = 0 CALL SNDPKT(DATA,NDATA,NSEQ,'Z') ELSE CALL RESEND END IF C GET THEIR RESPONSE CALL RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT) IF (ISTAT .LT. 0) GO TO 800 ! RECEIVED ERR IF (ISTAT .NE. 0) GO TO 810 ! RECEIVED NAK WRITE (*,*) '=SEND OF CURRENT FILE COMPLETE=' C IF THERE ARE MORE FILES TO SEND, OPEN THE NEXT FILE IF (WLDSND) THEN CALL SWOPEN(ISTAT) IF (ISTAT .LT. 0) THEN CALL SNDERR('can''t find specified file',MXDATA,DATA,NSEQ) GO TO 800 END IF END IF GO TO 900 800 ISTAT = -1 ! ABORT STATE = 'A' RETURN 810 ISTAT = 1 ! UNSUCCESSFUL RETURN 900 ISTAT = 0 ! SUCCESSFUL IF (WLDSND) THEN STATE = 'F' ELSE STATE = 'B' END IF RETURN END SUBROUTINE SBREAK(STATE,NUMTRY,MXDATA,DATA,NSEQ,ISTAT) C--- C--- SEND END-OF-FILE PACKET C--- CHARACTER STATE*1 INTEGER NUMTRY,MXDATA,DATA(*),NSEQ,ISTAT INTEGER NDATA C SEND EMPTY "B" PACKET NDATA = 0 CALL SNDPKT(DATA,NDATA,NSEQ,'B') C GET THEIR RESPONSE CALL RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT) IF (ISTAT .LT. 0) GO TO 800 ! RECEIVED ERR IF (ISTAT .NE. 0) GO TO 810 ! RECEIVED NAK GO TO 900 800 ISTAT = -1 ! ABORT STATE = 'A' RETURN 810 ISTAT = 1 ! UNSUCCESSFUL RETURN 900 ISTAT = 0 ! SUCCESSFUL STATE = 'C' RETURN END SUBROUTINE RDISK(NEWCHR,ISTAT) C--- C--- READS A SINGLE CHARACTER FROM A DISK FILE C--- C--- ENTRY POINT "RDINIT" INITIALIZES C--- ENTRY POINT "RDCLOS" FINISHES C--- INTEGER NEWCHR,ISTAT LOGICAL DEBUG COMMON /DBGCOM/ DEBUG INTEGER MAXW,MAXC PARAMETER (MAXW=100, MAXC=3*MAXW) INTEGER BUFW(MAXW) INTEGER*1 BUFC(MAXC+9) EQUIVALENCE (BUFW,BUFC) LOGICAL EOF INTEGER IBUF,NBUF,NBUFW,CR,LF,I SAVE EOF,BUFW,IBUF,NBUF DATA EOF /.TRUE./ DATA CR, LF /13, 10/ IF (EOF) THEN IF (DEBUG) WRITE (*,*) '*FATAL ERROR* RDISK NOT INITIALIZED' STOP END IF C GET NEXT CHARACTER FROM BUFFER IBUF = IBUF + 1 NEWCHR = BUFC(IBUF) C SEE IF WE HAVE JUST EMPTIED THE BUFFER 100 IF (IBUF .GE. NBUF) THEN IBUF = 0 NBUF = 0 C READ NEXT RECORD FROM DISK BUFFER IN(50,BUFW,S,MAXW,ISTAT,NBUFW) CALL STATUS(50) IF (ISTAT .NE. 2 .AND. ISTAT .NE. 3) THEN IF (DEBUG .AND. ISTAT .NE. 4) + WRITE (*,*) 'RDISK: DISK READ ERROR ON BUFFER IN', ISTAT EOF = .TRUE. GO TO 800 END IF C FIND LENGTH TO LAST NON-BLANK FOR I=NBUFW*3,1,-1 IF (BUFC(I) .NE. ICHAR(' ')) THEN NBUF = I EXIT FOR END IF END FOR C APPEND "" IF AN EMBEDDED EOF WAS FOUND IF (ISTAT .EQ. 3) THEN IF (DEBUG) WRITE (*,*) '(FOUND EMBEDDED EOF)' IF (NBUF .GT. 0) THEN NBUF = NBUF + 1 BUFC(NBUF) = CR NBUF = NBUF + 1 BUFC(NBUF) = LF END IF NBUF = NBUF + 1 BUFC(NBUF) = '<' NBUF = NBUF + 1 BUFC(NBUF) = 'E' NBUF = NBUF + 1 BUFC(NBUF) = 'O' NBUF = NBUF + 1 BUFC(NBUF) = 'F' NBUF = NBUF + 1 BUFC(NBUF) = '>' END IF C APPEND CR/LF NBUF = NBUF + 1 BUFC(NBUF) = CR NBUF = NBUF + 1 BUFC(NBUF) = LF END IF GO TO 900 800 ISTAT = 1 ! EOF OR ERROR (CURRENT CHARACTER IS THE LAST ONE) RETURN 900 ISTAT = 0 ! SUCCESSFUL RETURN C--- C--- INITIALIZE AND READ FIRST RECORD C--- ENTRY RDINIT(ISTAT) IBUF = 0 NBUF = 0 EOF = .FALSE. GO TO 100 C--- C--- CLOSE FILE C--- ENTRY RDCLOS IF (.NOT. EOF) THEN IF (DEBUG) WRITE (*,*) '*WARNING* SENT INCOMPLETE FILE' NBUF = 0 END IF CLOSE (UNIT=50) RETURN END SUBROUTINE SWINIT(AREANM,MXDATA,DATA,NDATA,NSEQ,ISTAT) C--- C--- ASSEMBLE A LIST OF NAMES OF FILES TO SEND IN RESPONSE TO A C--- "GET" COMMAND CONTAINING WILDCARD CHARACTERS C--- CHARACTER AREANM*(*) INTEGER MXDATA,DATA(*),NDATA,NSEQ,ISTAT CHARACTER DIRFIL*17, ERRMSG*80 LOGICAL SIZEORD INTEGER LFN,NARGC,NEWCHR,I DATA DIRFIL /'W1'/ DATA LFN /99/ C CONVERT THE FILE NAME TO UPPER CASE NARGC = MIN( NDATA, LEN(AREANM) ) FOR I=1,NARGC NEWCHR = ICHAR( AREANM(I:I) ) IF (NEWCHR .GT. ICHAR('a') .AND. NEWCHR .LT. ICHAR('z') ) THEN NEWCHR = NEWCHR - ICHAR('a') + ICHAR('A') AREANM(I:I) = CHAR( NEWCHR ) END IF END FOR C OPEN A DIRECTORY WORKFILE OPEN (UNIT=LFN, FILE=DIRFIL, STATUS='OLD', IOSTAT=ISTAT) IF (ISTAT .NE. 0) GO TO 810 REWIND (UNIT=LFN) C WRITE DIRECTORY INFORMATION TO THE WORKFILE SIZEORD = .FALSE. CALL DIR(LFN,AREANM,NARGC,SIZEORD,ERRMSG,ISTAT) IF (ISTAT .NE. 0) GO TO 800 C PREPARE TO SEND THE FIRST FILE REWIND (UNIT=LFN) CALL SWOPEN(ISTAT) IF (ISTAT .NE. 0) GO TO 820 GO TO 900 800 CALL SNDERR(ERRMSG,MXDATA,DATA,NSEQ) CLOSE (UNIT=LFN) RETURN 810 CALL SNDERR('directory workfile inaccessable',MXDATA,DATA,NSEQ) RETURN 820 CALL SNDERR('file not accessible',MXDATA,DATA,NSEQ) RETURN 900 RETURN END SUBROUTINE SWOPEN(ISTAT) C--- C--- OPEN THE NEXT FILE IN A LIST OF FILES TO SEND C--- INTEGER ISTAT CHARACTER FILNAM*19, BUF*80 INTEGER LFN LOGICAL WLDSND COMMON /SWCOM/ WLDSND DATA LFN /99/ C READ NEXT ENTRY FROM THE FILE NAME LIST DO READ (LFN, '(A)', END=800) BUF UNTIL ( BUF(9:9) .EQ. '*' .OR. BUF(16:16) .EQ. '*' ) IF ( BUF(9:9) .EQ. '*' ) THEN FILNAM = '"' // BUF(1:17) // '"' ELSE FILNAM = '"' // BUF(8:24) // '"' END IF WRITE (*,*) 'OPENING ', FILNAM, ' FOR SEND' OPEN (UNIT=50, FILE=FILNAM, STATUS='OLD', IOSTAT=ISTAT) IF (ISTAT .NE. 0) GO TO 810 GO TO 900 800 ISTAT = 1 ! NO MORE FILE NAMES IN LIST CALL SWCLOS() WLDSND = .FALSE. RETURN 810 ISTAT = -1 ! FILE OPEN UNSUCCESFUL WLDSND = .FALSE. RETURN 900 ISTAT = 0 ! FILE OPEN SUCCESFUL WLDSND = .TRUE. END SUBROUTINE SWCLOS() C--- C--- CLOSE THE FILE CONTAINING THE LIST OF FILES TO SEND C--- INTEGER LFN LOGICAL WLDSND COMMON /SWCOM/ WLDSND DATA LFN /99/ C IF THE FILE IS OPEN, CLOSE IT IF (WLDSND) THEN CLOSE (UNIT=LFN) WLDSND = .FALSE. END IF END C RECEIVE SUBROUTINES C C RECVSW -- PACKET TYPE SWITCHER FOR RECEIVING FILES C RINIT -- EXCHANGE SEND/RECEIVE INFO WITH SENDING KERMIT C RFILE -- RECIEVES FILE NAME AND CREATES RECEIVE FILE C RDATA -- RECEIVES FILE CONTENTS FROM SENDING KERMIT C REOF -- RECEIVES "END-OF-FILE" PACKET FROM SENDING KERMIT C RBREAK -- RECEIVES "BREAK" PACKET FROM SENDING KERMIT C WDISK -- WRITES A SINGLE CHARACTER TO A DISK FILE C ENPAD -- PADS OUTPUT RECORD TO A WORD BOUNDARY C DELFIL -- DELETES A FILE PARTIALLY RECEIVED C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE RECVSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY) C--- C--- THIS IS THE PACKET TYPE SWITCHER FOR RECEIVING FILES. C--- IT LOOPS UNTIL EITHER IT IS FINISHED OR A FAULT IS ENCOUNTERED. C--- INTEGER MXDATA,DATA(*),NDATA,NSEQ,MAXTRY LOGICAL DEBUG COMMON /DBGCOM/ DEBUG LOGICAL FILOPN INTEGER NUMTRY,OLDSEQ,ISTAT CHARACTER STATE*1,TYPE*1 STATE = 'I' TYPE = 'I' FILOPN = .FALSE. OLDSEQ = NSEQ 100 IF (TYPE .EQ. 'I') THEN ! GOT INIT PACKET CALL RINIT(STATE,MXDATA,DATA,NDATA,NSEQ) ELSE IF (TYPE .EQ. 'F') THEN ! GOT FILE-HEADER PACKET CALL RFILE(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT) IF (ISTAT .EQ. 0) FILOPN = .TRUE. ELSE IF (TYPE .EQ. 'D') THEN ! GOT FILE-DATA PACKET CALL RDATA(STATE,MXDATA,DATA,NDATA,NSEQ) ELSE IF (TYPE .EQ. 'Z') THEN ! GOT EOF PACKET CALL REOF(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT) IF (ISTAT .EQ. 0) FILOPN = .FALSE. ELSE IF (TYPE .EQ. 'B') THEN ! GOT BREAK PACKET CALL RBREAK(STATE,MXDATA,DATA,NDATA,NSEQ) ELSE IF (TYPE .EQ. 'E') THEN ! GOT ERROR PACKET NDATA = 0 CALL SNDACK(DATA,NDATA,NSEQ) STATE = 'A' ELSE IF (DEBUG) WRITE (*,*) 'INVALID PACKET TYPE' STATE = 'A' END IF IF (STATE .EQ. 'A') GO TO 800 ! ABORT IF (STATE .EQ. 'C') GO TO 900 ! COMPLETE C RECEIVE A NEW PACKET FOR NUMTRY=1,MAXTRY CALL RCVPKT(MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT) IF (ISTAT .EQ. 0) THEN C GOT THE RIGHT PACKET? CCC IF (NSEQ .EQ. MOD( OLDSEQ+1, 64 ) ) THEN SR11/86 IF (NSEQ .EQ. MOD( OLDSEQ+1, 64 ) .OR. TYPE .EQ. 'E') THEN SR11/86 OLDSEQ = NSEQ GO TO 100 C NO. GOT PREVIOUS PACKET AGAIN BY MISTAKE? ELSE IF (NSEQ .EQ. OLDSEQ) THEN IF (NUMTRY .LT. MAXTRY) CALL RESEND GO TO 200 END IF END IF C NO. NAK IT AND TRY AGAIN UP TO MAXTRY TIMES IF (NUMTRY .LT. MAXTRY) CALL SNDNAK(NSEQ) 200 CONTINUE END FOR CALL SNDERR('too many retries',MXDATA,DATA,NSEQ) GO TO 800 800 IF (DEBUG) WRITE (*,*) '--- ABORT ---' IF (FILOPN) CALL DELFIL ! ERASE PARTIAL FILE RETURN 900 IF (DEBUG) WRITE (*,*) '=== RECEIVE COMPLETE ===' RETURN END SUBROUTINE RINIT(STATE,MXDATA,DATA,NDATA,NSEQ) C--- C--- GOT RECEIVE-INIT PACKET, RESPOND WITH ACK AND OUR PARAMETERS C--- CHARACTER STATE*1 INTEGER MXDATA,DATA(*),NDATA,NSEQ CALL INIT(MXDATA,DATA,NDATA,NSEQ) STATE = 'F' END SUBROUTINE RFILE(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT) C--- C--- GOT FILE HEADER PACKET, CREATE THE SPECIFED FILE C--- CHARACTER STATE*1 INTEGER MXDATA,DATA(*),NDATA,NSEQ,ISTAT LOGICAL DEBUG COMMON /DBGCOM/ DEBUG LOGICAL WRKFIL CHARACTER FILNAM*40 INTEGER IDOT,IAST,I IF (STATE .NE. 'F') THEN CALL SNDERR('not expecting F packet',MXDATA,DATA,NSEQ) GO TO 800 END IF C ASSEMBLE HARRIS FILE NAME FILNAM = ' ' IDOT = 0 IAST = 0 NDATA = MIN( NDATA, MXDATA, LEN(FILNAM) ) FOR I=1,NDATA FILNAM(I:I) = CHAR( DATA(I) ) IF (FILNAM(I:I) .EQ. '.') IDOT = I IF (FILNAM(I:I) .EQ. '*') IAST = I END FOR IF (IDOT .GT. 0 .AND. IAST .EQ. 0) THEN C TRANSLATE IBM-PC STYLE FILENAME IF (IDOT .EQ. NDATA) THEN NDATA = MIN( 8, IDOT-1 ) ELSE IF (NDATA .GT. 8) THEN NDATA = 8 IF (IDOT .GT. 7) FILNAM(7:8) = '.' // CHAR( DATA(IDOT+1) ) END IF END IF C MAKE SURE THE FILE NAME IS VALID AND RESPOND WRITE (*,*) 'OPENING FILE ', FILNAM(1:NDATA), ' FOR RECEIVE' OPEN(UNIT=50, FILE=FILNAM(1:NDATA), STATUS='OLD', IOSTAT=ISTAT) IF (ISTAT .EQ. 0) THEN IF (WRKFIL(50)) GO TO 200 CLOSE (UNIT=50) CALL SNDERR( FILNAM(1:NDATA) // ' exists', MXDATA,DATA,NSEQ) GO TO 800 END IF OPEN(UNIT=50, FILE=FILNAM(1:NDATA), STATUS='NEW', IOSTAT=ISTAT) IF (ISTAT .NE. 0) THEN C CAN'T CREATE FILE CALL SNDERR( 'filename ' // FILNAM(1:NDATA) // ' is invalid', + MXDATA,DATA,NSEQ) GO TO 800 END IF 200 CALL WDINIT NDATA = 0 CALL SNDACK(DATA,NDATA,NSEQ) GO TO 900 800 ISTAT = -1 STATE = 'A' RETURN 900 ISTAT = 0 STATE = 'D' RETURN END SUBROUTINE RDATA(STATE,MXDATA,DATA,NDATA,NSEQ) C--- C--- GOT DATA PACKET, WRITE TO FILE C--- CHARACTER STATE*1 INTEGER MXDATA,DATA(*),NDATA,NSEQ INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME INTEGER CTL INTEGER IDATA,NEWCHR IF (STATE .NE. 'D') THEN CALL SNDERR('not expecting D packet',MXDATA,DATA,NSEQ) GO TO 800 END IF C UNPACK DATA AND WRITE TO FILE IDATA = 0 C EXTRACT NEXT CHARACTER OF DATA FROM PACKET 100 IF (IDATA .GE. NDATA) GO TO 200 IDATA = IDATA + 1 NEWCHR = DATA(IDATA) IF (NEWCHR .EQ. NSQUOT) THEN ! UNCONTROLLIFY QUOTED CHARACTER IF (IDATA .LT. NDATA) THEN IDATA = IDATA + 1 NEWCHR = DATA(IDATA) IF (NEWCHR .NE. NSQUOT) NEWCHR = CTL( NEWCHR ) END IF END IF C TRANSFER IT TO THE DISK FILE CALL WDISK(NEWCHR) GO TO 100 200 NDATA = 0 CALL SNDACK(DATA,NDATA,NSEQ) GO TO 900 800 STATE = 'A' RETURN 900 STATE = 'D' RETURN END SUBROUTINE REOF(STATE,MXDATA,DATA,NDATA,NSEQ,ISTAT) C--- C--- GOT EOF PACKET, CLOSE FILE C--- CHARACTER STATE*1 INTEGER MXDATA,DATA(*),NDATA,NSEQ,ISTAT IF (STATE .EQ. 'F') GO TO 100 IF (STATE .NE. 'D') THEN CALL SNDERR('not expecting Z packet',MXDATA,DATA,NSEQ) GO TO 800 END IF C HANDLE SPECIAL Z PACKET INSTRUCTING US TO DISCARD CURRENT FILE IF (NDATA .EQ. 1 .AND. DATA(1) .EQ. ICHAR('D') ) THEN CALL DELFIL ELSE CALL WDCLOS WRITE (*,*) '=RECEIVE OF CURRENT FILE COMPLETE=' END IF 100 NDATA = 0 CALL SNDACK(DATA,NDATA,NSEQ) GO TO 900 800 ISTAT = -1 STATE = 'A' RETURN 900 ISTAT = 0 STATE = 'F' RETURN END SUBROUTINE RBREAK(STATE,MXDATA,DATA,NDATA,NSEQ) C--- C--- GOT BREAK PACKET, WE'RE DONE C--- CHARACTER STATE*1 INTEGER MXDATA,DATA(*),NDATA,NSEQ IF (STATE .NE. 'F') THEN CALL SNDERR('not expecting B packet',MXDATA,DATA,NSEQ) GO TO 800 END IF NDATA = 0 CALL SNDACK(DATA,NDATA,NSEQ) GO TO 900 800 STATE = 'A' RETURN 900 STATE = 'C' RETURN END SUBROUTINE WDISK(NEWCHR) C--- C--- WRITES A CHARACTER TO A DISK FILE C--- C--- ENTRY POINT "WDINIT" INITIALIZES C--- ENTRY POINT "WDCLOS" FINISHES C--- INTEGER NEWCHR LOGICAL DEBUG COMMON /DBGCOM/ DEBUG INTEGER MAXW,MAXC PARAMETER (MAXW=100, MAXC=3*MAXW) INTEGER BUFW(MAXW) INTEGER*1 BUFC(MAXC) EQUIVALENCE (BUFW,BUFC) INTEGER NBUF,CR,LF,I SAVE BUFW,NBUF DATA CR, LF /13, 10/ IF (NEWCHR .EQ. CR) THEN C WRITE COMPLETED RECORD CALL ENPAD(BUFC,NBUF) WRITE (50,'(100A3)') (BUFW(I), I=1,NBUF/3) NBUF = 0 ELSE IF (NEWCHR .EQ. LF .AND. NBUF .EQ. 0) THEN C IGNORE LINEFEED FROM A CR/LF PAIR ELSE C ADD CHARACTER TO RECORD BUFFER NBUF = NBUF + 1 BUFC(NBUF) = NEWCHR END IF RETURN C--- C--- INITIALIZE CHARACTER COUNT C--- ENTRY WDINIT() NBUF = 0 RETURN C--- C--- WRITE LAST RECORD IF INCOMPLETE AND CLOSE FILE C--- ENTRY WDCLOS() IF (NBUF .GT. 0) THEN IF (DEBUG) WRITE (*,*) '*WARNING* NO EOL FOUND ON LAST RECORD' CALL ENPAD(BUFC,NBUF) WRITE (50,'(100A3)') (BUFW(I), I=1,NBUF/3) NBUF = 0 END IF CLOSE (UNIT=50) RETURN END SUBROUTINE ENPAD(BUFC,NBUF) C--- C--- PAD OUTPUT RECORD TO WORD BOUNDARY WITH BLANKS C--- INTEGER*1 BUFC(*) INTEGER NBUF INTEGER I FOR I=MOD(NBUF+2,3),1 NBUF = NBUF + 1 BUFC(NBUF) = ICHAR(' ') END FOR END SUBROUTINE DELFIL C--- C--- ERASE PARTIAL FILE ---NOT IMPLEMENTED YET--- C--- WRITE (*,*) '-CURRENT RECEIVE CANCELLED-' CLOSE (UNIT=50) END C REMOTE COMMAND SUBROUTINES C C COMMND -- REMOTE COMMAND HANDLER, CALLS THE FOLLOWING: C HELP -- SENDS USAGE INFORMATION TO RECEIVING KERMIT C LOGOUT -- PREPARES TO SIGN THE CURRENT USER OFF THE SYSTEM C FINISH -- PREPARES TO EXIT KERMIT SERVER C DIRECT -- SENDS DIRECTORY INFORMATION TO RECEIVING KERMIT C CMDARG -- EXTRACT A COMMAND ARGUMENT FROM PACKET C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE COMMND(MXDATA,DATA,NDATA,NSEQ,MAXTRY,ISTAT) C--- C--- MAIN ROUTINE HANDLING REMOTE COMMANDS C--- INTEGER MXDATA,DATA(*),NDATA,NSEQ,MAXTRY,ISTAT LOGICAL DEBUG COMMON /DBGCOM/ DEBUG CHARACTER*1 CMD C GET THE COMMAND IF (NDATA .LE. 0) GO TO 900 CMD = CHAR( DATA(1) ) IF (CMD .EQ. 'H') THEN ! HELP CALL HELP(MAXTRY,MXDATA,DATA) ELSE IF (CMD .EQ. 'L') THEN ! LOGOUT CALL LOGOUT(MAXTRY,MXDATA,DATA) GO TO 800 ELSE IF (CMD .EQ. 'F') THEN ! FINISH CALL FINISH(MAXTRY,MXDATA,DATA) GO TO 800 ELSE IF (CMD .EQ. 'D') THEN ! DIRECTORY CALL DIRECT(MAXTRY,MXDATA,DATA,NDATA) ELSE CALL SNDERR('remote command not implemented',MXDATA,DATA,NSEQ) END IF GO TO 900 800 ISTAT = 1 ! RETURN THEN EXIT PROGRAM RETURN 900 ISTAT = 0 ! NORMAL RETURN RETURN END SUBROUTINE HELP(MAXTRY,MXDATA,DATA) C--- C--- SEND FILE CONTAINING USAGE INFORMATION C--- INTEGER MAXTRY,MXDATA,DATA(*) CHARACTER HLPFIL*17 INTEGER NDATA,NSEQ,PREFIX DATA HLPFIL /'2000KERM*HARRIS'/ PREFIX = 0 CALL PUTDAT(HLPFIL,PREFIX,MXDATA,DATA,NDATA) NSEQ = 0 CALL SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY) RETURN END SUBROUTINE LOGOUT(MAXTRY,MXDATA,DATA) C--- C--- SEND CONFIRMATION MESSAGE AND DO A JOBCNTRL $OFF C--- INTEGER MAXTRY,MXDATA,DATA(*) LOGICAL DEBUG COMMON /DBGCOM/ DEBUG INTEGER NWORDS PARAMETER (NWORDS=2) INTEGER VOSCMD(NWORDS) CHARACTER MSG*80 INTEGER NSEQ,USER(4),PREFIX,NDATA,ISTAT NSEQ = 0 C PUT JOBCNTRL $OFF COMMAND IN LFN 0 BUFFER VOSCMD(1) = 3H$OF VOSCMD(2) = 3HF CALL BKSTOR(0,VOSCMD,NWORDS,ISTAT) IF (ISTAT .NE. 0) THEN CALL SNDERR('unable to sign off',MXDATA,DATA,NSEQ) RETURN END IF BACKSPACE (UNIT=0) C COPY LOGOUT MESSAGE INTO DATA ARRAY CALL USERNO( USER ) WRITE (MSG,1000) USER 1000 FORMAT ('SEE YOU LATER, ',4A3) PREFIX = 1 CALL PUTDAT(MSG,PREFIX,MXDATA,DATA,NDATA) C ACK WITH OUR CONFIRMATION MESSAGE CALL SNDACK(DATA,NDATA,NSEQ) END SUBROUTINE FINISH(MAXTRY,MXDATA,DATA) C--- C--- SEND CONFIRMATION MESSAGE AND EXIT PROGRAM C--- INTEGER MAXTRY,MXDATA,DATA(*) LOGICAL DEBUG COMMON /DBGCOM/ DEBUG INTEGER NSEQ,PREFIX,NDATA C COPY EXIT MESSAGE INTO DATA ARRAY PREFIX = 1 CALL PUTDAT('returning to JOBCNTRL',PREFIX,MXDATA,DATA,NDATA) C ACK WITH OUR CONFIRMATION MESSAGE NSEQ = 0 CALL SNDACK(DATA,NDATA,NSEQ) END SUBROUTINE DIRECT(MAXTRY,MXDATA,DATA,NDATA) C--- C--- SEND DIRECTORY INFORMATION ABOUT A SINGLE DISK AREA C--- INTEGER MAXTRY,MXDATA,DATA(*),NDATA CHARACTER DIRFIL*17, AREANM*19, ERRMSG*80 LOGICAL SIZEORD INTEGER LFN,NSEQ,ICOL,NARGC,PREFIX,ISTAT,I DATA DIRFIL /'W1'/ DATA LFN /99/ C GET FILE NAME, OPTIONALLY CONTAINING WILDCARD CHARACTERS IF (NDATA .EQ. 1) THEN NARGC = 0 ELSE ICOL = 2 CALL CMDARG(ICOL, DATA,NDATA, DATA,NARGC, ISTAT) IF (ISTAT .NE. 0) GO TO 820 END IF NARGC = MIN( NARGC, LEN(AREANM) ) AREANM = ' ' FOR I=1,NARGC AREANM(I:I) = CHAR( DATA(I) ) END FOR C OPEN A DIRECTORY WORKFILE OPEN (UNIT=LFN, FILE=DIRFIL, STATUS='OLD', IOSTAT=ISTAT) IF (ISTAT .NE. 0) GO TO 810 REWIND (UNIT=LFN) C WRITE DIRECTORY INFORMATION TO THE WORKFILE SIZEORD = .FALSE. CALL DIR(LFN,AREANM,NARGC,SIZEORD,ERRMSG,ISTAT) IF (ISTAT .NE. 0) GO TO 800 CLOSE (UNIT=LFN) C INVOKE THE SEND SWITCHER TO SEND THE WORKFILE PREFIX = 0 CALL PUTDAT(DIRFIL,PREFIX,MXDATA,DATA,NDATA) NSEQ = 0 CALL SENDSW(MXDATA,DATA,NDATA,NSEQ,MAXTRY) GO TO 900 800 CALL SNDERR(ERRMSG,MXDATA,DATA,NSEQ) RETURN 810 CALL SNDERR('directory workfile inaccessable',MXDATA,DATA,NSEQ) RETURN 820 CALL SNDERR('invalid command format',MXDATA,DATA,NSEQ) RETURN 900 RETURN END SUBROUTINE CMDARG(ICOL, DATA,NDATA, ARG,NARGC, ISTAT) C--- C--- EXTRACT A LENGTH-ENCODED ARGUMENT FROM DATA FIELD C--- INTEGER ICOL,DATA(*),NDATA,ARG(*),NARGC,ISTAT INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME INTEGER CTL,UNCHAR INTEGER IDATA,IARGC,NEWCHR C READ STARTING AT CHARACTER POSITION IN ARRAY NARGC = 0 IDATA = ICOL C GET NEXT CHARACTER FROM , UNCONTROLLIFYING AS NECESSARY 100 IF (IDATA .GT. NDATA) GO TO 800 NEWCHR = DATA(IDATA) IDATA = IDATA + 1 IF (NEWCHR .EQ. NSQUOT) THEN IF (IDATA .GT. NDATA) GO TO 800 NEWCHR = DATA(IDATA) IDATA = IDATA + 1 IF (NEWCHR .NE. NSQUOT) NEWCHR = CTL( NEWCHR ) END IF C CONVERT TO UPPER CASE IF (NEWCHR .GT. ICHAR('a') .AND. NEWCHR .LT. ICHAR('z') ) THEN NEWCHR = NEWCHR - ICHAR('a') + ICHAR('A') END IF C FIRST CHARACTER IS LENGTH CODE IF (NARGC .EQ. 0) THEN IARGC = 0 NARGC = UNCHAR( NEWCHR ) C COPY SUBSEQUENT CHARACTERS TO ELSE IARGC = IARGC + 1 ARG(IARGC) = NEWCHR END IF C RETURN THE RESULT OF LENGTH IN ARRAY IF (IARGC .GE. NARGC) THEN IF (IDATA .GT. NDATA) GO TO 900 GO TO 810 END IF GO TO 100 800 ISTAT = -1 ! CAN'T DECODE ARGUMENT (INVALID LENGTH CODE) RETURN 810 ISTAT = 1 ! SUCCESSFUL RETURN, MORE ARGUMENTS REMAIN RETURN 900 ISTAT = 0 ! SUCCESSFUL RETURN, THIS IS LAST ARGUMENT RETURN END SUBROUTINE DIR(LFN,AREANM,NC,SIZEORD,ERRMSG,ISTAT) C C CHECKS ALL AREANAMES AGAINST MATCH STRING, SAVING NECESSARY INFO C ON THOSE WHICH MATCH IN COMMON. WRITES RESULTS TO SPECIFIED LFN. C C ARGUMENTS: C LFN -- LOGICAL UNIT TO WRITE RESULTS C AREANM -- INPUT AREANAME, OPTIONALLY CONTAINING WILDCARDS C NC -- NUMBER OF CHARACTERS IN AREANM C SIZEORD -- LOGICAL VARIABLE INDICATING ORDER BY SIZE IF TRUE C ERRMSG -- TEXT STRING IDENTIFYING ERROR IF ISTAT NON-ZERO C ISTAT -- ZERO=SUCCESSFUL COMPLETION; NON-ZERO=ERROR C INTEGER LFN, NC, ISTAT CHARACTER AREANM*(*), ERRMSG*(*) LOGICAL SIZEORD C INTEGER MXMAP PARAMETER (MXMAP=999) CHARACTER NAME*17, TYPE*3, RWXD*11, OWNER*12 INTEGER SIZE, GRAN, NLINK, NFILES, IFIRST INTEGER MAXS, EL(6),GE(6),LA(6),LW(6) COMMON /MAPDAT/ NAME(MXMAP), TYPE(MXMAP), RWXD(MXMAP), + OWNER(MXMAP), SIZE(MXMAP), NLINK(MXMAP), NFILES, IFIRST C INTEGER NTOT, IPREV, INEXT INTEGER NCHARS, ISTAR, IWILD, I REAL KBYTES C C INITIALIZE FILE LIST C NFILES = 0 IFIRST = 0 NTOT = 0 C C PARSE MATCH STRING TO DETERMINE IF MORE THAN ONE AREANAME IS INVOLVED C NCHARS = 0 ISTAR = 0 IWILD = 0 FOR I=1,NC ! FIND SPECIAL CHARACTERS IF (AREANM(I:I) .NE. ' ') THEN NCHARS = I IF (AREANM(I:I) .EQ. '*') ISTAR = I IF (IWILD .EQ. 0 .AND. + AREANM(I:I) .EQ. '?') IWILD = I END IF END FOR IF (ISTAR .EQ. NCHARS) THEN ! DEFAULT AREANAME IS ? NCHARS = NCHARS + 1 AREANM(NCHARS:NCHARS) = '?' IF (IWILD .EQ. 0) IWILD = I END IF C C IF ONLY A SINGLE AREANAME IS INDICATED, DO IT NOW C IF (IWILD .EQ. 0) THEN CALL MAP(AREANM, + NAME(1),TYPE(1),RWXD(1),SIZE(1),GRAN,MAXS,OWNER(1), + EL,GE,LA,LW, ISTAT) IF (ISTAT .EQ. 0) THEN KBYTES = SIZE(1) * 336.0 / 1024.0 WRITE (LFN,1100) NAME(1),OWNER(1),TYPE(1),RWXD(1),KBYTES, + GE,LW,LA 1100 FORMAT (7X,A, T40,'OWNER: ',A, + /'TYPE: ',A, 7X,'ACCESS: 'A, T40,'SIZE (KBYTES):',F7.1, + /'CREATED: ', 6A3, + /'LAST UPDATED: ', 6A3, + /'LAST ACCESSED: ', 6A3) GO TO 900 ELSE ERRMSG = '*disc area not found*' GO TO 800 END IF END IF C C MAKE SURE THEY DIDN'T WILDCARD ONLY PART OF THE QUALIFIER C IF (IWILD .LT. ISTAR .AND. ISTAR .NE. 2) THEN ERRMSG = + '*error* invalid qualifier, use "?*" for all qualifiers' GO TO 800 END IF C C INITIALIZE THE CALL TO MAPWILD C CALL MAPINIT(AREANM(1:NCHARS),ISTAT) IF (ISTAT .NE. 0) THEN ERRMSG = '*error* invalid qualifier or areaname' GO TO 800 END IF C C LOOP THROUGH ALL FILES C NTOT = 0 LOOP I = NFILES + 1 CALL MAPWILD( + NAME(I),TYPE(I),RWXD(I),SIZE(I),GRAN,MAXS,OWNER(I), + EL,GE,LA,LW, ISTAT) IF (ISTAT .LT. 0) THEN EXIT LOOP IF (ISTAT .EQ. -2) WRITE (LFN,*) '*error* disc I/O error mapping file' GO TO 300 END IF C C IF IT MATCHED, LINK INTO THE LIST IN SORTED ORDER C NTOT = NTOT + 1 IF (ISTAT .NE. 0) GO TO 200 NFILES = I IPREV = 0 INEXT = IFIRST WHILE (INEXT .GT. 0) IF (SIZEORD) THEN ! ORDER BY SIZE EXIT WHILE IF ( SIZE(INEXT) .GT. SIZE(NFILES) ) EXIT WHILE IF ( SIZE(INEXT) .EQ. SIZE(NFILES) + .AND. NAME(INEXT) .GE. NAME(NFILES) ) ELSE ! ORDER BY NAME EXIT WHILE IF (NAME(INEXT) .GE. NAME(NFILES)) END IF IPREV = INEXT INEXT = NLINK(INEXT) END WHILE C WE FOUND WHERE IT GOES, NOW LINK IT IN IF (IPREV .LE. 0) THEN ! INSERT AT ROOT OF LIST NLINK(NFILES) = IFIRST IFIRST = NFILES ELSE ! INSERT INTO LIST NLINK(NFILES) = INEXT NLINK(IPREV) = NFILES END IF 200 CONTINUE 300 END LOOP C C WRITE SORTED RESULTS TO SPECIFIED UNIT C IF (NFILES .LT. 1) THEN ERRMSG = '*disc area not found*' GO TO 800 END IF WRITE (LFN,1500) I = IFIRST WHILE (I .GT. 0) KBYTES = SIZE(I) * 336.0 / 1024.0 WRITE (LFN,1510) NAME(I),TYPE(I),RWXD(I),KBYTES,OWNER(I) I = NLINK(I) END WHILE IF (NTOT .GT. NFILES) WRITE (LFN,1520) NFILES, NTOT 1500 FORMAT (4X,'AREANAME', 7X,'TYPE', 4X,'ACCESS', + 6X,'KBYTES', 4X,'OWNER') 1510 FORMAT (A, 2X,A, 3X,A, F8.1, 5X,A) 1520 FORMAT (/I4, ' files matched of', I5) GO TO 900 800 ISTAT = -1 RETURN 900 ISTAT = 0 RETURN END INTEGER FUNCTION ICOMP(MATCH,NM,STRING,NS) C C COMPARES A MATCH STRING, CONTAINING WILDCARD CHARACTERS, WITH AN C OBJECT STRING. RETURNS 0 IF MATCH SUCCEDED, 1 OTHERWISE C CHARACTER MATCH, STRING ! MATCH AND COMPARE STRINGS INTEGER NM, NS ! LENGTHS OF ABOVE C CHARACTER C*1 ! CURRENT MATCH CHARACTER LOGICAL AT ! SET IF LAST CHARACTER WAS ? INTEGER M ! MATCH STRING POINTER INTEGER S ! COMPARE STRING POINTER INTEGER LM ! POINTER TO LAST ? PROCESSED INTEGER LS ! S AFTER LAST ? INTEGER J C C INITIALIZE C ICOMP = 1 ! ASSUME NO MATCH M = 1 S = 1 LM = 0 LS = 0 AT = .FALSE. C C LOOP THROUGH MATCH CHARACTERS C 10 WHILE (M .LE. NM) C = MATCH(M:M) ! GET CURRENT MATCH CHARACTER C C HANDLE ? CHARACTER C IF (C .EQ. '?') THEN AT = .TRUE. LM = M C C HANDLE OTHER CHARACTERS C ELSE IF (S .GT. NS) RETURN ! NO MORE CHARS IN SUBSTRING IF (AT) THEN ! SKIP UNKNOWN CHARACTERS J = INDEX(STRING(S:NS),C) IF (J .EQ. 0) RETURN S = S + J LS = S AT = .FALSE. ELSE ! CHECK FOR EXACT MATCH IF (C .EQ. STRING(S:S)) THEN S = S + 1 ELSE ! NO MATCH IF (LS .GT. 0) THEN M = LM S = LS GO TO 10 ! BACK UP TO ?+1 AND TRY AGAIN ELSE RETURN END IF END IF END IF END IF M = M + 1 END WHILE C C MAKE SURE ANY REMAINING CHARACTERS IN STRING ARE TRAILING BLANKS C IF (.NOT. AT) THEN IF (S .LE. NS) THEN IF (STRING(S:NS) .NE. ' ') THEN M = LM S = LS GO TO 10 ! BACK UP TO ?+1 AND TRY AGAIN END IF END IF END IF ICOMP = 0 ! SUCCESSFUL MATCH END SUBROUTINE MAPINIT(AREANM,ISTAT), + MAPWILD(NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER, + ELDATE,GEDATE,LADATE,LWDATE,ISTAT) C C MAPWILD FORTRAN 77 / ASSEMBLER C WRITTEN BY SKIP RUSSELL APRIL, 1983 C C SUBROUTINE TO RETURN INFORMATION ABOUT ALL DISK AREAS WHICH C SUCCESSFULLY MATCH A "WILDCARD" AREANAME STRING. C C THE QUALIFIER OF THE MATCH STRING, IF SPECIFIED, DETERMINES C THE MAPPING OPERATION TO PERFORM AS FOLLOWS: C C NO QUALIFIER SPECIFIED -- SEARCH FILES UNDER CURRENT QUALIFIER C VALID QUALIFIER -- SEARCH FILES UNDER SPECIFIED QUALIFIER C QUALIFIER = "?" -- SEARCH ALL FILES OWNED BY CURRENT USER C C C MAPINIT: (INITIALIZATION FOR MAPWILD) C INPUT ARGUMENTS: C AREANM -- AREA NAME TO MATCH CONTAINING WILDCARD CHARACTERS C ISTAT -- STATUS INDICATOR, AS FOLLOWS: C 0 = SUCCESSFUL C -1 = INVALID NAME C C MAPWILD: C OUTPUT ARGUMENTS: C NAME -- QUAL*AREA (CHARACTER*17) C TYPE -- PROGRAM TYPE (CHARACTER*3) C RWXD -- READ/WRITE/EXECUTE/DELETE ACCESS (CHARACTER*11) C SIZE -- CURRENT SIZE IN SECTORS (INTEGER) C GRAN -- GRANULE SIZE IN SECTORS (INTEGER) C MAXS -- MAXIMUM SIZE IN SECTORS (INTEGER) C OWNER -- USER NAME OF THE OWNER (CHARACTER*12) C ELDATE -- ELIMINATE DATE/TIME (6 INTEGER ARRAY) C GEDATE -- GENERATE DATE/TIME (6 INTEGER ARRAY) C LADATE -- LAST ACCESS DATE/TIME (6 INTEGER ARRAY) C LWDATE -- LAST WRITE DATE/TIME (6 INTEGER ARRAY) C ISTAT -- STATUS INDICATOR, AS FOLLOWS: C 0 = MAP INFORMATION RETURNED AS REQUESTED C +1 = FILE NAME DOES NOT MATCH GIVEN MATCH STRING C -1 = ERROR (E.G. READ ERROR OR UNRESOURCED PACK) C -2 = NO MORE FILES C C --------------------------------------------------------------------- CHARACTER AREANM*(*) ! AREANAME MATCH STRING C CHARACTER NAME*17 ! AREANAME CHARACTER TYPE*3 ! FILE TYPE CHARACTER RWXD*11 ! ACCESS CODE INTEGER SIZE ! CURRENT SIZE INTEGER GRAN ! GRANULE SIZE INTEGER MAXS ! MAXIMUM SIZE CHARACTER OWNER*12 ! OWNER'S NAME INTEGER ELDATE(6) ! PURGE DATE/TIME INTEGER GEDATE(6) ! GENERATION D/T INTEGER LADATE(6) ! LAST REFERENCE D/T INTEGER LWDATE(6) ! LAST WRITE D/T INTEGER ISTAT ! MAP STATUS RETURNED C INTEGER PARLST(5) ! PARAMETER LIST FOR $DASAVE INTEGER DAIB(24,9) ! DISC AREA INFORMATION BLOCK EQUIVALENCE (PARLST(5),DAIB) C CHARACTER NAMTMP*19 ! TEMPORARY AREANAME INTEGER NAMEQV(7) ! HOLLERITH FORM OF AREANAME EQUIVALENCE (NAMTMP,NAMEQV) C CHARACTER MATCH*15 ! AREANAME PORTION OF MATCH STRING INTEGER NCHARS,ISTAR ! CHARACTER POINTERS INTEGER NMATCH,I ! CHARACTER POINTERS INTEGER MODE ! SEARCH FUNCTION TO PERFORM INTEGER NWORDS, FILENO ! BUFFER POINTERS INTEGER ICOMP, JCOMP ! COMPARISON FUNCTION, RESULT DATA FILENO / -1 / C C GET QUALIFIER IN TRUNCATED ASCII, IF REQUIRED C ISTAR = 0 FOR I=1,LEN(AREANM) C FIND QUALIFIER DELIMITER IF (AREANM(I:I) .EQ. '*') THEN ISTAR = I EXIT FOR END IF END FOR C HANDLE A WILDCARD QUALIFIER IF (ISTAR .EQ. 2 .AND. AREANM(1:1) .EQ. '?') THEN MODE = 2 ELSE MODE = 1 C ASSEMBLE A DUMMY AREANAME USING THE SPECIFED QUALIFIER IF (ISTAR .LE. 0) THEN NAMTMP = 'TEMPNAME' ELSE NAMTMP = AREANM(1:ISTAR) // 'TEMPNAME' END IF CALL FILNAM(NAMTMP,PARLST,ISTAT) IF (ISTAT .LE. 0) GO TO 800 END IF C C MAKE A COPY OF THE MATCH STRING C MATCH = AREANM(ISTAR+1:) NMATCH = LEN(AREANM) - ISTAR C C PERFORM INITIAL CALL TO $DASAVE C IF (MODE .EQ. 1) THEN ! SINGLE QUALIFIER :ASSEM REEN MAKE THE ROUTINE RE-ENTRANT * TLO PARLST DEFINE PARAMETER LIST BLU $DASAVE GET THE DISK INFO DATA 2 FUNCTION CODE FOR GET ALL FILES FROM QUAL CZA ERROR? BNZ $800 YES, EXIT TEM NWORDS NO, GET WORD COUNT :END ELSE ! ALL QUALIFIERS :ASSEM TLO PARLST DEFINE PARAMETER LIST BLU $DASAVE GET THE DISK INFO DATA 8 FUNCTION CODE FOR GET ALL USER FILES CZA ERROR? BNZ $800 YES, EXIT TEM NWORDS NO, GET WORD COUNT :END END IF FILENO = 1 ! INDICATE FIRST FILE GO TO 900 C C --------------------------------------------------------------------- C ENTRY MAPWILD IF (FILENO .LE. 0) STOP '*error* MAPWILD not initialized' IF (NWORDS .LE. 0) GO TO 810 ! NO MORE FILES C C MAKE SURE THE CURRENT FILE MATCHES BEFORE WE PROCESS IT C CALL TATOA(DAIB(13,FILENO),NAMEQV(1),8) ! QUALIFIER CALL TATOA(DAIB( 1,FILENO),NAMEQV(4),8) ! AREANAME NAMTMP(9:9) = '*' NAME = NAMTMP JCOMP = ICOMP( MATCH,NMATCH, NAME(10:17),8 ) IF (JCOMP .EQ. 0) THEN CALL MAPIFY( DAIB(1,FILENO), + NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER, + ELDATE,GEDATE,LADATE,LWDATE ) END IF C C INCREMENT THE BUFFER POINTER C FILENO = FILENO + 1 NWORDS = NWORDS - 24 C C IF THE CURRENT BUFFER IS EMPTY, GET INFORMATION ON UP TO 9 MORE FILES C IF (NWORDS .EQ. 0) THEN :ASSEM TLO PARLST DEFINE PARAMETER LIST BLU $DASAVE GET THE DISK INFO DATA 0 FUNCTION CODE FOR GET INFO CZA ERROR? BNZ $800 YES, EXIT TEM NWORDS NO, GET NEW WORD COUNT :END FILENO = 1 ! INDICATE FIRST FILE END IF IF (JCOMP .NE. 0) GO TO 820 GO TO 900 C C ERROR C 800 ISTAT = -1 RETURN C C NO MORE FILES C 810 ISTAT = -2 RETURN C C COMPARISON WITH MATCH STRING FAILED (ONLY QUAL*NAME RETURNED) C 820 ISTAT = 1 RETURN C C SUCCESSFUL RETURN C 900 ISTAT = 0 RETURN END SUBROUTINE MAP(AREANM, NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER, + ELDATE,GEDATE,LADATE,LWDATE,ISTAT) C C MAPFILE FORTRAN 77 / ASSEMBLER C WRITTEN BY SKIP RUSSELL APRIL, 1983 C C SUBROUTINE TO RETURN DIRECTORY INFORMATION ON A SINGLE DISK AREA C C C INPUT ARGUMENTS: C AREANM -- AREA NAME TO MATCH (CHARACTER STRING) C C OUTPUT ARGUMENTS: C NAME -- QUAL*AREA (CHARACTER*17) C TYPE -- PROGRAM TYPE (CHARACTER*3) C RWXD -- READ/WRITE/EXECUTE/DELETE ACCESS (CHARACTER*11) C SIZE -- CURRENT SIZE IN SECTORS (INTEGER) C GRAN -- GRANULE SIZE IN SECTORS (INTEGER) C MAXS -- MAXIMUM SIZE IN SECTORS (INTEGER) C OWNER -- USER NAME OF THE OWNER (CHARACTER*12) C ELDATE -- ELIMINATE DATE/TIME (6 INTEGER ARRAY) C GEDATE -- GENERATE DATE/TIME (6 INTEGER ARRAY) C LADATE -- LAST ACCESS DATE/TIME (6 INTEGER ARRAY) C LWDATE -- LAST WRITE DATE/TIME (6 INTEGER ARRAY) C ISTAT -- STATUS INDICATOR, AS FOLLOWS: C +1 = FILE NOT FOUND C 0 = MAP INFORMATION RETURNED (SUCCESSFUL) C -1 = INVALID NAME SPECIFIED C C --------------------------------------------------------------------- CHARACTER AREANM*(*) ! AREANAME MATCH STRING C CHARACTER NAME*17 ! AREANAME CHARACTER TYPE*3 ! FILE TYPE CHARACTER RWXD*11 ! ACCESS CODE INTEGER SIZE ! CURRENT SIZE INTEGER GRAN ! GRANULE SIZE INTEGER MAXS ! MAXIMUM SIZE CHARACTER OWNER*12 ! OWNER'S NAME INTEGER ELDATE(6) ! PURGE DATE/TIME INTEGER GEDATE(6) ! GENERATION D/T INTEGER LADATE(6) ! LAST REFERENCE D/T INTEGER LWDATE(6) ! LAST WRITE D/T INTEGER ISTAT ! MAP STATUS RETURNED C INTEGER PARLST(5) ! PARAMETER LIST FOR $DASAVE INTEGER DAIB(24) ! DISC AREA INFORMATION BLOCK EQUIVALENCE (PARLST(5),DAIB) C C GET FILE NAME IN TRUNCATED ASCII C CALL FILNAM(AREANM,PARLST,ISTAT) IF (ISTAT .LE. 0) GO TO 800 C C CALL $DASAVE SYSTEM SERVICE C :ASSEM REEN MAKE THE ROUTINE RE-ENTRANT * TLO PARLST DEFINE PARAMETER LIST BLU $DASAVE GET THE DISK INFO DATA 7 FUNCTION CODE FOR GET INFO ON ONE FILE CZA ERROR? BNZ $810 YES, EXIT :END C C PROCESS OUTPUT AND RETURN C CALL MAPIFY(DAIB, NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER, + ELDATE,GEDATE,LADATE,LWDATE) GO TO 900 C C INVALID FILE NAME C 800 ISTAT = -1 RETURN C C FILE NOT FOUND C 810 ISTAT = 1 RETURN C C SUCCESSFUL RETURN C 900 ISTAT = 0 RETURN END SUBROUTINE MAPIFY(DAIB, NAME,TYPE,RWXD,SIZE,GRAN,MAXS,OWNER, + ELDATE,GEDATE,LADATE,LWDATE) C C SUBROUTINE TO DECODE A DISK AREA INFORMATION BLOCK C C INPUT ARGUMENT: C DAIB -- 24 WORD DAIB AS RETURNED BY THE $DASAVE SERVICE C C OUTPUT ARGUMENTS: C NAME -- QUAL*AREA (CHARACTER*17) C TYPE -- PROGRAM TYPE (CHARACTER*3) C RWXD -- READ/WRITE/EXECUTE/DELETE ACCESS (CHARACTER*11) C SIZE -- CURRENT SIZE IN SECTORS (INTEGER) C GRAN -- GRANULE SIZE IN SECTORS (INTEGER) C MAXS -- MAXIMUM SIZE IN SECTORS (INTEGER) C OWNER -- USER NAME OF THE OWNER (CHARACTER*12) C ELDATE -- ELIMINATE DATE/TIME (6 INTEGER ARRAY) C GEDATE -- GENERATE DATE/TIME (6 INTEGER ARRAY) C LADATE -- LAST ACCESS DATE/TIME (6 INTEGER ARRAY) C LWDATE -- LAST WRITE DATE/TIME (6 INTEGER ARRAY) C C --------------------------------------------------------------------- INTEGER DAIB(24) ! DISC AREA INFORMATION BLOCK C CHARACTER NAME*17 ! AREANAME CHARACTER TYPE*3 ! FILE TYPE CHARACTER RWXD*11 ! ACCESS CODE INTEGER SIZE ! CURRENT SIZE INTEGER GRAN ! GRANULE SIZE INTEGER MAXS ! MAXIMUM SIZE CHARACTER OWNER*12 ! OWNER'S NAME INTEGER ELDATE(6) ! PURGE DATE/TIME INTEGER GEDATE(6) ! GENERATION D/T INTEGER LADATE(6) ! LAST REFERENCE D/T INTEGER LWDATE(6) ! LAST WRITE D/T C CHARACTER OWNTMP*12 ! TEMPORARY OWNER NAME INTEGER PARLS2(10) ! PARAMETER LIST FOR $USERNO EQUIVALENCE (OWNTMP,PARLS2(5)) C CHARACTER NAMTMP*18 ! TEMPORARY AREANAME INTEGER NAMEQV(6) ! HOLLERITH FORM OF AREANAME EQUIVALENCE (NAMTMP,NAMEQV) C CHARACTER PREFIX*1 ! PUBLIC/ACCOUNT FLAG INTEGER I C C AREANAME C CALL TATOA(DAIB(13),NAMEQV(1),8) ! QUALIFIER CALL TATOA(DAIB( 1),NAMEQV(4),8) ! AREANAME NAMTMP(9:9) = "*" NAME = NAMTMP C C TYPE C I = DAIB(8) IF ((I.AND.'40000000) .NE. 0) THEN TYPE = 'INT' ELSE IF ((I.AND.'10000000) .NE. 0) THEN TYPE = 'BLK' ELSE IF ((I.AND.'04000000) .NE. 0) THEN TYPE = 'RAN' ELSE TYPE = 'UNB' END IF C C CURRENT & GRANULE & MAXIMUM SIZES C SIZE = DAIB(15) GRAN = DAIB( 4) MAXS = DAIB(16) C C ACCESS C I = DAIB(7) / 2**12 IF ((I.AND.'100) .NE. 0) THEN PREFIX = "P" ELSE PREFIX = "A" END IF RWXD = "-----------" IF ((I.AND.'2000) .NE. 0) THEN SR11/86 IF ((I.AND.'0001) .NE. 0) RWXD(10:11) = "OD" SR11/86 IF ((I.AND.'0002) .NE. 0) RWXD(04:05) = "OW" SR11/86 IF ((I.AND.'0004) .NE. 0) RWXD(10:11) = 'AD' SR11/86 IF ((I.AND.'0010) .NE. 0) RWXD(07:08) = 'AX' SR11/86 IF ((I.AND.'0020) .NE. 0) RWXD(04:05) = 'AW' SR11/86 IF ((I.AND.'0040) .NE. 0) RWXD(01:02) = 'AR' SR11/86 IF ((I.AND.'0100) .NE. 0) RWXD(10:11) = 'PD' SR11/86 IF ((I.AND.'0200) .NE. 0) RWXD(07:08) = 'PX' SR11/86 IF ((I.AND.'0400) .NE. 0) RWXD(04:05) = 'PW' SR11/86 IF ((I.AND.'1000) .NE. 0) RWXD(01:02) = 'PR' SR11/86 ELSE SR11/86 IF ((I.AND.'01) .NE. 0) RWXD(10:11) = "OD" IF ((I.AND.'02) .NE. 0) RWXD(04:05) = "OW" IF ((I.AND.'04) .NE. 0) RWXD(10:11) = PREFIX // 'D' IF ((I.AND.'10) .NE. 0) RWXD(07:08) = PREFIX // 'X' IF ((I.AND.'20) .NE. 0) RWXD(04:05) = PREFIX // 'W' IF ((I.AND.'40) .NE. 0) RWXD(01:02) = PREFIX // 'R' END IF SR11/86 C C OWNER C IF (PARLS2(1) .NE. DAIB(5) .OR. PARLS2(2) .NE. DAIB(6)) THEN PARLS2(1) = DAIB(5) PARLS2(2) = DAIB(6) PARLS2(3) = 0 PARLS2(4) = 0 OWNTMP = ' ' :ASSEM REEN MAKE THE ROUTINE RE-ENTRANT * TLO PARLS2 DEFINE PARAMETER LIST NSK BLU $USERNO GET USER NAME :END END IF OWNER = OWNTMP C C DATES AND TIMES C ELDATE(1) = DAIB(17) ELDATE(2) = DAIB(18) GEDATE(1) = DAIB(19) GEDATE(2) = DAIB(20) LADATE(1) = DAIB(21) LADATE(2) = DAIB(22) LWDATE(1) = DAIB(23) LWDATE(2) = DAIB(24) :ASSEM TMK ELDATE NSK BLU $DATE * TMK GEDATE NSK BLU $DATE * TMK LADATE NSK BLU $DATE * TMK LWDATE NSK BLU $DATE :END IF (DAIB(17).EQ.'37777777) THEN ELDATE(1) = ' ' ELDATE(2) = ' ' ELDATE(3) = ' ' ELDATE(4) = ' ' ELDATE(5) = ' ' ELDATE(6) = ' ' END IF END SUBROUTINE FILNAM(AREANM,TASCII,ISTAT) C C CHECK A DISC AREANAME TO INSURE THAT IS CORRECTLY FORMED, C AND SET UP THE TRUNCATED ASCII REPRESENTATION WHICH IS USED C BY SEVERAL HARRIS SYSTEM SERVICES C C INPUT: C AREANM -- CHARACTER STRING CONTAINING THE AREANAME TO SCAN C C OUTPUT: C TASCII -- 4 WORD ARRAY CONTAINING THE COMPLETE AREANAME IN C TRUNCATED ASCII C C ISTAT -- STATUS FLAG RETURNED: C NEGATIVE IF AREANAME IS MALFORMED C LENGTH OF INPUT STRING IF SUCCESSFUL C C WRITTEN 4/83 BY SR C C --------------------------------------------------------------------- CHARACTER AREANM*(*) ! INPUT AREANAME INTEGER TASCII(4) ! OUTPUT AREANAME INTEGER ISTAT ! STATUS CODE CHARACTER NAMTMP*18 INTEGER NAMEQV(6) EQUIVALENCE (NAMTMP,NAMEQV) NAMTMP = AREANM ! CONVERT AREANAME TO HOLLERITH :ASSEM REEN MAKE THE ROUTINE RE-ENTRANT * TLO PARLST INITIALIZE THE SCANNER BLU $SCINIT * TMK TASCII IDENTIFY THE OUTPUT BUFFER BLU $AREANM CALL AREANAME SERVICE TAM* ISTAT GET STATUS RETURNED * PORG * DATA PARLST DATA 6 INPUT BUFFER LENGTH LAC NAMTMP INPUT BUFFER ADDRESS :END RETURN END C KERMIT PRIMITIVES C C SNDPKT -- SEND PACKET C RESEND -- RE-SEND PREVIOUS PACKET C SNDACK -- SEND "ACK" PACKET C SNDNAK -- SEND "NAK" PACKET C SNDERR -- SEND ERROR PACKET C RCVPKT -- RECEIVE PACKET C RCVACK -- RECEIVE ACK/NAK PACKET C UNPACK -- DECODE AN INCOMING PACKET C SPAR -- ENCODE MY SEND/RECEIVE PARAMETERS C RPAR -- DECODE THE OTHER KERMIT'S SEND/RECEIVE PARAMETERS C PUTDAT -- FILL PACKET DATA WITH A STRING OF TEXT C ICHKFN -- COMPUTE PACKET CHECKSUM (INTEGER FUNCTION) C MAKEC -- MAKE A NUMBER PRINTABLE (INTEGER FUNCTION) C UNCHAR -- RESTORE A NUMBER FROM PRINTABLE (INTEGER FUNCTION) C ISCTRL -- IS THIS A CONTROL CHARACTER? (LOGICAL FUNCTION) C CTL -- CONTROL CHAR TO/FROM PRINTABLE (INTEGER FUNCTION) C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C PACKET DESCRIPTION: C C BYTE 1 -- MARK : SOH CHARACTER C BYTE 2 -- COUNT : # OF BYTES FOLLOWING THIS FIELD C BYTE 3 -- SEQ : SEQUENCE NUMBER MODULO 64 C BYTE 4 -- PTYPE : PACKET TYPE = {D,Y,N,S,B,F,Z,E,...} C BYTE 5- -- DATA : THE ACTUAL DATA (N BYTES) C BYTE N+5 -- CHKSUM : CHECKSUM OF BYTES 2 THROUGH N+4 C APPENDED: -- EOL : (NOT CONSIDERED PART OF PACKET PROPER) SUBROUTINE SNDPKT(DATA,NDATA,NSEQ,TYPE) C--- C--- BUILDS AND SENDS PACKET C--- INTEGER DATA(*),NDATA,NSEQ CHARACTER TYPE*1 LOGICAL DEBUG COMMON /DBGCOM/ DEBUG INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME INTEGER ICHKFN,MAKEC INTEGER PACK(94),NPACK,SOH,I SAVE PACK,NPACK DATA SOH /1/ NPACK = NDATA + 5 ! TOTAL CHARACTERS IN PACKET PACK(1) = SOH ! MARK (START OF PACKET CHARACTER) PACK(2) = MAKEC(NDATA+3) ! COUNT = SEQ+PTYPE+DATA+CHKSUM PACK(3) = MAKEC(NSEQ) ! SEQUENCE NUMBER PACK(4) = ICHAR(TYPE) ! PACKET TYPE FOR I=1,NDATA PACK(I+4) = DATA(I) ! DATA END FOR PACK(NDATA+5) = ICHKFN(PACK,NPACK) ! CHECKSUM IF (DEBUG) THEN IF (NDATA .LE. 0) THEN WRITE (*,1100) NSEQ, TYPE, NPACK, NDATA ELSE WRITE (*,1100) NSEQ, TYPE, NPACK, NDATA, + ICHAR('<'), (DATA(I), I=1,NDATA), ICHAR('>') END IF 1100 FORMAT (' SENT',I3,') TYPE=',A,' SIZE=',I3,' NDATA=',I3, + :,2X,R1,89R1,R1) END IF GO TO 100 C--- C--- RE-SENDS PREVIOUS PACKET C--- ENTRY RESEND() IF (DEBUG) WRITE (*,*) 'RE-SENDING LAST PACKET' C SEND PADDING IF THEY REQUESTED IT 100 FOR I=1,NSPAD CALL PUT1CW(NSPCHR,1) END FOR C SEND PACKET CALL PUT1CW(PACK,NPACK) END SUBROUTINE SNDACK(DATA,NDATA,NSEQ) C--- C--- SEND ACK PACKET C--- INTEGER DATA(*),NDATA,NSEQ CALL SNDPKT(DATA,NDATA,NSEQ,'Y') END SUBROUTINE SNDNAK(NSEQ) C--- C--- SEND NAK PACKET C--- INTEGER NSEQ INTEGER DATA(1),NDATA NDATA = 0 CALL SNDPKT(DATA,NDATA,NSEQ,'N') END SUBROUTINE SNDERR(MSG,MXDATA,DATA,NSEQ) C--- C--- SEND ERROR PACKET C--- CHARACTER MSG*(*) INTEGER MXDATA,DATA(*),NSEQ LOGICAL DEBUG COMMON /DBGCOM/ DEBUG INTEGER NDATA,PREFIX IF (DEBUG) WRITE (*,*) MSG C COPY MESSAGE INTO DATA ARRAY PREFIX = 1 CALL PUTDAT(MSG,PREFIX,MXDATA,DATA,NDATA) C SEND "E" PACKET CALL SNDPKT(DATA,NDATA,NSEQ,'E') END SUBROUTINE RCVPKT(MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT) C--- C--- RECEIVES PACKET C--- INTEGER MXDATA,DATA(*),NDATA,NSEQ,ISTAT CHARACTER TYPE*1 LOGICAL DEBUG COMMON /DBGCOM/ DEBUG INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME INTEGER MXBUF PARAMETER (MXBUF=80) INTEGER PACK(MXBUF) INTEGER I C READ PACKET CALL PUT1CW(NSEOL,1) READ (3,'(100R1)',IOSTAT=ISTAT) PACK IF (ISTAT .NE. 0) THEN IF (DEBUG) WRITE (*,*) 'I/O ERROR ON READ, IOSTAT=', ISTAT GO TO 800 END IF C CHECK CALL UNPACK(PACK,MXBUF,MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT) IF (ISTAT .NE. 0) THEN IF (DEBUG) WRITE (*,*) 'INVALID PACKET RECEIVED' GO TO 800 END IF GO TO 900 800 ISTAT = -1 ! UNSUCCESSFUL RETURN 900 ISTAT = 0 ! SUCCESSFUL RETURN END SUBROUTINE RCVACK(MXDATA,DATA,NDATA,NSEQ,ISTAT) C--- C--- RECEIVE "ACK" PACKET AND CHECK VALIDITY C--- INTEGER MXDATA,DATA(*),NDATA,NSEQ,ISTAT LOGICAL DEBUG COMMON /DBGCOM/ DEBUG INTEGER RSEQ CHARACTER TYPE*1 CALL RCVPKT(MXDATA,DATA,NDATA,RSEQ,TYPE,ISTAT) IF (ISTAT .NE. 0) GO TO 810 IF (TYPE .EQ. 'Y' .AND. NSEQ .EQ. RSEQ) GO TO 900 IF (TYPE .EQ. 'N') THEN IF (MOD(NSEQ+1,64) .EQ. RSEQ) THEN IF (DEBUG) WRITE (*,*) '(EQUIVALENT TO ACK)' GO TO 900 END IF GO TO 810 END IF CCC IF (TYPE .EQ. 'E') GO TO 800 CCC GO TO 810 800 ISTAT = -1 ! ERROR PACKET RETURN 810 ISTAT = 1 ! UNSUCCESSFUL IF (DEBUG) WRITE (*,*) 'RECEIVED NAK OR EQUIVALENT' RETURN 900 ISTAT = 0 ! SUCCESSFUL RETURN END SUBROUTINE UNPACK(PACK,MXBUF,MXDATA,DATA,NDATA,NSEQ,TYPE,ISTAT) C--- C--- UNPACK AND VALIDATE PACKET (CALLED BY RCVPKT) C--- INTEGER PACK(*),MXBUF INTEGER MXDATA,DATA(*),NDATA,NSEQ,ISTAT CHARACTER TYPE*1 LOGICAL DEBUG COMMON /DBGCOM/ DEBUG INTEGER UNCHAR,ICHKFN INTEGER NPACK,IPACK,NSOH,CHKSUM,CHKSU2,NCHARS,SOH,I DATA SOH /1/ C INITIALIZE NSOH = 0 TYPE = '?' C MARK FIELD : SOH CHARACTER IPACK = 0 FOR I=1,MXBUF-3 IPACK = IPACK + 1 IF (PACK(IPACK) .EQ. SOH) GO TO 100 END FOR IF (DEBUG) WRITE (*,*) 'UNPACK: SOH NOT FOUND' GO TO 800 100 NSOH = IPACK IF (DEBUG .AND. NSOH .NE. 1) WRITE (*,*) 'SOH FOUND AT', NSOH C COUNT FIELD : # OF BYTES FOLLOWING THIS FIELD IPACK = IPACK + 1 NPACK = UNCHAR( PACK(IPACK) ) IF (NPACK .LT. 3 .OR. NPACK+2 .GT. MXBUF) THEN IF (DEBUG) WRITE (*,*) 'UNPACK: INVALID COUNT FIELD', NPACK GO TO 800 ELSE IF (NPACK+NSOH+1 .GT. MXBUF) THEN IF (DEBUG) WRITE (*,*) 'UNPACK: BUFFER OVERRUN', NPACK+NSOH+1 GO TO 800 END IF NPACK = NPACK + 2 C SEQ FIELD : SEQUENCE NUMBER MODULO 64 IPACK = IPACK + 1 NSEQ = UNCHAR( PACK(IPACK) ) IF (NSEQ .LT. 0 .OR. NSEQ .GT. 63) THEN IF (DEBUG) WRITE (*,*) 'UNPACK: INVALID SEQ FIELD', NSEQ GO TO 800 END IF C PTYPE FIELD : PACKET TYPE = {D,Y,N,S,B,F,Z,E,...} IPACK = IPACK + 1 TYPE = CHAR( PACK(IPACK) ) IF (TYPE .LT. 'A' .OR. TYPE .GT. 'Z') THEN IF (DEBUG) WRITE (*,*) 'UNPACK: INVALID PACKET TYPE ', TYPE GO TO 800 END IF C DATA FIELD : COPY INTO DATA ARRAY NDATA = NPACK-5 IF (NDATA .GT. MXDATA) THEN IF (DEBUG) WRITE (*,*) 'UNPACK: MORE DATA RECEIVED THAN', + ' EXPECTED (N=', NDATA, ' MAX=', MXDATA, ')' NDATA = MXDATA END IF FOR I=1,NDATA DATA(I) = PACK(I+NSOH+3) END FOR C CHKSUM FIELD : CHECKSUM OF BYTES 2 THROUGH N-4 CHKSUM = PACK(NPACK+NSOH-1) CHKSU2 = ICHKFN( PACK(NSOH), NPACK ) IF (CHKSUM .NE. CHKSU2) THEN IF (DEBUG) WRITE (*,*) 'UNPACK: CHECKSUMS=', CHKSUM,CHKSU2 GO TO 800 END IF C LOG ERROR MESSAGES IF (TYPE .EQ. 'E') THEN IF (DEBUG) THEN WRITE (*,*) 'ERROR PACKET RECEIVED:' WRITE (*,*) '***', (CHAR(PACK(I)), I=NSOH+4,NPACK-1), '***' END IF END IF GO TO 900 800 ISTAT = -1 ! UNSUCCESSFUL IF (DEBUG) THEN NCHARS = 0 FOR I=MXBUF,1,-1 IF (PACK(I) .NE. ICHAR(' ') ) THEN NCHARS = I EXIT FOR END IF END FOR WRITE (*,*) 'DUMP OF PACKET CONTENTS:' WRITE (*,'(26(2X,R1))') (MAX(ICHAR(' '),PACK(I)), I=1,NCHARS) WRITE (*,'(1X,26I3)') (PACK(I), I=1,NCHARS) END IF RETURN 900 ISTAT = 0 ! SUCCESSFUL IF (DEBUG) THEN IF (NDATA .LE. 0) THEN WRITE (*,1900) NSEQ, TYPE, NPACK, NDATA ELSE WRITE (*,1900) NSEQ, TYPE, NPACK, NDATA, + ICHAR('<'), (DATA(I), I=1,NDATA), ICHAR('>') END IF 1900 FORMAT (' RCVD',I3,') TYPE=',A,' SIZE=',I3,' NDATA=',I3, + :,2X,93R1) END IF END SUBROUTINE SPAR(MXDATA,DATA,NDATA) C--- C--- FILL THE DATA ARRAY WITH MY SEND-INIT PARAMETERS C--- INTEGER MXDATA,DATA(*),NDATA LOGICAL DEBUG COMMON /DBGCOM/ DEBUG INTEGER MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME COMMON /RCVCOM/ MRPSIZ,MYPAD,MYPCHR,MYEOL,MYQUOT,MYTIME INTEGER MAKEC,CTL LOGICAL FIRST DATA FIRST /.TRUE./ NDATA = 6 IF (MXDATA .LT. NDATA) THEN WRITE (*,*) 'FATAL ERROR: DATA ARRAY < MIN SIZE IN "SPAR"' STOP END IF DATA(1) = MAKEC( MRPSIZ ) ! BIGGEST PACKET I CAN RECEIVE DATA(2) = MAKEC( MYTIME ) ! WHEN I WANT TIMEOUT DATA(3) = MAKEC( MYPAD ) ! HOW MUCH PADDING TO SEND ME DATA(4) = CTL( MYPCHR ) ! PAD CHARACTER TO USE DATA(5) = MAKEC( MYEOL ) ! EOL TO SEND ME DATA(6) = MYQUOT ! CONTROL QUOTE CHAR I WILL SEND C USE DEFAULTS FOR THE FOLLOWING: C 7. NEITHER OF US WILL DO 8-BIT QUOTING C 8. BOTH OF US WILL USE A SINGLE CHARACTER CHECKSUM C 9. NEITHER OF US WILL USE REPEAT PREFIXES IF (DEBUG .AND. FIRST) THEN FIRST = .FALSE. WRITE (*,*) WRITE (*,*) 'HARRIS KERMIT REQUESTS THE FOLLOWING FROM LOCAL:' WRITE (*,*) WRITE (*,*) 'BIGGEST PACKET I CAN RECEIVE IS', MRPSIZ,' CHARS' WRITE (*,*) 'SUGGEST THEY TIMEOUT AFTER', MYTIME, ' SECONDS' WRITE (*,*) 'PREFIX PACKETS WITH', MYPAD, ' PAD CHARS', + ', USING CHARACTER', MYPCHR WRITE (*,*) 'TERMINATE PACKETS WITH CHARACTER', MYEOL WRITE (*,*) 'I WILL SEND "', CHAR(MYQUOT), + '" TO QUOTE CONTROL CHARACTERS' WRITE (*,*) '(USE DEFAULTS FOR THE REMAINDER)' WRITE (*,*) END IF END SUBROUTINE RPAR(DATA,NDATA) C--- C--- GET THE OTHER HOST'S SEND-INIT PARAMETERS C--- INTEGER DATA(*),NDATA LOGICAL DEBUG COMMON /DBGCOM/ DEBUG INTEGER MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME COMMON /SNDCOM/ MSPSIZ,NSPAD,NSPCHR,NSEOL,NSQUOT,NSTIME INTEGER UNCHAR,CTL INTEGER I LOGICAL FIRST DATA FIRST /.TRUE./ C READ THEIR PACKET IF (NDATA .LT. 1) GO TO 200 I = UNCHAR( DATA(1) ) ! BIGGEST PACKET THEY CAN RECEIVE IF (I .GT. 0 .AND. I .LT. MSPSIZ) MSPSIZ = I IF (NDATA .LT. 2) GO TO 200 NSTIME = UNCHAR( DATA(2) ) ! WHEN THEY WANT TIMEOUT IF (NDATA .LT. 3) GO TO 200 NSPAD = UNCHAR( DATA(3) ) ! HOW MUCH PADDING TO SEND THEM IF (NDATA .LT. 4) GO TO 200 NSPCHR = CTL( DATA(4) ) ! PAD CHARACTER TO USE IF (NDATA .LT. 5) GO TO 200 I = UNCHAR( DATA(5) ) ! EOL TO SEND THEM IF (I .GT. 0) NSEOL = I IF (NDATA .LT. 6) GO TO 200 I = DATA(6) ! INCOMING DATA QUOTE CHARACTER IF (I .GT. 0) NSQUOT = I 200 IF (DEBUG .AND. FIRST) THEN FIRST = .FALSE. WRITE (*,*) WRITE (*,*) 'REQUESTED OF HARRIS KERMIT BY LOCAL:' WRITE (*,*) WRITE (*,*) 'BIGGEST PACKET TO SEND THEM IS', MSPSIZ, ' CHARS' WRITE (*,*) 'SUGGEST I TIMEOUT AFTER', NSTIME, ' SECONDS' WRITE (*,*) 'PREFIX PACKETS WITH', NSPAD, ' PAD CHARS', + ', USING CHARACTER', NSPCHR WRITE (*,*) 'TERMINATE PACKETS WITH CHARACTER', NSEOL WRITE (*,*) 'THEY WILL SEND "', CHAR(NSQUOT), + '" TO QUOTE CONTROL CHARACTERS' WRITE (*,*) '(USING DEFAULTS FOR THE REMAINDER, REGARDLESS)' WRITE (*,*) END IF END SUBROUTINE PUTDAT(MSG,PREFIX,MXDATA,DATA,NDATA) C--- C--- FILL PACKET DATA WITH SPECIFIED CHARACTER STRING C--- C--- NON-ZERO PREFIXES MESSAGE WITH "HARRIS:" IDENTIFIER C--- CHARACTER MSG*(*) INTEGER PREFIX,MXDATA,DATA(*),NDATA INTEGER N,C,I CHARACTER PRE*8 DATA PRE /'HARRIS: '/ C COPY PREFIX INTO DATA ARRAY IF REQUESTED NDATA = 0 IF (PREFIX .NE. 0) THEN FOR I=1,LEN(PRE) EXIT FOR IF (NDATA .GE. MXDATA) NDATA = NDATA + 1 DATA(NDATA) = ICHAR( PRE(I:I) ) END FOR END IF C COPY MESSAGE INTO DATA ARRAY, WITHOUT TRAILING BLANKS N = NDATA FOR I=1,LEN(MSG) EXIT FOR IF (N .GE. MXDATA) C = ICHAR( MSG(I:I) ) N = N + 1 IF (C .NE. ICHAR(' ') ) NDATA = N DATA(N) = C END FOR END INTEGER FUNCTION ICHKFN(PACK,NPACK) C--- C--- CALCULATE CHECKSUM AND CONVERT TO PRINTABLE FORM C--- INTEGER PACK(*),NPACK INTEGER MAKEC INTEGER S,CHKSUM,I S = 0 FOR I=2,NPACK-1 S = S + PACK(I) END FOR C CHECKSUM = LOW ORDER 6 BITS OF THE RESULT OF THE FUNCTION: C S(BITS 0:5) + S(BITS 6:7) C WHERE S IS THE SUM OF ALL CHARACTERS IN THIS PACKET CHKSUM = (S + ((S .AND. '300)/'100)) .AND. '77 ICHKFN = MAKEC(CHKSUM) END INTEGER FUNCTION MAKEC(ICHR) C--- C--- CONVERT A NUMBER TO A PRINTABLE CHARACTER C--- INTEGER ICHR MAKEC = ICHR + 32 END INTEGER FUNCTION UNCHAR(ICHR) C--- C--- RESTORE A NUMBER FROM A CHARACTER (REVERSE OF "MAKEC") C--- INTEGER ICHR UNCHAR = ICHR - 32 END LOGICAL FUNCTION ISCTRL(ICHR) C--- C--- RETURN TRUE IF SPECIFIED CHARACTER A CONTROL CHARACTER C--- INTEGER ICHR ISCTRL = (ICHR .LT. 32 .OR. ICHR .EQ. 127) END INTEGER FUNCTION CTL(ICHR) C--- C--- TOGGLE A CHARACTER BETWEEN CONTROL AND PRINTABLE REPRESENTATIONS C--- INTEGER ICHR CTL = ICHR .XOR. 64 END