home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
archives
/
gould3.tar.gz
/
gould3.tar
/
kermit4
< prev
next >
Wrap
Text File
|
2011-08-09
|
83KB
|
1,022 lines
* 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> 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 <MSEC> 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
