* BASE -ULTLY-KERM -SFM-A2703 - 08/01/90 WJH HEADER SFMKERM 0001.000 SUBROUTINE SNDPACK(TYPE, NUM, LEN, DATA) 0001.100 IMPLICIT NONE 0002.000 INTEGER TYPE !type of packet 0003.000 INTEGER NUM !packet number 0004.000 INTEGER LEN !length of packet 0005.000 INTEGER DATA(LEN) !packet to send 0006.000 INTEGER LEN1 0006.100 INTEGER LEN2 0006.200 INTEGER LENP6 0006.300 INTEGER CHCKSM 0006.400 C 0007.000 C= Send a packet down an output stream 0008.000 C 0009.000 C Sndpack will send a packet of information and log it 0010.000 C if debug is turned on. This subroutine could be made 0011.000 C more efficient by not calling a subroutine for each 0012.000 C character, but that might cause portability problems. 0013.000 C 0014.000 INCLUDE K.KERMD 0015.000 INCLUDE K.DBUGC 0016.000 INCLUDE K.PROTC 0017.000 INCLUDE K.PACKC 0018.000 C 0019.000 INTEGER I 0020.000 INTEGER CHKSUM ! com puted checksum 0021.000 INTEGER TMP 0022.000 INTEGER NCH !number of characters 0023.000 C 0024.000 INTEGER TOCHAR 0025.000 INTEGER CHKSUMER !find checksum 0026.000 C 0027.000 IF (DEBUG(DBGPACK)) THEN 0028.000 CALL PRINTL(DBGFD, 'Sending...') 0029.000 ENDIF 0030.000 C 0031.000 C put out pad chars 0032.000 C 0033.000 DO I=1, SPAD 0034.000 CALL PUTC(OFD, SPADCH) 0035.000 IF (DEBUG(DBGPACK)) THEN 0036.000 CALL PUTC(DBGFD, SPADCH) 0037.000 ENDIF 0038.000 ENDDO 0039.000 CALL PUTC(OFD, SNDSYNC) 0040.000 C 0041.000 C packet len assumes one character checksums 0042.000 C 0043.000 LENP6 = LEN 0043.010 IF((LENP6).GT.95)THEN 0043.100 LEN1 = (LENP6)/95 0043.200 LEN2 = (LENP6) - LEN1*95 + 1 0043.300 CHKSUM= 2Z20 0043.400 ELSE 0043.500 CHKSUM = TOCHAR(LEN+3) 0044.000 ENDIF 0044.100 CALL PUTC(OFD, CHKSUM) 0045.000 TMP = TOCHAR(NUM) 0046.000 CHKSUM = CHKSUM + TMP 0047.000 CALL PUTC(OFD, TMP) 0048.000 CHKSUM = CHKSUM + TYPE 0049.000 CALL PUTC(OFD, TYPE) 0050.000 IF(LENP6.GT.95)THEN 0050.100 TMP = TOCHAR(LEN1) 0050.110 CHKSUM = CHKSUM + TMP 0050.120 CALL PUTC(OFD,TMP) 0050.200 TMP = TOCHAR(LEN2) 0050.210 CHKSUM = CHKSUM + TMP 0050.220 CALL PUTC(OFD,TMP) 0050.300 CHCKSM = CHKSUMER(CHKSUM) + 2Z20 0050.310 CALL PUTC(OFD,CHCKSM) 0050.400 CHKSUM = CHKSUM + CHCKSM 0050.410 ENDIF 0050.500 DO I=1, LEN 0051.000 CHKSUM = CHKSUM + DATA(I) 0052.000 CALL PUTC(OFD, DATA(I)) 0053.000 ENDDO 0054.000 CHKSUM = CHKSUMER(CHKSUM) 0055.000 CALL PUTC(OFD, TOCHAR(CHKSUM)) 0056.000 CALL PUTC(OFD, SPEOL) 0057.000 IF (DEBUG(DBGPACK)) THEN 0058.000 CALL PUTC(DBGFD, SNDSYNC) 0059.000 CALL PUTC(DBGFD, TOCHAR(LEN+3)) 0060.000 CALL PUTC(DBGFD, TOCHAR(NUM)) 0061.000 CALL PUTC(DBGFD, TYPE) 0062.000 IF (LEN .GT. 0) CALL PUTSTR(DBGFD, DATA) 0063.000 CALL PUTC(DBGFD, TOCHAR(CHKSUM)) 0064.000 CALL PUTC(DBGFD, SPEOL) 0065.000 CALL FLUSH(DBGFD) 0066.000 ENDIF 0067.000 C 0068.000 C force buffer flush since desired eol char won't 0069.000 C 0070.000 CALL FLUSH(OFD) 0071.000 C 0072.000 C update the statistics 0073.000 C 0074.000 NCH = SPAD + 5 + LEN + 1 0075.000 SCHCNT = SCHCNT + NCH 0076.000 SCHOVRH = SCHOVRH + NCH - LEN 0077.000 RETURN 0078.000 END 0079.000 INTEGER FUNCTION RDPACK(LEN, NUM, DATA) 0080.000 IMPLICIT NONE 0081.000 INTEGER LEN !length of packet read 0082.000 INTEGER NUM !packet number 0083.000 INTEGER DATA(*) !data read 0084.000 C 0085.000 C= Read a packet of information 0086.000 INCLUDE K.KERMD 0087.000 INCLUDE K.DBUGC 0088.000 INCLUDE K.PROTC 0089.000 INCLUDE K.PACKC 0090.000 LOGICAL BREAK 0091.000 COMMON /BREAK/BREAK 0092.000 C 0093.000 INTEGER CHKSUM 0094.000 INTEGER FIELD 0095.000 INTEGER NCH 0096.000 INTEGER CH 0097.000 INTEGER TYPE 0098.000 INTEGER I 0099.000 INTEGER STIME !start time 0100.000 INTEGER FTIME !finish time 0101.000 C 0102.000 INTEGER GETC 0103.000 INTEGER UNCHAR 0104.000 INTEGER CHKSUMER !compute checksum 0105.000 INTEGER LEN1,LEN2 0105.100 INTEGER LOOPF 0105.200 INTEGER LPK 0105.300 C 0106.000 C debug 0107.000 C 0108.000 IF (DEBUG(DBGPACK)) THEN 0109.000 CALL PRINTL(DBGFD, 'Reading...') 0110.000 ENDIF 0111.000 NCH = 0 0112.000 C 0113.000 C hunt for start of packet 0114.000 C 0115.000 LEN = 0 0116.000 LOOPF = 0 0116.100 CHKSUM = 0 0117.000 CALL MSEC(STIME) 0118.000 BREAK = .FALSE. 0119.000 10 CONTINUE 0120.000 CALL MSEC(FTIME) 0121.000 IF ((FTIME-STIME)/1000 .GT. TIMEOUT .OR. BREAK) THEN 0122.000 IF (DEBUG(DBGPACK)) THEN 0123.000 IF (BREAK) THEN 0124.000 CALL PRINTL(DBGFD, 'BREAK TIMEOUT') 0125.000 ELSE 0126.000 CALL PRINTL(DBGFD, 'TIMEOUT') 0127.000 ENDIF 0128.000 ENDIF 0129.000 RDPACK = ERROR 0130.000 GOTO 30 !RETURN 0131.000 ENDIF 0132.000 CH = GETC(IFD, CH) 0133.000 IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH) 0134.000 IF (CH .EQ. ERROR) THEN 0135.000 GOTO 10 0136.000 ENDIF 0137.000 NCH = NCH + 1 0138.000 CLT IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH) 0139.000 IF (CH .NE. SYNC) GOTO 10 0140.000 CALL MSEC(STIME) 0140.100 C 0141.000 C parse each field of the packet 0142.000 C 0143.000 FIELD = 1 0144.000 20 CONTINUE 0145.000 CALL MSEC(FTIME) 0146.000 IF ((FTIME-STIME)/1000 .GT. TIMEOUT .OR. BREAK) THEN 0147.000 RDPACK = ERROR 0148.000 X WRITE(19,1481)FTIME,STIME,TIMEOUT ,I 0148.100 X1481 FORMAT(' 1481** ',4(1X,1Z8)) 0148.200 GOTO 30 !RETURN 0149.000 ENDIF 0150.000 21 IF (FIELD .LE. (5+LOOPF)) THEN 0151.000 C 0152.000 C a character read in field 4 here is the first char of the 0153.000 C data field or the checksum character if the data field is 0154.000 C empty 0155.000 C 0156.000 IF (FIELD .NE. (5+LOOPF) .OR. LEN .GT. 0) THEN 0157.000 IF (GETC(IFD, CH) .EQ. SYNC) FIELD = 0 0158.000 NCH = NCH + 1 0159.000 IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH) 0160.000 ENDIF 0161.000 IF (FIELD .LE. 3 ) CHKSUM = CHKSUM + CH 0162.000 C 0163.000 C if resync 0164.000 C 0165.000 IF (FIELD .EQ. 0) THEN 0166.000 CHKSUM = 0 0167.000 IF (DEBUG(DBGPACK)) THEN 0168.000 CALL PRINTL(DBGFD, 'Reading...') 0169.000 CALL PUTC(DBGFD, SYNC) 0170.000 ENDIF 0171.000 C 0172.000 C if data length 0173.000 C 0174.000 ELSE IF (FIELD .EQ. 1) THEN 0175.000 IF(CH.EQ.2Z20)THEN 0175.100 LEN = 0 0175.200 LPK = 1 0175.210 ELSE 0175.300 LEN = UNCHAR(CH-3) 0176.000 LPK = 0 0176.010 ENDIF 0176.100 C 0177.000 C if pack number 0178.000 C 0179.000 ELSE IF (FIELD .EQ. 2) THEN 0180.000 NUM = UNCHAR(CH) 0181.000 C 0182.000 C if packet type 0183.000 C 0184.000 ELSE IF (FIELD .EQ. 3) THEN 0185.000 TYPE = CH 0186.000 ELSE IF (FIELD .EQ. 4 .AND. LPK .EQ. 1) THEN 0186.100 CHKSUM = CHKSUM + CH 0186.200 LOOPF = 3 0186.220 LEN1 = UNCHAR(CH)*95 0186.230 ELSE IF (FIELD .EQ. 5 .AND. LPK .EQ. 1) THEN 0186.300 CHKSUM = CHKSUM + CH 0186.301 LEN2 = UNCHAR(CH) 0186.310 LEN = LEN1 + LEN2 - 1 0186.400 IF(LEN.GT.MAXPACK)THEN 0186.410 RDPACK = ERROR 0186.420 GO TO 30 0186.430 ENDIF 0186.440 ELSE IF (FIELD .EQ. 6 .AND. LPK .EQ. 1) THEN 0186.500 CHKSUM = CHKSUM + CH 0186.600 C 0187.000 C if data field is not empty 0188.000 C 0189.000 ELSE IF (FIELD .EQ. (4+LOOPF) .AND. LEN .GT. 0) THEN 0190.000 C 0191.000 C read 2nd-len chars of data  checksum char 0192.000 C 0193.000 X WRITE(19,1002)LEN,LEN1,LEN2,FIELD,LOOPF,CHKSUM 0193.100 X1002 FORMAT(' 1932** ',6(1X,1Z8)) 0193.200 DO I=1, LEN 0194.000 CALL MSEC(FTIME) 0195.000 IF ((FTIME-STIME)/1000 .GT. TIMEOUT .OR. BREAK) THEN 0196.000 RDPACK = ERROR 0197.000 X WRITE(19,1971)FTIME,STIME,TIMEOUT ,I 0197.100 X1971 FORMAT(' 1971** ',4(1X,1Z8)) 0197.200 GOTO 30 !RETURN 0198.000 ENDIF 0199.000 IF (I .GT. 1) THEN 0200.000 CH = GETC(IFD, CH) 0201.000 NCH = NCH + 1 0202.000 C IF (CH .EQ. SYNC) THEN 0203.000 C FIELD = 0 0204.000 C CALL MSEC(STIME) 0204.100 C WRITE(19,2041)LEN,LEN1,LEN2,CH,SYNC,STIME,I 0204.200 C2041 FORMAT(' 2041** ',7(1X,1Z8)) 0204.300 C GOTO 20 0205.000 C ENDIF 0206.000 C IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH) 0207.000 ENDIF 0208.000 CHKSUM = CHKSUM + CH 0209.000 DATA (I) = CH 0210.000 ENDDO 0211.000 FIELD = FIELD + 1 0211.100 GO TO 21 0211.200 C 0212.000 C if chksum char 0213.000 C 0214.000 ELSE IF (FIELD .EQ. (5+LOOPF)) THEN 0215.000 DATA(LEN+1) = 0 0216.000 X WRITE(19,2161)CHKSUM 0216.100 X2161 FORMAT(' CHKSUM = ',1Z8) 0216.200 CHKSUM = CHKSUMER(CHKSUM) 0217.000 ENDIF 0218.000 C 0219.000 C process next packet field 0220.000 C 0221.000 FIELD = FIELD + 1 0222.000 X WRITE(19,1005)FIELD,LEN,LOOPF,CH,CHKSUM 0222.100 X1005 FORMAT(' 2222** ',5(1X,1Z8)) 0222.200 GOTO 20 0223.000 ENDIF 0224.000 IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, NEL) 0225.000 C 0226.000 C does the checksum match 0227.000 C 0228.000 IF (CHKSUM .NE. UNCHAR(CH)) THEN 0229.000 X WRITE(19,2291)LEN,NCH,CHKSUM,CH 0229.100 X2291 FORMAT(' 2291** ',4(1X,1Z8)) 0229.200 X WRITE(19,2292)( DATA(I),I=1,LEN) 0229.300 X2292 FORMAT(1X,19A4) 0229.400 RDPACK = ERROR 0230.000 RCHOVRH = RCHOVRH + NCH 0231.000 IF (DEBUG(DBGON)) THEN 0232.000 CALL PRINTL(DBGFD, 'chksum error, found ') 0233.000 CALL PUTINT(DBGFD, UNCHAR(CH), 1) 0234.000 CALL PRINT(DBGFD, ' needed ') 0235.000 CALL PUTINT(DBGFD, CHKSUM, 1) 0236.000 ENDIF 0237.000 ELSE 0238.000 X WRITE(19,2381)LEN,NCH,CHKSUM,CH 0238.100 X2381 FORMAT(' 2381** ',4(1X,1Z8)) 0238.200 RDPACK = TYPE 0239.000 RCHOVRH = RCHOVRH + NCH - LEN 0240.000 ENDIF 0241.000 RCHCNT = RCHCNT + NCH 0242.000 C 0243.000 C flush any eol characters and other garbage 0244.000 C 0245.000 CALL FLUSH(IFD) 0246.000 30 CONTINUE !error exit 0247.000 IF (DEBUG(DBGON)) THEN 0248.000 CALL FLUSH(DBGFD) 0249.000 ENDIF 0250.000 RETURN 0251.000 END 0252.000 INTEGER FUNCTION BUFFIL(FD, BUFFER) 0253.000 IMPLICIT NONE 0254.000 INTEGER FD !file device 0255.000 INTEGER BUFFER(*) !buffer to fill 0256.000 C 0257.000 C= Get some data to send. 0258.000 C 0259.000 C BUFFIL READS FROM THE FILE TO SEND AND PERFORMS ALL 0260.000 C THE PROPER ESCAPING OF CONTROL CHARACTERS AND MAPPING 0261.000 C NEWLINES INTO CRLF SEQUENCES. IF IT EVER GETS SMART 0262.000 C ENOUGH, IT WILL ALSO DO THE 8 BIT QUOTING AND REPEAT 0263.000 C COUNTS. 0264.000 C 0265.000 C *** NOTE: THIS ALGORTHM ASSUMES 5 OVERHEAD CHARACTERS FOR THE 0266.000 C PACKET AND LEAVES 3 CHARACTERS IN CASE THE LAST CHARACTER TO 0267.000 C BUFFER IS A NEL (EXPANDS TO 4 CHARACTERS). 0268.000 INCLUDE K.KERMD 0269.000 INCLUDE K.DBUGC 0270.000 INCLUDE K.PROTC 0271.000 INCLUDE K.PACKC 0272.000 C 0273.000 INTEGER I 0274.000 INTEGER CH 0275.000 INTEGER X18 /X'18'/ 0276.000 INTEGER X50 /X'50'/ 0277.000 INTEGER TEMPCH,TEMPCH1,TEMPCH2 0278.000 INTEGER FIEND /X'A0'/ 0279.000 C 0280.000 INTEGER GETC 0281.000 INTEGER CTL !control switch 0282.000 C 0283.000 C 0284.000 C get a packet worth of data 0285.000 C 0286.000 I = 0 0287.000 X WRITE(19,1000)SPKSIZ 0287.100 X1000 FORMAT(' 2873**' 1X,1Z8) 0287.200 10 CONTINUE 0288.000 C READ A CHARACTER FROM THE FILE TO BE TRANSFERRED 0289.000 TEMPCH = GETC(FD, CH) 0290.000 IF (TEMPCH .NE. EOF) THEN 0291.000 IF (CH .LT. BLANK .OR. CH .EQ. DEL .OR. CH .EQ. NEL .OR. 0292.000 $ CH .EQ. SPQUOTE) THEN 0293.000 IF (CH .EQ. NEL) THEN 0294.000 BUFFER(I+1) = SPQUOTE 0295.000 BUFFER(I+2) = CTL(CR) 0296.000 I = I + 2 0297.000 CH = LF 0298.000 ENDIF 0299.000 I = I + 1 0300.000 BUFFER(I) = SPQUOTE 0301.000 IF (CH .NE. SPQUOTE) CH = CTL(CH) 0302.000 ENDIF 0303.000 I = I + 1 0304.000 C Put the character into the Output Buffer 0305.000 BUFFER(I) = CH 0306.000 IF (I .GE. SPKSIZ-10) THEN 0307.000 BUFFIL = I 0308.000 GOTO 99 0309.000 ENDIF 0310.000 GOTO 10 0311.000 ENDIF 0312.000 90 IF (I .EQ. 0) THEN 0313.000 BUFFIL = EOF 0314.000 ELSE 0315.000 BUFFIL = I 0316.000 ENDIF 0317.000 99 CONTINUE 0318.000 C Check for END OF BLOCK 0319.000 IF (BUFFER(I).EQ.X50.AND.BUFFER(I-1).EQ.X'20') THEN 0320.000 TEMPCH = GETC(FD,CH) 0321.000 IF (CH.EQ.0) THEN 0322.000 BUFFER(I-1) = LF 0323.000 BUFFER(I) = 0 0324.000 I = I - 1 0325.000 ELSE 0326.000 I = I + 1 0327.000 BUFFER(I) = CH 0328.000 END IF 0329.000 BUFFIL = I 0330.000 END IF 0331.000 C IF (BUFFER(I).EQ.X'20') THEN 0332.000 C TEMPCH1 = GETC(FD,CH) 0333.000 C IF (TEMPCH1.EQ.X50) THEN 0334.000 C TEMPCH2 = GETC(FD,CH) 0335.000 C IF (TEMPCH2.EQ.0) THEN 0336.000 C BUFFER(I) = LF 0337.000 C ELSE 0338.000 C BUFFER(I+1) = TEMPCH1 0339.000 C BUFFER(I+2) = TEMPCH2 0340.000 C I = I + 2 0341.000 C END IF 0342.000 C ELSE 0343.000 C I = I + 1 0344.000 C BUFFER(I) = CH 0345.000 C END IF 0346.000 C END IF 0347.000 C END IF 0348.000 BUFFER(I+1) = 0 0349.000 RETURN 0350.000 END 0351.000 SUBROUTINE BUFEMP( BUFFER, FD, LEN) 0352.000 IMPLICIT NONE 0353.000 INTEGER BUFFER(*) !buffer to empty 0354.000 INTEGER FD !file descriptor 0355.000 INTEGER LEN !length of buffer to empty 0356.000 C 0357.000 C= dumps a buffer to a file 0358.000 C 0359.000 INCLUDE K.KERMD 0360.000 INCLUDE K.DBUGC 0361.000 INCLUDE K.PROTC 0362.000 INCLUDE K.PACKC 0363.000 C 0364.000 INTEGER I,J 0365.000 INTEGER PREVCH 0366.000 INTEGER CH 0367.000 C 0368.000 INTEGER CTL 0369.000 INTEGER CHN 0369.100 C 0370.000 C 0371.000 C write the packet data to the file 0372.000 C 0373.000 X WRITE(19,1000)QUOTECH,CR,LF,LEN 0373.100 X1000 FORMAT(' 3732** ',4(1X,1Z8)) 0373.200 X WRITE(19,1001)BUFFER 0373.300 X1001 FORMAT(1X,80A4) 0373.400 I = 1 0374.000 10 CONTINUE 0375.000 IF (I .LE. LEN) THEN 0376.000 CH = BUFFER(I) 0377.000 IF (CH .EQ. QUOTECH) THEN 0378.000 I = I + 1 0379.000 CH = BUFFER(I) 0380.000 IF (CH .EQ. RPREFIX)THEN 0380.100 CONTINUE 0380.200 ELSE IF (CH .NE. QUOTECH) THEN 0381.000 CH = CTL(CH) 0381.010 ENDIF 0381.020 ELSE IF(CH .EQ. RPREFIX)THEN 0381.100 I = I + 1 0381.110 CH = BUFFER(I) 0381.120 CHN = CH - 2Z21 0381.800 I = I + 1 0381.900 CH = BUFFER(I) 0381.910 IF(CH.EQ.QUOTECH)THEN 0381.911 I = I + 1 0381.912 CH = BUFFER(I) 0381.913 ENDIF 0381.914 DO J =1,CHN 0381.920 CALL PUTC(FD,CH) 0381.930 ENDDO 0381.940 ENDIF 0382.000 C 0383.000 C convert cr/lf pair to NEL 0384.000 C 0385.000 IF (CH .EQ. LF .AND. PREVCH .EQ. CR) THEN 0386.000 CH = NEL 0387.000 C 0388.000 C just a lone cr 0389.000 C 0390.000 ELSE IF (PREVCH .EQ. CR) THEN 0391.000 CALL PUTC(FD, PREVCH) 0392.000 ENDIF 0393.000 IF (CH .NE. CR) CALL PUTC(FD, CH) 0394.000 PREVCH = CH 0395.000 I = I + 1 0396.000 GOTO 10 0397.000 ENDIF 0398.000 RETURN 0399.000 END 0400.000 INTEGER FUNCTION CHKSUMER (SUM) 0401.000 IMPLICIT NONE 0402.000 INTEGER SUM !sum to find check sum of 0403.000 C 0404.000 C= Compute checksum for transmission 0405.000 C 0406.000 INTEGER HIGHBITS/X'C0'/ !mask for high bits 0407.000 INTEGER SHIFTLOW /X'40'/ !make them low bits 0408.000 INTEGER SIXBITS /X'3F'/ !return only six bits 0409.000 C 0410.000 INTEGER IAND !and words together 0411.000 C 0412.000 CHKSUMER = IAND (SUM + IAND (SUM,HIGHBITS) / SHIFTLOW, 0413.000 $ SIXBITS) 0414.000 RETURN 0415.000 END 0416.000