* BASE -ULTLY-KERM -SFM-A2703 - 08/01/90 WJH HEADER SFMKERM 0001.000 SUBROUTINE AS2DPC(ASTR,DSTR) 0001.100 IMPLICIT NONE 0002.000 INTEGER ASTR(1000) 0003.000 CHARACTER*(*) DSTR 0004.000 0005.000 C= Translate ascii integer string to character string 0006.000 C 0007.000 C ASCII STRING IS TERMINATED BY A ZERO BYTE. 0008.000 C 0009.000 C 0010.000 INTEGER CLEN 0011.000 INTEGER I 0012.000 C 0013.000 INTRINSIC CHAR,LEN 0013.100 C CHARACTER*1 CHAR 0014.000 INTEGER LEN 0015.000 C 0016.000 I = 1 0017.000 CLEN = LEN(DSTR) 0018.000 DSTR = ' ' 0019.000 10 IF (ASTR(I) .NE. 0 .AND. I .LE. CLEN) THEN 0020.000 DSTR(I:I) = CHAR(ASTR(I)) 0021.000 I = I + 1 0022.000 GO TO 10 0023.000 ENDIF 0024.000 C 0025.000 RETURN 0026.000 END 0027.000 SUBROUTINE DPC2AS(DSTR,ASTR,N) 0028.000 IMPLICIT NONE 0029.000 CHARACTER*(*) DSTR 0030.000 INTEGER ASTR(1000) 0031.000 INTEGER N 0032.000 C 0033.000 C= TRANSLATE STRING OF DISPLAY CODE CHARACTERS ASCII INTEGER STRING. 0034.000 C STRING IS N CHARACTERS (WORDS) LONG. 0035.000 C 0036.000 C 0037.000 INTEGER I 0038.000 C 0039.000 INTRINSIC ICHAR 0040.100 C INTEGER ICHAR 0040.200 C 0041.000 DO I=1,N 0042.000 ASTR(I) = ICHAR(DSTR(I:I)) 0043.000 ENDDO 0044.000 C 0045.000 C SET ASCII END-OF-STRING-BUFFER 0046.000 C 0047.000 ASTR(N+1) = 0 0048.000 C 0049.000 RETURN 0050.000 END 0051.000 INTEGER FUNCTION CTOI(ASTR) 0052.000 IMPLICIT NONE 0053.000 INTEGER ASTR(1000) 0054.000 0055.000 C= CONVERT CHARACTER BUFFER TO INTEGER. 0056.000 C 0057.000 C CTOI CONVERTS THE NUMBER USING BASE 10 AS A DEFAULT. 0058.000 C A SUFFIX OF H WILL CONVERT USING BASE 16 AND A SUFFIX 0059.000 C OF O WILL CONVERT USING BASE 8. DEFAULT SUFFIX IS 0060.000 C D. 0061.000 C 0062.000 INCLUDE K.KERMD 0063.000 INTEGER DIG0, DIG7, DIG9, BIGA, BIGB, BIGD 0064.000 INTEGER BIGF, BIGH, BIGO, LETA, LETB, LETD 0065.000 INTEGER LETF, LETH, LETO 0066.000 PARAMETER (DIG0=48, DIG7=55, DIG9=57, BIGA=65, BIGB=66, BIGD=68) 0067.000 PARAMETER (BIGF=70, BIGH=72, BIGO=79, LETA=97, LETB=98, LETD=100) 0068.000 PARAMETER (LETF=102, LETH=104, LETO=111) 0069.000 INTEGER BASE 0070.000 INTEGER PTR 0071.000 INTEGER EOD 0072.000 INTEGER CH 0073.000 INTEGER TOTAL 0074.000 INTEGER ISNEG 0075.000 INTEGER I 0076.000 0077.000 BASE = 0 0078.000 PTR = 0 0079.000 C 0080.000 C FIND LAST VALID DIGIT 0081.000 C 0082.000 10 PTR = PTR + 1 0083.000 IF (ASTR(PTR) .NE. 0) GO TO 10 0084.000 PTR = PTR - 1 0085.000 IF (ASTR(PTR) .EQ. LETO .OR. ASTR(PTR) .EQ. BIGO .OR. 0086.000 + ASTR(PTR) .EQ. LETB .OR. ASTR(PTR) .EQ. BIGB .OR. 0087.000 + ASTR(PTR) .EQ. LETH .OR. ASTR(PTR) .EQ. BIGH) THEN 0088.000 EOD = PTR - 1 0089.000 ELSE 0090.000 EOD = PTR 0091.000 PTR = PTR + 1 0092.000 ENDIF 0093.000 C 0094.000 C TRY TO FIGURE OUT THE BASE 0095.000 C 0096.000 IF (ASTR(PTR) .EQ. 0) THEN 0097.000 BASE = 10 0098.000 ELSE IF (ASTR(PTR) .EQ. LETO .OR. ASTR(PTR) .EQ. BIGO .OR. 0099.000 + ASTR(PTR) .EQ. LETB .OR. ASTR(PTR) .EQ. BIGB) THEN 0100.000 BASE = 8 0101.000 ELSE IF (ASTR(PTR) .EQ. LETH .OR. ASTR(PTR) .EQ. BIGH) THEN 0102.000 BASE = 16 0103.000 ENDIF 0104.000 C 0105.000 C IF DIDN'T FIND A BASE 0106.000 C 0107.000 IF (BASE .EQ. 0) THEN 0108.000 CALL PRINTL(STDOUT,'CTOI - Invalid base ') 0109.000 CALL PUTC(STDOUT, ASTR(PTR)) 0110.000 CALL FLUSH(STDOUT) 0111.000 CTOI = 0 0112.000 RETURN 0113.000 ENDIF 0114.000 C 0115.000 C ADD UP THE DIGITS 0116.000 C 0117.000 TOTAL = 0 0118.000 ISNEG = 1 0119.000 DO 100 I = 1,EOD 0120.000 CH = ASTR(I) 0121.000 IF (CH .EQ. MINUS) THEN 0122.000 ISNEG = -1 0123.000 GO TO 100 0124.000 ENDIF 0125.000 IF (BASE .EQ. 10) THEN 0126.000 IF (CH .LT. DIG0 .OR. CH .GT. DIG9) THEN 0127.000 CALL PRINTL(STDOUT,'CTOI - Invalid decimal digit ') 0128.000 CALL PUTC(STDOUT, CH) 0129.000 CALL FLUSH(STDOUT) 0130.000 CTOI = 0 0131.000 RETURN 0132.000 ELSE 0133.000 CH = CH - DIG0 0134.000 ENDIF 0135.000 ELSE IF (BASE .EQ. 8) THEN 0136.000 IF (CH .LT. DIG0 .OR. CH .GT. DIG7) THEN 0137.000 CALL PRINTL(STDOUT,'CTOI - Invalid octal digit ') 0138.000 CALL PUTC(STDOUT, CH) 0139.000 CALL FLUSH(STDOUT) 0140.000 CTOI = 0 0141.000 RETURN 0142.000 ELSE 0143.000 CH = CH - DIG0 0144.000 ENDIF 0145.000 ELSE IF (BASE .EQ. 16) THEN 0146.000 IF (CH .GE. DIG0 .AND. CH .LE. DIG9) THEN 0147.000 CH = CH - DIG0 0148.000 ELSE IF (CH .GE. LETA .AND. CH .LE. LETF) THEN 0149.000 CH = 10 + CH - LETA 0150.000 ELSE IF (CH .GE. BIGA .AND. CH .LE. BIGF) THEN 0151.000 CH = 10 + CH - BIGA 0152.000 ELSE 0153.000 CALL PRINTL(STDOUT,'CTOI - Invalid hex digit ') 0154.000 CALL PUTC(STDOUT, CH) 0155.000 CALL FLUSH(STDOUT) 0156.000 CTOI = 0 0157.000 RETURN 0158.000 ENDIF 0159.000 ENDIF 0160.000 TOTAL = TOTAL*BASE + CH 0161.000 100 CONTINUE 0162.000 CTOI = TOTAL * ISNEG 0163.000 RETURN 0164.000 END 0165.000 INTEGER FUNCTION ITOS(INT,STR,MINWID) 0166.000 IMPLICIT NONE 0167.000 INTEGER INT 0168.000 INTEGER STR(1000) 0169.000 INTEGER MINWID 0170.000 0171.000 CCC ITOS - CONVERT AN INTEGER TO STRING FORMAT. 0172.000 C 0173.000 INCLUDE K.KERMD 0174.000 INTEGER WIDTH 0175.000 INTEGER VAL 0176.000 INTEGER ASCII0 0177.000 INTEGER TCH 0178.000 INTEGER IPTR 0179.000 INTEGER ENDPTR 0180.000 C 0181.000 INTEGER MOD 0182.000 INTRINSIC ICHAR 0183.100 C INTEGER ICHAR 0183.200 0184.000 WIDTH = 0 0185.000 IF (INT .LT. 0) THEN 0186.000 WIDTH = 1 0187.000 STR(WIDTH) = ICHAR('-') 0188.000 ENDIF 0189.000 VAL = IABS(INT) 0190.000 ASCII0 = ICHAR('0') 0191.000 10 WIDTH = WIDTH + 1 0192.000 STR(WIDTH) = MOD(VAL,10) + ASCII0 0193.000 VAL = VAL / 10 0194.000 IF (VAL .NE. 0) GO TO 10 0195.000 STR(WIDTH+1) = 0 0196.000 C 0197.000 C NOW REVERSE THE DIGITS 0198.000 C 0199.000 IPTR = 1 0200.000 ENDPTR = WIDTH 0201.000 IF (STR(IPTR) .EQ. ICHAR('-')) IPTR = IPTR + 1 0202.000 20 IF (IPTR .LT. ENDPTR) THEN 0203.000 TCH = STR(IPTR) 0204.000 STR(IPTR) = STR(ENDPTR) 0205.000 STR(ENDPTR) = TCH 0206.000 IPTR = IPTR + 1 0207.000 ENDPTR = ENDPTR - 1 0208.000 GO TO 20 0209.000 ENDIF 0210.000 ITOS = WIDTH 0211.000 RETURN 0212.000 END 0213.000 INTEGER FUNCTION GETFILE(FN) 0214.000 IMPLICIT NONE 0215.000 INTEGER FN(2) !file name 0216.000 INTEGER ERRSTAT 0216.100 INTEGER*8 KERMIT /'KERMIT '/ 0216.200 INTEGER BLOCKS /4/ 0216.300 INTEGER DEVTYPE /2/ 0216.400 INTEGER*8 FNAME 0216.500 0217.000 C= Open a file for writing packet data to. 0218.000 C 0219.000 C GETFILE WILL TRY TO CREATE A FILE TO WRITE TO. IF IT 0220.000 C ALREADY EXISTS, THEN IT WILL FAIL. 0221.000 C 0222.000 CHARACTER*8 FILENAM 0223.000 EQUIVALENCE (FNAME,FILENAM) 0223.100 C 0224.000 INTEGER OPEN 0225.000 C 0226.000 INCLUDE K.KERMD 0227.000 C 0228.000 C GET THE DPC VERSION OF THE FILENAME 0229.000 C 0230.000 CALL AS2DPC(FN,FILENAM) 0231.000 CALL FILCHK(FILENAM) 0232.000 CALL M:CREATE(FNAME,BLOCKS,DEVTYPE,,,,,,,,,,ERRSTAT) 0232.200 IF (ERRSTAT.EQ.1) THEN 0232.300 GETFILE = OPEN(FILENAM, 'W') 0233.000 ELSE 0233.100 GETFILE = 0 0233.200 CALL M:DELETE(FNAME,,,ERRSTAT) 0233.300 END IF 0233.400 RETURN 0234.000 END 0235.000 SUBROUTINE GETNOW(MM,DD,YY,HR,MIN,SEC) 0236.000 IMPLICIT NONE 0237.000 INTEGER MM,DD,YY 0238.000 INTEGER HR,MIN,SEC 0239.000 INTEGER ATIME 0240.000 INTEGER*8 ADATE 0241.000 INTEGER*1 BITE(8) 0242.000 EQUIVALENCE (ADATE,BITE(1)) 0243.000 0244.000 CCC GET THE CURRENT DATE AND TIME. 0245.000 C 0246.000 INTEGER IDT(3) !INTEGER DATE AND TIME 0247.000 C 0248.000 CALL X:TDAY(ATIME,ADATE) 0249.000 CALL DATE(IDT) 0250.000 YY = IDT(1) 0251.000 IF (BITE(3).EQ.'-') THEN 0252.000 MM = IDT(3) 0253.000 DD = IDT(2) 0254.000 ELSE 0255.000 MM = IDT(2) 0256.000 DD = IDT(3) 0257.000 END IF 0258.000 C MM = IDT(2) 0259.000 C DD = IDT(3) 0260.000 CALL TIME(IDT) 0261.000 HR = IDT(1) 0262.000 MIN = IDT(2) 0263.000 SEC = IDT(3) 0264.000 RETURN 0265.000 END 0266.000 SUBROUTINE FILCHK(FN) 0267.000 IMPLICIT NONE 0268.000 CHARACTER*8 FN 0269.000 C 0270.000 C= Check validity of filename, remove special characters 0271.000 C 0272.000 INTEGER PTR,CH 0273.000 INTEGER I 0274.000 C 0275.000 INTRINSIC ICHAR,CHAR,LEN 0275.100 C INTEGER LEN 0276.000 C INTEGER ICHAR 0277.200 C CHARACTER*1 CHAR 0278.000 C 0279.000 PTR = 1 0280.000 DO I=1, LEN(FN) 0281.000 IF (FN(I:I) .EQ. ' ') THEN 0282.000 ELSE IF(FN(I:I) .GE. 'A' .AND. FN(I:I) .LE. 'Z') THEN 0283.000 FN(PTR:PTR) = FN(I:I) 0284.000 PTR = PTR + 1 0285.000 ELSE IF (FN(I:I) .GE. '0' .AND. FN(I:I) .LE. '9' .AND. 0286.000 $ I .NE. 1) THEN 0287.000 FN(PTR:PTR) = FN(I:I) 0288.000 PTR = PTR + 1 0289.000 ELSE IF (FN(I:I) .GE. 'a' .AND. FN(I:I) .LE. 'z') THEN 0290.000 FN(PTR:PTR) = CHAR(ICHAR(FN(I:I)) - X'20') 0291.000 PTR = PTR + 1 0292.000 ELSE IF(FN(I:I) .EQ. '.' .OR. FN(I:I) .EQ. '*' .OR. 0293.000 $ FN(I:I) .EQ. '_') THEN 0294.000 FN(PTR:PTR) = FN(I:I) 0295.000 PTR = PTR + 1 0296.000 ENDIF 0297.000 ENDDO 0298.000 IF (PTR .LE. LEN(FN)) FN(PTR:) = ' ' 0299.000 RETURN 0300.000 END 0301.000 SUBROUTINE RDPARAM(PDATA) 0302.000 IMPLICIT NONE 0303.000 INTEGER PDATA (1000) 0304.000 0305.000 C= Get the packet parameters from the other kermit 0306.000 C 0307.000 INCLUDE K.KERMD 0308.000 INCLUDE K.PACKC 0309.000 INTEGER PARAMS(17) 0310.000 EQUIVALENCE (PARAMS,SPKHDR) 0311.000 INTEGER I 0312.000 C 0313.000 INTEGER CTL 0314.000 INTEGER UNCHAR 0315.000 INTEGER TMP 0315.100 C 0316.000 C CYCLE THROUGH THE LIST OF PARAMETERS UNTIL THE END-OF-LIST 0317.000 C IS FOUND (A 0 BYTE). 0318.000 C Must be loop because variable length reply 0319.000 C 0320.000 I = 1 0321.000 DO WHILE (PDATA(I) .NE. 0 .AND. I .LE. 17) 0322.000 X WRITE(19,1000)I,PDATA(I) 0322.100 X1000 FORMAT(' 322.2** ',1I8,1X,1Z8) 0322.200 C 0323.000 C IS IT THE PAD CHARACTER? 0324.000 C 0325.000 IF (I .EQ. 4) THEN 0326.000 PARAMS(I) = CTL(PDATA(I)) 0327.000 IF (PARAMS(I) .EQ. 0) PARAMS(I) = NULL 0328.000 C 0329.000 C IS IT THE QUOTE CHARACTER? 0330.000 C 0331.000 ELSE IF (I .EQ. 6) THEN 0332.000 PARAMS(I) = PDATA(I) 0333.000 C 0334.000 C all else 0335.000 C 0336.000 ELSE 0337.000 TMP = UNCHAR(PDATA(I)) 0337.100 IF (TMP .NE. 0) THEN 0338.000 PARAMS(I) = TMP 0339.000 ENDIF 0340.000 ENDIF 0341.000 I = I + 1 0342.000 ENDDO 0343.000 X WRITE(19,1006)PARAMS(3) 0343.010 X1006 FORMAT(' PSIZE = ',1Z8) 0343.020 IF(PDATA(3).EQ.2Z20)THEN 0343.100 PARAMS(3) = PARAMS(12)*95 + PARAMS(13) - 1 0343.200 X WRITE(19,1005)PARAMS 0343.210 X1005 FORMAT(' 3432**',8(1X,1Z8)) 0343.220 ENDIF 0343.300 PARAMS(5) = 0 0343.400 RETURN 0344.000 END 0345.000 SUBROUTINE REMOVE(FN) 0346.000 IMPLICIT NONE 0347.000 INTEGER FN(1000) 0348.000 0349.000 C= Remove a file from the local file list. 0350.000 C 0351.000 CHARACTER*56 FNAME 0352.000 0353.000 CALL AS2DPC(FN,FNAME) 0354.000 OPEN(UNIT='TMP',FILE=FNAME) 0355.000 CLOSE(UNIT='TMP',STATUS='DELETE') 0356.000 RETURN 0357.000 END 0358.000 SUBROUTINE STRCPY(S1,S2) 0359.000 IMPLICIT NONE 0360.000 INTEGER S1(1000),S2(1000) 0361.000 0362.000 C= Copy one ascii string to another 0363.000 C 0364.000 INTEGER I1 0365.000 0366.000 I1 = 1 0367.000 10 S2(I1) = S1(I1) 0368.000 IF (S1(I1) .NE. 0) THEN 0369.000 I1 = I1 + 1 0370.000 GO TO 10 0371.000 ENDIF 0372.000 RETURN 0373.000 END 0374.000 INTEGER FUNCTION SLEN(STR) 0375.000 IMPLICIT NONE 0376.000 INTEGER STR(1000) 0377.000 0378.000 C= Return the length of a zero terminated ascii string buffer. 0379.000 C 0380.000 INTEGER I 0381.000 0382.000 I = 0 0383.000 10 IF (STR(I+1) .NE. 0) THEN 0384.000 I = I + 1 0385.000 GO TO 10 0386.000 ENDIF 0387.000 SLEN = I 0388.000 RETURN 0389.000 END 0390.000 INTEGER FUNCTION SNDPAR(PDATA) 0391.000 IMPLICIT NONE 0392.000 INTEGER PDATA(1000) 0393.000 0394.000 C= Setup parameters to send to other kermit. 0395.000 C 0396.000 INCLUDE K.KERMD 0397.000 INCLUDE K.PACKC 0398.000 C 0399.000 INTEGER I 0400.000 INTEGER PARAMS(17) 0401.000 EQUIVALENCE (PARAMS, PACKSIZ) 0402.000 C 0403.000 INTEGER CTL 0404.000 INTEGER TOCHAR 0405.000 C 0406.000 C SEND WHAT WE WANT 0407.000 C 0408.000 IF(PACKSIZ.GT.95)THEN 0408.100 PDATA (1) = 2Z20 0408.200 ELSE 0408.300 PDATA (1) = TOCHAR(PACKSIZ) 0409.000 ENDIF 0409.100 PDATA (2) = TOCHAR(TIMEOUT) 0410.000 PDATA (3) = TOCHAR(NPAD) 0411.000 PDATA (4) = CTL(PADCH) 0412.000 PDATA (5) = TOCHAR(EOLCH) 0413.000 PDATA (6) = QUOTECH 0414.000 PDATA (7) = 2Z26 0415.000 PDATA(8) = 2Z31 0415.100 PDATA (9) = 2Z7E 0415.200 PDATA (10)= 2Z2E 0415.300 PDATA (11) = 2Z21 0415.301 PDATA (12) = MAXPACK/95 0415.310 PDATA (13) = MAXPACK - PDATA(12)*95 + 2Z20 0415.320 PDATA (12) = PDATA(12) + 2Z20 0415.330 C 0416.000 C RETURN LENGTH OF HOW MANY THINGS WE WANT TO SET 0417.000 C 0418.000 SNDPAR = 13 0419.000 RETURN 0420.000 END 0421.000 SUBROUTINE SLEEP(SECONDS) 0422.000 IMPLICIT NONE 0423.000 INTEGER SECONDS 0424.000 CC 0425.000 C SLEEP - HOLD FOR SECONDS. 0426.000 C 0427.000 INTEGER I 0428.000 0429.000 DO 100 I=1,SECONDS 0430.000 CALL DELAY( 500) 0431.000 100 CONTINUE 0432.000 RETURN 0433.000 END 0434.000 SUBROUTINE DELAY(MSEC) 0435.000 IMPLICIT NONE 0436.000 INTEGER MSEC 0437.000 C 0438.000 C= DELAY - HOLD THINGS UP FOR MILISECS. 0439.000 C 0440.000 C **** THIS IS PROBABLY SYSTEM DEPENDENT CODE ***** 0441.000 C IF YOU MODIFY IT USE CONDITIONAL COMPILATION 0442.000 C 0443.000 INTEGER IOS 0444.000 C 0445.000 CALL WAIT(MSEC, 1, IOS) 0446.000 RETURN 0447.000 END 0448.000 INTEGER FUNCTION CTL (ASCCH) 0449.000 IMPLICIT NONE 0450.000 INTEGER ASCCH 0451.000 C 0452.000 C= Flip control bit protecting control chars and unprotecting 0453.000 C 0454.000 CTL = IEOR(ASCCH,X'40') 0455.000 RETURN 0456.000 END 0457.000 INTEGER FUNCTION TOCHAR(ASCCH) 0458.000 IMPLICIT NONE 0459.000 INTEGER ASCCH 0460.000 C 0461.000 C= Make an ascii character. 0462.000 C 0463.000 INCLUDE K.KERMD 0464.000 C 0465.000 TOCHAR = ASCCH + BLANK 0466.000 RETURN 0467.000 END 0468.000 INTEGER FUNCTION UNCHAR(ASCCH) 0469.000 IMPLICIT NONE 0470.000 INTEGER ASCCH 0471.000 C 0472.000 C= Convert back to control character 0473.000 C 0474.000 INCLUDE K.KERMD 0475.000 C 0476.000 UNCHAR = ASCCH - BLANK 0477.000 RETURN 0478.000 END 0479.000 SUBROUTINE GETMACH(MACH) 0480.000 IMPLICIT NONE 0481.000 CHARACTER*(*) MACH !current machine type 0482.000 C 0483.000 C= Retrieves current machine type from os 0484.000 C 0485.000 CHARACTER*2 MACHS(0:5) !gould machines 0486.000 $ /'55','77','27','67','87','97'/ 0487.000 INTEGER IMACH !read machine type 0488.000 C 0489.000 INLINE 0490.000 LB 7,X'0CB7' !get machine type code 0491.000 STW 7,IMACH !store for use 0492.000 ENDI 0493.000 IF (IMACH .GE. 0 .AND. IMACH .LE. 5) THEN 0494.000 MACH = MACHS(IMACH) 0495.000 ELSE 0496.000 MACH = '**' 0497.000 ENDIF 0498.000 RETURN 0499.000 END 0500.000 SUBROUTINE PRTMSG(STR, VAL) 0501.000 IMPLICIT NONE 0502.000 CHARACTER*(*) STR 0503.000 INTEGER VAL 0504.000 C 0505.000 C= Prints a message to output device (normally abort message) 0506.000 C 0507.000 1000 FORMAT (X,A,I4) 0508.000 WRITE ('UT',1000,ERR=10) STR, VAL 0509.000 10 CONTINUE 0510.000 RETURN 0511.000 END 0512.000 SUBROUTINE DISPLAY (S) 0513.000 IMPLICIT NONE 0514.000 CHARACTER*(*) S 0515.000 C 0516.000 C= Display string on console 0517.000 C 0518.000 INTEGER WORD 0519.000 CHARACTER*80 STRING 0520.000 EQUIVALENCE (WORD, STRING) !word bound string 0521.000 C 0522.000 STRING = S 0523.000 CALL CARRIAGE 0524.000 CALL M:TELEW(STRING) 0525.000 RETURN 0526.000 END 0527.000 INTEGER FUNCTION NOFIND (STRING,CHARN) 0528.000 IMPLICIT NONE 0529.000 C= Return position of 1st character in STRING that does not match CHARN.0530.000 C 0531.000 C RETURN THE INDEX OF THE FIRST 0532.000 C CHARACTER IN STRING THAT DOES 0533.000 C NOT MATCH CHARN. 0534.000 C RETURNS 0 IF THE STRINGS MATCH. 0535.000 C 0536.000 C FORMAL PARAMETER DECLARATIONS. 0537.000 CHARACTER*(*) STRING,CHARN 0538.000 C 0539.000 C LOCAL DECLARATIONS. 0540.000 C 0541.000 C LENGTH OF STRING PARAMETER. 0542.000 INTEGER STRLEN 0543.000 C STRING SEARCH POINTER. 0544.000 INTEGER I 0545.000 C LENGTH OF STRING FUNCTION 0546.000 INTRINSIC LEN 0547.000 0548.000 C 0549.000 C------------------------------------------------------------------- 0550.000 C 0551.000 C FIND LENGTH OF INPUT STRING. 0552.000 STRLEN = LEN(STRING) 0553.000 C PRESET FUNCTION VALUE TO INDICATE 0554.000 C SEARCH FAILED TO FIND NON-CHARN 0555.000 C CHARACTER. 0556.000 NOFIND = 0 0557.000 C INITIALIZE STRING SEARCH POINTER. 0558.000 I=0 0559.000 10 CONTINUE 0560.000 C POINT TO NEXT CHARACTER IN STRING 0561.000 I = I + 1 0562.000 C BEYOND END OF STRING - SEARCH FAILED. 0563.000 IF( I .GT. STRLEN ) GO TO 20 0564.000 C DO IT AGAIN IF THIS CHARACTER MATCHES. 0565.000 IF( STRING(I:I) .EQ. CHARN ) GO TO 10 0566.000 C MISMATCH ENCOUNTERED - NOTE 0567.000 C POSITION AND RETURN. 0568.000 NOFIND = I 0569.000 C 0570.000 20 CONTINUE 0571.000 C 0572.000 RETURN 0573.000 END 0574.000 INTEGER FUNCTION LASTCHR (STRING) 0575.000 IMPLICIT NONE 0576.000 C= Return position of last non-blank character in STRING. 0577.000 C 0578.000 C FIND THE LAST NON-BLANK CHARACTER 0579.000 C IN THE INPUT STRING. 0580.000 C 0581.000 C 0582.000 CHARACTER*(*) STRING ! GIVEN STRING 0583.000 C 0584.000 C RETURNS LASTCHR ! POSITION OF LAST NON-BLANK CHARACTER 0585.000 C IN STRING 0586.000 C 0587.000 INTEGER CHR 0588.000 C 0589.000 INTEGER LEN 0590.000 INTRINSIC LEN 0591.000 C 0592.000 INTEGER ZERO,ONE 0593.000 PARAMETER (ZERO=0,ONE=1) 0594.000 C CHARACTER*1 BLANK 0595.000 C PARAMETER (BLANK=' ') 0596.000 C 0597.000 C REVISED 12/08/82, PDM. CORRECT TREATMENT OF EMPTY LINE. 0598.000 C 0599.000 C------------------------------------------------------------------ 0600.000 C 0601.000 C 0602.000 CHR = LEN(STRING) + ONE 0603.000 10 CONTINUE 0604.000 CHR = CHR - ONE 0605.000 IF (CHR.LE.ZERO) GOTO 20 0606.000 IF (STRING(CHR:CHR).EQ.' ') GOTO 10 0607.000 20 CONTINUE 0608.000 C 0609.000 LASTCHR = CHR 0610.000 C 0611.000 C 0612.000 RETURN 0613.000 END 0614.000 SUBROUTINE LADJ(STRING) 0615.000 IMPLICIT NONE 0616.000 C= Left-justify a string. 0617.000 C Left-justify a string. 0618.000 C------------------------------------------------------------------- 0619.000 C Written May 6, 1983 by Fred Preller, Simulation Associates, Inc. 0620.000 C------------------------------------------------------------------- 0621.000 CHARACTER*(*) STRING 0622.000 C------------------------------------------------------------------- 0623.000 INTEGER FIRST ! First non-blank character position 0624.000 CHARACTER*1 BLANK/' '/ 0625.000 C------------------------------------------------------------------- 0626.000 INTEGER NOFIND 0627.000 EXTERNAL NOFIND 0628.000 C------------------------------------------------------------------- 0629.000 FIRST = NOFIND(STRING,BLANK) 0630.000 C Note the criteria: FIRST = 0 => totally blank line, and 0631.000 C FIRST = 1 => line already justified. 0632.000 IF( FIRST .GT. 1 ) STRING = STRING(FIRST:) 0633.000 RETURN 0634.000 END 0635.000 SUBROUTINE BREAKR 0636.000 IMPLICIT NONE 0637.000 C= Establish break receiver 0638.000 C 0639.000 C BREAKR ESTABLISHES A BREAK RECEIVER THAT REMAINS ACTIVE AS 0640.000 C LONG AS THE TASK IS ACTIVE. WHEN A BREAK IS RECEIVED, THE 0641.000 C BREAK FLAG IS SET. THE USER MUST CLEAR THE FLAG TO ENSURE 0642.000 C THAT SUBSEQUENT BREAKS ARE DETECTED. 0643.000 C 0644.000 LOGICAL BREAK 0645.000 INTEGER ERRSTAT 0646.000 COMMON /BREAK/ BREAK 0647.000 C 0648.000 C CALL M_PRIV 0649.000 CALL X:BRK ($100,ERRSTAT,$50) 0650.000 BREAK = .FALSE. 0651.000 50 CONTINUE 0652.000 C CALL M_UPRIV 0653.000 RETURN 0654.000 C 0655.000 C BREAK ENTRY POINT 0656.000 100 BREAK = .TRUE. 0657.000 CALL X:BRKXIT 0658.000 C 0659.000 END 0660.000 SUBROUTINE SLINE(S) 0661.000 CHARACTER*(*) S !tsm line 0662.000 C 0663.000 C= Returns the tsm command line without the execution portion 0664.000 C 0665.000 CHARACTER*236 BUFF !local buffer 0666.000 INTEGER NRESV !number of reserved words 0667.000 PARAMETER (NRESV = 5) 0668.000 CHARACTER*8 RWORDS(NRESV) !reserved pre words 0669.000 $ /'RUN', 'EXECUTE ', 'EXEC', 'DEBU', 'DEBUG'/ 0670.000 CHARACTER*8 R !reserved word 0671.000 INTEGER OUT/'OUT'/ 0672.000 CHARACTER*1 D !delimitor 0673.000 C 0674.000 C SLINE 0675.000 C 0676.000 CALL TLINE(BUFF) !get tsm command line 0677.000 CALL LADJ(BUFF) 0678.000 C 0679.000 C remove leading '$' 0680.000 C 0681.000 IF (BUFF(1:1) .EQ. '$') THEN 0682.000 BUFF = BUFF(2:) 0683.000 END IF 0684.000 CALL EXTR(R, D, BUFF) !possible task name/reserved 0685.000 C 0686.000 C get rid of leading reserved words 0687.000 C 0688.000 DO 20,I=1, NRESV 0689.000 IF (R .EQ. RWORDS(I)) THEN 0690.000 CALL EXTR(R, D, BUFF) !get task path 0691.000 LEAVE 20 0692.000 END IF 0693.000 20 END DO 0694.000 C 0695.000 C check for dsc name 0696.000 C 0697.000 IF (R(1:1) .EQ. '@' .OR. R(1:1) .EQ. '^' .OR. D .EQ. '(') THEN 0698.000 CALL EXTR(R, D, BUFF) !extract directory 0699.000 CALL EXTR(R, D, BUFF) !task name 0700.000 END IF 0701.000 C 0702.000 C return remander without task name 0703.000 C 0704.000 S = BUFF 0705.000 RETURN 0706.000 END 0707.000 SUBROUTINE EXTR(R, D, S) 0708.000 CHARACTER*(*) R !extracted word 0709.000 CHARACTER*1 D !delimitor 0710.000 CHARACTER*(*) S !word to extract from 0711.000 C 0712.000 C= Extracts the next word based on TSM's delimitors 0713.000 C 0714.000 CHARACTER*9 DELIM /' ,()=;$!%'/ !delimitors 0715.000 CHARACTER*2 QUOTES /'''""'/ !quotes 0716.000 INTEGER NS !length of S 0717.000 INTEGER I 0718.000 LOGICAL QUOTE !in quote 0719.000 CHARACTER*1 QUOTECH !character used in quote 0720.000 C 0721.000 C functions 0722.000 C 0723.000 INTEGER NOFIND !look until not found 0724.000 C 0725.000 C extr 0726.000 C 0727.000 QUOTE = .FALSE. 0728.000 NS = LEN(S) 0729.000 I = 1 0730.000 DO 20, WHILE (I .LE. NS) 0731.000 IF (QUOTE) THEN 0732.000 IF (S(I:I) .EQ. QUOTECH) THEN 0733.000 QUOTE = .FALSE. 0734.000 ENDIF 0735.000 ELSE 0736.000 IF (INDEX(QUOTES, S(I:I)) .GT. 0) THEN 0737.000 QUOTECH = S(I:I) 0738.000 QUOTE = .TRUE. 0739.000 ELSE IF (INDEX(DELIM, S(I:I)) .GT. 0) THEN 0740.000 LEAVE 20 0741.000 ENDIF 0742.000 END IF 0743.000 I = I + 1 0744.000 20 END DO 0745.000 C 0746.000 C returned field 0747.000 C 0748.000 IF (I .GT. NS) THEN 0749.000 R = S 0750.000 ELSE IF (I .EQ. 1) THEN 0751.000 R = ' ' 0752.000 ELSE 0753.000 R = S(:I-1) 0754.000 END IF 0755.000 C 0756.000 C delimitor 0757.000 C 0758.000 IF (I .GT. NS) THEN 0759.000 D = ' ' 0760.000 ELSE 0761.000 D = S(I:I) 0762.000 END IF 0763.000 C 0764.000 C new buffer 0765.000 C 0766.000 IF (I .GT. NS) THEN 0767.000 S = ' ' 0768.000 ELSE IF (I .EQ. NS) THEN 0769.000 S = ' ' 0770.000 ELSE 0771.000 S = S(I+1:) 0772.000 END IF 0773.000 C 0774.000 C remove trailing blanks 0775.000 C 0776.000 I = NOFIND(S, ' ') 0777.000 IF (I .GT. 0) S = S(I:) 0778.000 RETURN 0779.000 END 0780.000 LOGICAL FUNCTION ISFILE(FILNAME) 0781.000 IMPLICIT NONE 0782.000 INTEGER*8 FILNAME !FILE TO CHECK 0783.000 C 0784.000 C= Tests to determine if file specified in path exists 0785.000 C The M:LOG routine needs the FILENAME to be declared 0786.000 C as an INTEGER DOUBLE WORD. 0787.000 C 0788.000 INTEGER*4 RDBUFFER(8) !RESOURCE DESCR. BUFFER 0789.000 INTEGER*4 ERRSTAT !ERROR STATUS 0790.000 INTEGER*4 TYPE !FILE TYPE 0791.000 LOGICAL ISFILE 0791.100 C 0792.000 C 0793.000 C CALL X_RID(PATHNAME,RDBUFFER,ERRSTAT) 0794.000 ERRSTAT = -1 !INITIALIZE ERROR STATUS 0795.000 TYPE = 8Z4E202020 !N ' 0795.100 ISFILE = .TRUE. 0795.200 CALL M:LOG(TYPE,RDBUFFER,FILNAME,ERRSTAT) ! X_RID DOES NOT EXIS 0796.000 ISFILE = ERRSTAT .NE. 0 0797.000 RETURN 0798.000 END 0799.000 INTEGER FUNCTION XTOI(S) 0800.000 IMPLICIT NONE 0801.000 CHARACTER*(*) S !hex number in ascii 0802.000 C return integer value 0803.000 C 0804.000 C= Converts an ascii hex string to integer number 0805.000 C 0806.000 INTEGER N !length of string 0807.000 INTEGER I !string pointer 0808.000 INTEGER C !ascii value 0809.000 INTEGER ZERO/X'30'/ !ascii zero 0810.000 INTEGER NINE/X'39'/ 0811.000 INTEGER A /X'41'/ 0812.000 INTEGER F /X'46'/ 0813.000 C 0814.000 C functions 0815.000 C 0816.000 INTRINSIC ICHAR ,LEN 0817.100 C INTEGER ICHAR !char to integer value 0817.200 INTEGER LEN !length of string 0818.000 C 0819.000 C xtoi 0820.000 C 0821.000 N = LEN(S) 0822.000 I = 1 0823.000 XTOI = 0 0824.000 DO WHILE (I .LT. N .AND. S(I:I) .EQ. ' ') 0825.000 I = I + 1 0826.000 END DO 0827.000 DO 20 WHILE (I .LE. N) 0828.000 C = ICHAR(S(I:I)) 0829.000 IF (C .GE. ZERO .AND. C .LE. NINE) THEN 0830.000 C = C - ZERO 0831.000 ELSE IF (C .GE. A .AND. C .LE. F) THEN 0832.000 C = C - A + 10 0833.000 ELSE 0834.000 LEAVE 20 0835.000 END IF 0836.000 INLINE 0837.000 LW 6,XTOI !get previous value 0838.000 LW 7,C !get current value to add 0839.000 SLL 7,28 !left justify 0840.000 SLLD 6,4 !move into xtoi 0841.000 STW 6,XTOI !done 0842.000 ENDI 0843.000 I = I + 1 0844.000 20 END DO 0845.000 RETURN 0846.000 END 0847.000 CHARACTER*(*) FUNCTION ITOX (X) 0848.000 IMPLICIT NONE 0849.000 INTEGER X !hex value 0850.000 C 0851.000 C= Convert integer to hex ascii string 0852.000 C forces a leading numeric character 0853.000 C 0854.000 CHARACTER*9 T !temporary string 0855.000 INTEGER I !sting pointer 0856.000 INTEGER J !local value to convert 0857.000 INTEGER C !convertion value 0858.000 INTEGER A/X'41'/ 0859.000 INTEGER F/X'46'/ 0860.000 INTEGER ZERO/X'30'/ 0861.000 INTEGER NINE/X'39'/ 0862.000 C 0863.000 C functions 0864.000 C 0865.000 CHARACTER*1 CHAR !integer to character function 0866.000 C 0867.000 C ITOX 0868.000 C 0869.000 J = X 0870.000 T = ' ' 0871.000 I = 9 0872.000 DO UNTIL (J .EQ. 0) 0873.000 INLINE 0874.000 LW 6,J !get current value 0875.000 SRLD 6,4 !get first hex value 0876.000 SRL 7,28 !right justify 0877.000 STW 7,C !convert 0878.000 STW 6,J !new value 0879.000 ENDI 0880.000 IF (C .GE. 10) THEN 0881.000 C = C - 10 + A 0882.000 ELSE 0883.000 C = C + ZERO 0884.000 END IF 0885.000 T(I:I) = CHAR(C) 0886.000 I = I - 1 0887.000 END DO 0888.000 IF (T(I+1:I+1) .GT. 'A') THEN 0889.000 T(I:I) = CHAR(ZERO) 0890.000 END IF 0891.000 CALL LADJ(T) 0892.000 ITOX = T 0893.000 RETURN 0894.000 END 0895.000 CHARACTER*(*) FUNCTION ITOA (I) 0896.000 IMPLICIT NONE 0897.000 INTEGER I !integer to output 0898.000 C 0899.000 C= Converts an integer number to an ascii string 0900.000 C 0901.000 CHARACTER*20 BUF !local buffer 0902.000 INTEGER J !local integer value 0903.000 C 0904.000 C format 0905.000 C 0906.000 1000 FORMAT (I20) 0907.000 C 0908.000 C itoa 0909.000 C 0910.000 J = I 0911.000 WRITE (BUF, 1000, ERR=10) J 0912.000 CALL LADJ(BUF) 0913.000 ITOA = BUF 0914.000 RETURN 0915.000 10 CONTINUE 0916.000 ITOA = '0' 0917.000 RETURN 0918.000 END 0919.000 SUBROUTINE GETEMSG(STRNG) 0920.000 IMPLICIT NONE 0921.000 INTEGER STRNG(1000) 0922.000 C 0923.000 C= Produce an error message string for the current error 0924.000 CLT 2.3 THIS ROUTINE TRW'D TO PRODUCE CORRECT ERROR MESSAGES 0925.000 C 0926.000 INCLUDE K.KERMD 0927.000 INCLUDE K.PROTC 0928.000 C 0929.000 INTEGER I 0930.000 C 0931.000 I = 1 0932.000 IF (ABORTYP(SENDING)) THEN 0933.000 CALL DPC2AS('SENDING',STRNG(I), 7) 0934.000 I = I + 7 0935.000 ELSE 0936.000 CALL DPC2AS('RECEIVING',STRNG(I),9) 0937.000 I = I + 9 0938.000 ENDIF 0939.000 IF (ABORTYP(INITERR)) THEN 0940.000 CALL DPC2AS(' INIT',STRNG(I),5) 0941.000 I = I + 5 0942.000 ELSE IF (ABORTYP(FILERR)) THEN 0943.000 CALL DPC2AS(' FILE NAME',STRNG(I),10) 0944.000 I = I + 10 0945.000 ELSE IF (ABORTYP(DATAERR)) THEN 0946.000 CALL DPC2AS(' DATA',STRNG(I),5) 0947.000 I = I + 5 0948.000 ELSE IF (ABORTYP(EOFERR)) THEN 0949.000 CALL DPC2AS(' EOF',STRNG(I),4) 0950.000 I = I + 4 0951.000 ELSE 0952.000 CALL DPC2AS(' BREAK',STRNG(I),6) 0953.000 I = I + 6 0954.000 ENDIF 0955.000 CALL DPC2AS(' PACKET,',STRNG(I),7) 0956.000 I = I + 7 0957.000 IF (ABORTYP(TOOMANY)) THEN 0958.000 CALL DPC2AS(' TOO MANY RETRIES',STRNG(I),17) 0959.000 I = I + 17 0960.000 ELSE IF (ABORTYP(INVALID)) THEN 0961.000 CALL DPC2AS(' RECV. INVALID PACKET',STRNG(I),20) 0962.000 I = I + 20 0963.000 ELSE IF (ABORTYP(SEQERR)) THEN 0964.000 CALL DPC2AS(' RECV. OUT OF SEQ. PACKET',STRNG(I),25) 0965.000 I = I + 25 0966.000 ELSE IF (ABORTYP(LCLFILE)) THEN 0967.000 CALL DPC2AS(' FAILED TO OPEN FILE',STRNG(I), 21) 0968.000 I = I + 21 0969.000 ELSE 0970.000 CALL DPC2AS(' UNANTICIPATED ERROR',STRNG(I),20) 0971.000 I = I + 20 0972.000 ENDIF 0973.000 STRNG(I) = 0 0974.000 I = I+1 0975.000 RETURN 0976.000 END 0977.000