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 >
Text File  |  2011-08-09  |  83KB  |  1,022 lines

  1. *     BASE -ULTLY-KERM -SFM-A2703 - 08/01/90  WJH     HEADER  SFMKERM   0001.000
  2.       SUBROUTINE AS2DPC(ASTR,DSTR)                                      0001.100
  3.            IMPLICIT NONE                                                0002.000
  4.            INTEGER   ASTR(1000)                                         0003.000
  5.            CHARACTER*(*)   DSTR                                         0004.000
  6.                                                                         0005.000
  7. C= Translate ascii integer string to character string                   0006.000
  8. C                                                                       0007.000
  9. C     ASCII STRING IS TERMINATED BY A ZERO BYTE.                        0008.000
  10. C                                                                       0009.000
  11. C                                                                       0010.000
  12.       INTEGER            CLEN                                           0011.000
  13.       INTEGER      I                                                    0012.000
  14. C                                                                       0013.000
  15.       INTRINSIC CHAR,LEN                                                0013.100
  16. C     CHARACTER*1  CHAR                                                 0014.000
  17.       INTEGER      LEN                                                  0015.000
  18. C                                                                       0016.000
  19.       I = 1                                                             0017.000
  20.       CLEN = LEN(DSTR)                                                  0018.000
  21.       DSTR = ' '                                                        0019.000
  22. 10    IF (ASTR(I) .NE. 0 .AND. I .LE. CLEN) THEN                        0020.000
  23.          DSTR(I:I) = CHAR(ASTR(I))                                      0021.000
  24.          I = I + 1                                                      0022.000
  25.          GO TO 10                                                       0023.000
  26.       ENDIF                                                             0024.000
  27. C                                                                       0025.000
  28.       RETURN                                                            0026.000
  29.       END                                                               0027.000
  30.       SUBROUTINE DPC2AS(DSTR,ASTR,N)                                    0028.000
  31.            IMPLICIT NONE                                                0029.000
  32.            CHARACTER*(*) DSTR                                           0030.000
  33.            INTEGER       ASTR(1000)                                     0031.000
  34.            INTEGER       N                                              0032.000
  35. C                                                                       0033.000
  36. C= TRANSLATE STRING OF DISPLAY CODE CHARACTERS ASCII INTEGER STRING.    0034.000
  37. C  STRING IS N CHARACTERS (WORDS) LONG.                                 0035.000
  38. C                                                                       0036.000
  39. C                                                                       0037.000
  40.       INTEGER      I                                                    0038.000
  41. C                                                                       0039.000
  42.       INTRINSIC    ICHAR                                                0040.100
  43. C     INTEGER      ICHAR                                                0040.200
  44. C                                                                       0041.000
  45.       DO I=1,N                                                          0042.000
  46.          ASTR(I) = ICHAR(DSTR(I:I))                                     0043.000
  47.       ENDDO                                                             0044.000
  48. C                                                                       0045.000
  49. C     SET ASCII END-OF-STRING-BUFFER                                    0046.000
  50. C                                                                       0047.000
  51.       ASTR(N+1) = 0                                                     0048.000
  52. C                                                                       0049.000
  53.       RETURN                                                            0050.000
  54.       END                                                               0051.000
  55.       INTEGER FUNCTION CTOI(ASTR)                                       0052.000
  56.           IMPLICIT NONE                                                 0053.000
  57.           INTEGER      ASTR(1000)                                       0054.000
  58.                                                                         0055.000
  59. C= CONVERT CHARACTER BUFFER TO INTEGER.                                 0056.000
  60. C                                                                       0057.000
  61. C     CTOI CONVERTS THE NUMBER USING BASE 10 AS A DEFAULT.              0058.000
  62. C     A SUFFIX OF H WILL CONVERT USING BASE 16 AND A SUFFIX             0059.000
  63. C     OF O WILL CONVERT USING BASE 8.  DEFAULT SUFFIX IS                0060.000
  64. C     D.                                                                0061.000
  65. C                                                                       0062.000
  66.       INCLUDE K.KERMD                                                   0063.000
  67.       INTEGER      DIG0, DIG7, DIG9, BIGA, BIGB, BIGD                   0064.000
  68.       INTEGER      BIGF, BIGH, BIGO, LETA, LETB, LETD                   0065.000
  69.       INTEGER      LETF, LETH, LETO                                     0066.000
  70.       PARAMETER (DIG0=48, DIG7=55, DIG9=57, BIGA=65, BIGB=66, BIGD=68)  0067.000
  71.       PARAMETER (BIGF=70, BIGH=72, BIGO=79, LETA=97, LETB=98, LETD=100) 0068.000
  72.       PARAMETER (LETF=102, LETH=104, LETO=111)                          0069.000
  73.       INTEGER      BASE                                                 0070.000
  74.       INTEGER      PTR                                                  0071.000
  75.       INTEGER      EOD                                                  0072.000
  76.       INTEGER      CH                                                   0073.000
  77.       INTEGER      TOTAL                                                0074.000
  78.       INTEGER      ISNEG                                                0075.000
  79.       INTEGER      I                                                    0076.000
  80.                                                                         0077.000
  81.       BASE = 0                                                          0078.000
  82.       PTR = 0                                                           0079.000
  83. C                                                                       0080.000
  84. C     FIND LAST VALID DIGIT                                             0081.000
  85. C                                                                       0082.000
  86. 10    PTR = PTR + 1                                                     0083.000
  87.       IF (ASTR(PTR) .NE. 0) GO TO 10                                    0084.000
  88.       PTR = PTR - 1                                                     0085.000
  89.       IF (ASTR(PTR) .EQ. LETO .OR. ASTR(PTR) .EQ. BIGO .OR.             0086.000
  90.      +    ASTR(PTR) .EQ. LETB .OR. ASTR(PTR) .EQ. BIGB .OR.             0087.000
  91.      +    ASTR(PTR) .EQ. LETH .OR. ASTR(PTR) .EQ. BIGH) THEN            0088.000
  92.          EOD = PTR - 1                                                  0089.000
  93.       ELSE                                                              0090.000
  94.          EOD = PTR                                                      0091.000
  95.          PTR = PTR + 1                                                  0092.000
  96.       ENDIF                                                             0093.000
  97. C                                                                       0094.000
  98. C     TRY TO FIGURE OUT THE BASE                                        0095.000
  99. C                                                                       0096.000
  100.       IF (ASTR(PTR) .EQ. 0) THEN                                        0097.000
  101.          BASE = 10                                                      0098.000
  102.       ELSE IF (ASTR(PTR) .EQ. LETO .OR. ASTR(PTR) .EQ. BIGO .OR.        0099.000
  103.      +         ASTR(PTR) .EQ. LETB .OR. ASTR(PTR) .EQ. BIGB) THEN       0100.000
  104.          BASE = 8                                                       0101.000
  105.       ELSE IF (ASTR(PTR) .EQ. LETH .OR. ASTR(PTR) .EQ. BIGH) THEN       0102.000
  106.          BASE = 16                                                      0103.000
  107.       ENDIF                                                             0104.000
  108. C                                                                       0105.000
  109. C     IF DIDN'T FIND A BASE                                             0106.000
  110. C                                                                       0107.000
  111.       IF (BASE .EQ. 0) THEN                                             0108.000
  112.          CALL PRINTL(STDOUT,'CTOI - Invalid base ')                     0109.000
  113.          CALL PUTC(STDOUT, ASTR(PTR))                                   0110.000
  114.          CALL FLUSH(STDOUT)                                             0111.000
  115.          CTOI = 0                                                       0112.000
  116.          RETURN                                                         0113.000
  117.       ENDIF                                                             0114.000
  118. C                                                                       0115.000
  119. C     ADD UP THE DIGITS                                                 0116.000
  120. C                                                                       0117.000
  121.       TOTAL = 0                                                         0118.000
  122.       ISNEG = 1                                                         0119.000
  123.       DO 100 I = 1,EOD                                                  0120.000
  124.          CH = ASTR(I)                                                   0121.000
  125.          IF (CH .EQ. MINUS) THEN                                        0122.000
  126.             ISNEG = -1                                                  0123.000
  127.             GO TO 100                                                   0124.000
  128.          ENDIF                                                          0125.000
  129.          IF (BASE .EQ. 10) THEN                                         0126.000
  130.             IF (CH .LT. DIG0 .OR. CH .GT. DIG9) THEN                    0127.000
  131.                CALL PRINTL(STDOUT,'CTOI - Invalid decimal digit ')      0128.000
  132.                CALL PUTC(STDOUT, CH)                                    0129.000
  133.                CALL FLUSH(STDOUT)                                       0130.000
  134.                CTOI = 0                                                 0131.000
  135.                RETURN                                                   0132.000
  136.             ELSE                                                        0133.000
  137.                CH = CH - DIG0                                           0134.000
  138.             ENDIF                                                       0135.000
  139.          ELSE IF (BASE .EQ. 8) THEN                                     0136.000
  140.             IF (CH .LT. DIG0 .OR. CH .GT. DIG7) THEN                    0137.000
  141.                CALL PRINTL(STDOUT,'CTOI - Invalid octal digit ')        0138.000
  142.                CALL PUTC(STDOUT, CH)                                    0139.000
  143.                CALL FLUSH(STDOUT)                                       0140.000
  144.                CTOI = 0                                                 0141.000
  145.                RETURN                                                   0142.000
  146.             ELSE                                                        0143.000
  147.                CH = CH - DIG0                                           0144.000
  148.             ENDIF                                                       0145.000
  149.          ELSE IF (BASE .EQ. 16) THEN                                    0146.000
  150.             IF (CH .GE. DIG0 .AND. CH .LE. DIG9) THEN                   0147.000
  151.                CH = CH - DIG0                                           0148.000
  152.             ELSE IF (CH .GE. LETA .AND. CH .LE. LETF) THEN              0149.000
  153.                CH = 10 + CH - LETA                                      0150.000
  154.             ELSE IF (CH .GE. BIGA .AND. CH .LE. BIGF) THEN              0151.000
  155.                CH = 10 + CH - BIGA                                      0152.000
  156.             ELSE                                                        0153.000
  157.                CALL PRINTL(STDOUT,'CTOI - Invalid hex digit ')          0154.000
  158.                CALL PUTC(STDOUT, CH)                                    0155.000
  159.                CALL FLUSH(STDOUT)                                       0156.000
  160.                CTOI = 0                                                 0157.000
  161.                RETURN                                                   0158.000
  162.             ENDIF                                                       0159.000
  163.          ENDIF                                                          0160.000
  164.          TOTAL = TOTAL*BASE + CH                                        0161.000
  165. 100   CONTINUE                                                          0162.000
  166.       CTOI = TOTAL * ISNEG                                              0163.000
  167.       RETURN                                                            0164.000
  168.       END                                                               0165.000
  169.       INTEGER FUNCTION ITOS(INT,STR,MINWID)                             0166.000
  170.            IMPLICIT NONE                                                0167.000
  171.            INTEGER INT                                                  0168.000
  172.            INTEGER STR(1000)                                            0169.000
  173.            INTEGER MINWID                                               0170.000
  174.                                                                         0171.000
  175. CCC   ITOS - CONVERT AN INTEGER TO STRING FORMAT.                       0172.000
  176. C                                                                       0173.000
  177.       INCLUDE K.KERMD                                                   0174.000
  178.       INTEGER      WIDTH                                                0175.000
  179.       INTEGER      VAL                                                  0176.000
  180.       INTEGER      ASCII0                                               0177.000
  181.       INTEGER      TCH                                                  0178.000
  182.       INTEGER      IPTR                                                 0179.000
  183.       INTEGER      ENDPTR                                               0180.000
  184. C                                                                       0181.000
  185.       INTEGER      MOD                                                  0182.000
  186.       INTRINSIC    ICHAR                                                0183.100
  187. C     INTEGER      ICHAR                                                0183.200
  188.                                                                         0184.000
  189.       WIDTH = 0                                                         0185.000
  190.       IF (INT .LT. 0) THEN                                              0186.000
  191.          WIDTH = 1                                                      0187.000
  192.          STR(WIDTH) = ICHAR('-')                                        0188.000
  193.       ENDIF                                                             0189.000
  194.       VAL = IABS(INT)                                                   0190.000
  195.       ASCII0 = ICHAR('0')                                               0191.000
  196. 10    WIDTH = WIDTH + 1                                                 0192.000
  197.       STR(WIDTH) = MOD(VAL,10) + ASCII0                                 0193.000
  198.       VAL = VAL / 10                                                    0194.000
  199.       IF (VAL .NE. 0) GO TO 10                                          0195.000
  200.       STR(WIDTH+1) = 0                                                  0196.000
  201. C                                                                       0197.000
  202. C     NOW REVERSE THE DIGITS                                            0198.000
  203. C                                                                       0199.000
  204.       IPTR = 1                                                          0200.000
  205.       ENDPTR = WIDTH                                                    0201.000
  206.       IF (STR(IPTR) .EQ. ICHAR('-')) IPTR = IPTR + 1                    0202.000
  207. 20    IF (IPTR .LT. ENDPTR) THEN                                        0203.000
  208.          TCH = STR(IPTR)                                                0204.000
  209.          STR(IPTR) = STR(ENDPTR)                                        0205.000
  210.          STR(ENDPTR) = TCH                                              0206.000
  211.          IPTR = IPTR + 1                                                0207.000
  212.          ENDPTR = ENDPTR - 1                                            0208.000
  213.          GO TO 20                                                       0209.000
  214.       ENDIF                                                             0210.000
  215.       ITOS = WIDTH                                                      0211.000
  216.       RETURN                                                            0212.000
  217.       END                                                               0213.000
  218.       INTEGER FUNCTION GETFILE(FN)                                      0214.000
  219.            IMPLICIT NONE                                                0215.000
  220.            INTEGER       FN(2)     !file name                           0216.000
  221.            INTEGER       ERRSTAT                                        0216.100
  222.            INTEGER*8     KERMIT /'KERMIT  '/                            0216.200
  223.            INTEGER       BLOCKS /4/                                     0216.300
  224.            INTEGER       DEVTYPE /2/                                    0216.400
  225.            INTEGER*8     FNAME                                          0216.500
  226.                                                                         0217.000
  227. C= Open a file for writing packet data to.                              0218.000
  228. C                                                                       0219.000
  229. C     GETFILE WILL TRY TO CREATE A FILE TO WRITE TO.  IF IT             0220.000
  230. C     ALREADY EXISTS, THEN IT WILL FAIL.                                0221.000
  231. C                                                                       0222.000
  232.       CHARACTER*8  FILENAM                                              0223.000
  233.            EQUIVALENCE  (FNAME,FILENAM)                                 0223.100
  234. C                                                                       0224.000
  235.       INTEGER      OPEN                                                 0225.000
  236. C                                                                       0226.000
  237.       INCLUDE K.KERMD                                                   0227.000
  238. C                                                                       0228.000
  239. C     GET THE DPC VERSION OF THE FILENAME                               0229.000
  240. C                                                                       0230.000
  241.       CALL AS2DPC(FN,FILENAM)                                           0231.000
  242.       CALL FILCHK(FILENAM)                                              0232.000
  243.       CALL M:CREATE(FNAME,BLOCKS,DEVTYPE,,,,,,,,,,ERRSTAT)              0232.200
  244.       IF (ERRSTAT.EQ.1) THEN                                            0232.300
  245.          GETFILE = OPEN(FILENAM, 'W')                                   0233.000
  246.        ELSE                                                             0233.100
  247.          GETFILE = 0                                                    0233.200
  248.          CALL M:DELETE(FNAME,,,ERRSTAT)                                 0233.300
  249.       END IF                                                            0233.400
  250.       RETURN                                                            0234.000
  251.       END                                                               0235.000
  252.       SUBROUTINE GETNOW(MM,DD,YY,HR,MIN,SEC)                            0236.000
  253.            IMPLICIT NONE                                                0237.000
  254.            INTEGER  MM,DD,YY                                            0238.000
  255.            INTEGER  HR,MIN,SEC                                          0239.000
  256.            INTEGER  ATIME                                               0240.000
  257.            INTEGER*8 ADATE                                              0241.000
  258.            INTEGER*1 BITE(8)                                            0242.000
  259.            EQUIVALENCE  (ADATE,BITE(1))                                 0243.000
  260.                                                                         0244.000
  261. CCC   GET THE CURRENT DATE AND TIME.                                    0245.000
  262. C                                                                       0246.000
  263.       INTEGER      IDT(3)              !INTEGER DATE AND TIME           0247.000
  264. C                                                                       0248.000
  265.       CALL X:TDAY(ATIME,ADATE)                                          0249.000
  266.       CALL DATE(IDT)                                                    0250.000
  267.       YY = IDT(1)                                                       0251.000
  268.       IF (BITE(3).EQ.'-') THEN                                          0252.000
  269.          MM = IDT(3)                                                    0253.000
  270.          DD = IDT(2)                                                    0254.000
  271.          ELSE                                                           0255.000
  272.          MM = IDT(2)                                                    0256.000
  273.          DD = IDT(3)                                                    0257.000
  274.       END IF                                                            0258.000
  275. C     MM = IDT(2)                                                       0259.000
  276. C     DD = IDT(3)                                                       0260.000
  277.       CALL TIME(IDT)                                                    0261.000
  278.       HR = IDT(1)                                                       0262.000
  279.       MIN = IDT(2)                                                      0263.000
  280.       SEC = IDT(3)                                                      0264.000
  281.       RETURN                                                            0265.000
  282.       END                                                               0266.000
  283.       SUBROUTINE FILCHK(FN)                                             0267.000
  284.            IMPLICIT NONE                                                0268.000
  285.            CHARACTER*8    FN                                            0269.000
  286. C                                                                       0270.000
  287. C= Check validity of filename, remove special characters                0271.000
  288. C                                                                       0272.000
  289.       INTEGER PTR,CH                                                    0273.000
  290.       INTEGER      I                                                    0274.000
  291. C                                                                       0275.000
  292.       INTRINSIC    ICHAR,CHAR,LEN                                       0275.100
  293. C     INTEGER      LEN                                                  0276.000
  294. C     INTEGER      ICHAR                                                0277.200
  295. C     CHARACTER*1  CHAR                                                 0278.000
  296. C                                                                       0279.000
  297.       PTR = 1                                                           0280.000
  298.       DO I=1, LEN(FN)                                                   0281.000
  299.         IF (FN(I:I) .EQ. ' ') THEN                                      0282.000
  300.         ELSE IF(FN(I:I) .GE. 'A' .AND. FN(I:I) .LE. 'Z') THEN           0283.000
  301.           FN(PTR:PTR) = FN(I:I)                                         0284.000
  302.           PTR = PTR + 1                                                 0285.000
  303.         ELSE IF (FN(I:I) .GE. '0' .AND. FN(I:I) .LE. '9' .AND.          0286.000
  304.      $           I .NE. 1) THEN                                         0287.000
  305.           FN(PTR:PTR) = FN(I:I)                                         0288.000
  306.           PTR = PTR + 1                                                 0289.000
  307.         ELSE IF (FN(I:I) .GE. 'a' .AND. FN(I:I) .LE. 'z') THEN          0290.000
  308.           FN(PTR:PTR) = CHAR(ICHAR(FN(I:I)) - X'20')                    0291.000
  309.           PTR = PTR + 1                                                 0292.000
  310.         ELSE IF(FN(I:I) .EQ. '.' .OR. FN(I:I) .EQ. '*' .OR.             0293.000
  311.      $          FN(I:I) .EQ. '_') THEN                                  0294.000
  312.           FN(PTR:PTR) = FN(I:I)                                         0295.000
  313.           PTR = PTR + 1                                                 0296.000
  314.         ENDIF                                                           0297.000
  315.       ENDDO                                                             0298.000
  316.       IF (PTR .LE. LEN(FN)) FN(PTR:) = ' '                              0299.000
  317.       RETURN                                                            0300.000
  318.       END                                                               0301.000
  319.       SUBROUTINE RDPARAM(PDATA)                                         0302.000
  320.            IMPLICIT NONE                                                0303.000
  321.            INTEGER    PDATA (1000)                                      0304.000
  322.                                                                         0305.000
  323. C= Get the packet parameters from the other kermit                      0306.000
  324. C                                                                       0307.000
  325.       INCLUDE K.KERMD                                                   0308.000
  326.       INCLUDE K.PACKC                                                   0309.000
  327.       INTEGER PARAMS(17)                                                0310.000
  328.       EQUIVALENCE (PARAMS,SPKHDR)                                       0311.000
  329.       INTEGER      I                                                    0312.000
  330. C                                                                       0313.000
  331.       INTEGER      CTL                                                  0314.000
  332.       INTEGER      UNCHAR                                               0315.000
  333.       INTEGER      TMP                                                  0315.100
  334. C                                                                       0316.000
  335. C     CYCLE THROUGH THE LIST OF PARAMETERS UNTIL THE END-OF-LIST        0317.000
  336. C     IS FOUND (A 0 BYTE).                                              0318.000
  337. C     Must be loop because variable length reply                        0319.000
  338. C                                                                       0320.000
  339.       I = 1                                                             0321.000
  340.       DO WHILE (PDATA(I) .NE. 0 .AND. I .LE. 17)                        0322.000
  341. X     WRITE(19,1000)I,PDATA(I)                                          0322.100
  342. X1000 FORMAT(' 322.2**  ',1I8,1X,1Z8)                                   0322.200
  343. C                                                                       0323.000
  344. C        IS IT THE PAD CHARACTER?                                       0324.000
  345. C                                                                       0325.000
  346.          IF (I .EQ. 4) THEN                                             0326.000
  347.             PARAMS(I) = CTL(PDATA(I))                                   0327.000
  348.             IF (PARAMS(I) .EQ. 0) PARAMS(I) = NULL                      0328.000
  349. C                                                                       0329.000
  350. C        IS IT THE QUOTE CHARACTER?                                     0330.000
  351. C                                                                       0331.000
  352.          ELSE IF (I .EQ. 6) THEN                                        0332.000
  353.             PARAMS(I) = PDATA(I)                                        0333.000
  354. C                                                                       0334.000
  355. C all else                                                              0335.000
  356. C                                                                       0336.000
  357.          ELSE                                                           0337.000
  358.             TMP = UNCHAR(PDATA(I))                                      0337.100
  359.             IF (TMP .NE. 0) THEN                                        0338.000
  360.                PARAMS(I) = TMP                                          0339.000
  361.             ENDIF                                                       0340.000
  362.          ENDIF                                                          0341.000
  363.          I = I + 1                                                      0342.000
  364.       ENDDO                                                             0343.000
  365. X     WRITE(19,1006)PARAMS(3)                                           0343.010
  366. X1006 FORMAT(' PSIZE = ',1Z8)                                           0343.020
  367.       IF(PDATA(3).EQ.2Z20)THEN                                          0343.100
  368.         PARAMS(3) = PARAMS(12)*95 + PARAMS(13) - 1                      0343.200
  369. X       WRITE(19,1005)PARAMS                                            0343.210
  370. X1005   FORMAT(' 3432**',8(1X,1Z8))                                     0343.220
  371.       ENDIF                                                             0343.300
  372.       PARAMS(5) = 0                                                     0343.400
  373.       RETURN                                                            0344.000
  374.       END                                                               0345.000
  375.       SUBROUTINE REMOVE(FN)                                             0346.000
  376.            IMPLICIT NONE                                                0347.000
  377.            INTEGER   FN(1000)                                           0348.000
  378.                                                                         0349.000
  379. C= Remove a file from the local file list.                              0350.000
  380. C                                                                       0351.000
  381.       CHARACTER*56 FNAME                                                0352.000
  382.                                                                         0353.000
  383.       CALL AS2DPC(FN,FNAME)                                             0354.000
  384.       OPEN(UNIT='TMP',FILE=FNAME)                                       0355.000
  385.       CLOSE(UNIT='TMP',STATUS='DELETE')                                 0356.000
  386.       RETURN                                                            0357.000
  387.       END                                                               0358.000
  388.       SUBROUTINE STRCPY(S1,S2)                                          0359.000
  389.            IMPLICIT NONE                                                0360.000
  390.            INTEGER S1(1000),S2(1000)                                    0361.000
  391.                                                                         0362.000
  392. C= Copy one ascii string to another                                     0363.000
  393. C                                                                       0364.000
  394.       INTEGER      I1                                                   0365.000
  395.                                                                         0366.000
  396.       I1 = 1                                                            0367.000
  397. 10    S2(I1) = S1(I1)                                                   0368.000
  398.       IF (S1(I1) .NE. 0) THEN                                           0369.000
  399.          I1 = I1 + 1                                                    0370.000
  400.          GO TO 10                                                       0371.000
  401.       ENDIF                                                             0372.000
  402.       RETURN                                                            0373.000
  403.       END                                                               0374.000
  404.       INTEGER FUNCTION SLEN(STR)                                        0375.000
  405.            IMPLICIT NONE                                                0376.000
  406.            INTEGER   STR(1000)                                          0377.000
  407.                                                                         0378.000
  408. C= Return the length of a zero terminated ascii string buffer.          0379.000
  409. C                                                                       0380.000
  410.       INTEGER      I                                                    0381.000
  411.                                                                         0382.000
  412.       I = 0                                                             0383.000
  413. 10    IF (STR(I+1) .NE. 0) THEN                                         0384.000
  414.          I = I + 1                                                      0385.000
  415.          GO TO 10                                                       0386.000
  416.       ENDIF                                                             0387.000
  417.       SLEN = I                                                          0388.000
  418.       RETURN                                                            0389.000
  419.       END                                                               0390.000
  420.       INTEGER FUNCTION SNDPAR(PDATA)                                    0391.000
  421.            IMPLICIT NONE                                                0392.000
  422.            INTEGER PDATA(1000)                                          0393.000
  423.                                                                         0394.000
  424. C= Setup parameters to send to other kermit.                            0395.000
  425. C                                                                       0396.000
  426.       INCLUDE K.KERMD                                                   0397.000
  427.       INCLUDE K.PACKC                                                   0398.000
  428. C                                                                       0399.000
  429.       INTEGER      I                                                    0400.000
  430.       INTEGER      PARAMS(17)                                           0401.000
  431.         EQUIVALENCE (PARAMS, PACKSIZ)                                   0402.000
  432. C                                                                       0403.000
  433.       INTEGER      CTL                                                  0404.000
  434.       INTEGER      TOCHAR                                               0405.000
  435. C                                                                       0406.000
  436. C     SEND WHAT WE WANT                                                 0407.000
  437. C                                                                       0408.000
  438.       IF(PACKSIZ.GT.95)THEN                                             0408.100
  439.         PDATA (1) = 2Z20                                                0408.200
  440.       ELSE                                                              0408.300
  441.          PDATA (1) = TOCHAR(PACKSIZ)                                    0409.000
  442.       ENDIF                                                             0409.100
  443.       PDATA (2) = TOCHAR(TIMEOUT)                                       0410.000
  444.       PDATA (3) = TOCHAR(NPAD)                                          0411.000
  445.       PDATA (4) = CTL(PADCH)                                            0412.000
  446.       PDATA (5) = TOCHAR(EOLCH)                                         0413.000
  447.       PDATA (6) = QUOTECH                                               0414.000
  448.       PDATA (7) = 2Z26                                                  0415.000
  449.       PDATA(8)  = 2Z31                                                  0415.100
  450.       PDATA (9) = 2Z7E                                                  0415.200
  451.       PDATA (10)= 2Z2E                                                  0415.300
  452.       PDATA (11) = 2Z21                                                 0415.301
  453.       PDATA (12) = MAXPACK/95                                           0415.310
  454.       PDATA (13) = MAXPACK - PDATA(12)*95  + 2Z20                       0415.320
  455.       PDATA (12) = PDATA(12) + 2Z20                                     0415.330
  456. C                                                                       0416.000
  457. C     RETURN LENGTH OF HOW MANY THINGS WE WANT TO SET                   0417.000
  458. C                                                                       0418.000
  459.       SNDPAR = 13                                                       0419.000
  460.       RETURN                                                            0420.000
  461.       END                                                               0421.000
  462.       SUBROUTINE SLEEP(SECONDS)                                         0422.000
  463.            IMPLICIT NONE                                                0423.000
  464.            INTEGER     SECONDS                                          0424.000
  465. CC                                                                      0425.000
  466. C     SLEEP - HOLD FOR <SECONDS> SECONDS.                               0426.000
  467. C                                                                       0427.000
  468.       INTEGER      I                                                    0428.000
  469.                                                                         0429.000
  470.       DO 100 I=1,SECONDS                                                0430.000
  471.          CALL DELAY(  500)                                              0431.000
  472. 100   CONTINUE                                                          0432.000
  473.       RETURN                                                            0433.000
  474.       END                                                               0434.000
  475.       SUBROUTINE DELAY(MSEC)                                            0435.000
  476.            IMPLICIT NONE                                                0436.000
  477.            INTEGER  MSEC                                                0437.000
  478. C                                                                       0438.000
  479. C=    DELAY - HOLD THINGS UP FOR <MSEC> MILISECS.                       0439.000
  480. C                                                                       0440.000
  481. C     **** THIS IS PROBABLY SYSTEM DEPENDENT CODE *****                 0441.000
  482. C          IF YOU MODIFY IT USE CONDITIONAL COMPILATION                 0442.000
  483. C                                                                       0443.000
  484.       INTEGER      IOS                                                  0444.000
  485. C                                                                       0445.000
  486.       CALL WAIT(MSEC, 1, IOS)                                           0446.000
  487.       RETURN                                                            0447.000
  488.       END                                                               0448.000
  489.       INTEGER FUNCTION CTL (ASCCH)                                      0449.000
  490.            IMPLICIT NONE                                                0450.000
  491.            INTEGER  ASCCH                                               0451.000
  492. C                                                                       0452.000
  493. C= Flip control bit protecting control chars and unprotecting           0453.000
  494. C                                                                       0454.000
  495.       CTL = IEOR(ASCCH,X'40')                                           0455.000
  496.       RETURN                                                            0456.000
  497.       END                                                               0457.000
  498.       INTEGER FUNCTION TOCHAR(ASCCH)                                    0458.000
  499.            IMPLICIT NONE                                                0459.000
  500.            INTEGER  ASCCH                                               0460.000
  501. C                                                                       0461.000
  502. C= Make an ascii character.                                             0462.000
  503. C                                                                       0463.000
  504.       INCLUDE      K.KERMD                                              0464.000
  505. C                                                                       0465.000
  506.       TOCHAR = ASCCH + BLANK                                            0466.000
  507.       RETURN                                                            0467.000
  508.       END                                                               0468.000
  509.       INTEGER FUNCTION UNCHAR(ASCCH)                                    0469.000
  510.            IMPLICIT NONE                                                0470.000
  511.            INTEGER   ASCCH                                              0471.000
  512. C                                                                       0472.000
  513. C= Convert back to control character                                    0473.000
  514. C                                                                       0474.000
  515.       INCLUDE      K.KERMD                                              0475.000
  516. C                                                                       0476.000
  517.       UNCHAR = ASCCH - BLANK                                            0477.000
  518.       RETURN                                                            0478.000
  519.       END                                                               0479.000
  520.       SUBROUTINE GETMACH(MACH)                                          0480.000
  521.            IMPLICIT NONE                                                0481.000
  522.            CHARACTER*(*) MACH  !current machine type                    0482.000
  523. C                                                                       0483.000
  524. C= Retrieves current machine type from os                               0484.000
  525. C                                                                       0485.000
  526.       CHARACTER*2 MACHS(0:5)       !gould machines                      0486.000
  527.      $ /'55','77','27','67','87','97'/                                  0487.000
  528.       INTEGER     IMACH            !read machine type                   0488.000
  529. C                                                                       0489.000
  530.       INLINE                                                            0490.000
  531.         LB         7,X'0CB7'       !get machine type code               0491.000
  532.         STW        7,IMACH         !store for use                       0492.000
  533.       ENDI                                                              0493.000
  534.       IF (IMACH .GE. 0 .AND. IMACH .LE. 5) THEN                         0494.000
  535.         MACH = MACHS(IMACH)                                             0495.000
  536.       ELSE                                                              0496.000
  537.         MACH = '**'                                                     0497.000
  538.       ENDIF                                                             0498.000
  539.       RETURN                                                            0499.000
  540.       END                                                               0500.000
  541.       SUBROUTINE PRTMSG(STR, VAL)                                       0501.000
  542.            IMPLICIT NONE                                                0502.000
  543.            CHARACTER*(*) STR                                            0503.000
  544.            INTEGER       VAL                                            0504.000
  545. C                                                                       0505.000
  546. C= Prints a message to output device (normally abort message)           0506.000
  547. C                                                                       0507.000
  548.  1000 FORMAT (X,A,I4)                                                   0508.000
  549.       WRITE ('UT',1000,ERR=10) STR, VAL                                 0509.000
  550.  10   CONTINUE                                                          0510.000
  551.       RETURN                                                            0511.000
  552.       END                                                               0512.000
  553.       SUBROUTINE DISPLAY (S)                                            0513.000
  554.            IMPLICIT NONE                                                0514.000
  555.            CHARACTER*(*) S                                              0515.000
  556. C                                                                       0516.000
  557. C= Display string on console                                            0517.000
  558. C                                                                       0518.000
  559.       INTEGER      WORD                                                 0519.000
  560.       CHARACTER*80 STRING                                               0520.000
  561.         EQUIVALENCE (WORD, STRING) !word bound string                   0521.000
  562. C                                                                       0522.000
  563.       STRING = S                                                        0523.000
  564.       CALL CARRIAGE                                                     0524.000
  565.       CALL M:TELEW(STRING)                                              0525.000
  566.       RETURN                                                            0526.000
  567.       END                                                               0527.000
  568.       INTEGER FUNCTION NOFIND (STRING,CHARN)                            0528.000
  569.       IMPLICIT     NONE                                                 0529.000
  570. C= Return position of 1st character in STRING that does not match CHARN.0530.000
  571. C                                                                       0531.000
  572. C                            RETURN THE INDEX OF THE FIRST              0532.000
  573. C                            CHARACTER IN STRING THAT DOES              0533.000
  574. C                            NOT MATCH CHARN.                           0534.000
  575. C                            RETURNS 0 IF THE STRINGS MATCH.            0535.000
  576. C                                                                       0536.000
  577. C                            FORMAL PARAMETER DECLARATIONS.             0537.000
  578.       CHARACTER*(*) STRING,CHARN                                        0538.000
  579. C                                                                       0539.000
  580. C                            LOCAL DECLARATIONS.                        0540.000
  581. C                                                                       0541.000
  582. C                            LENGTH OF STRING PARAMETER.                0542.000
  583.       INTEGER STRLEN                                                    0543.000
  584. C                            STRING SEARCH POINTER.                     0544.000
  585.       INTEGER I                                                         0545.000
  586. C                            LENGTH OF STRING FUNCTION                  0546.000
  587.       INTRINSIC LEN                                                     0547.000
  588.                                                                         0548.000
  589. C                                                                       0549.000
  590. C-------------------------------------------------------------------    0550.000
  591. C                                                                       0551.000
  592. C                            FIND LENGTH OF INPUT STRING.               0552.000
  593.       STRLEN = LEN(STRING)                                              0553.000
  594. C                            PRESET FUNCTION VALUE TO INDICATE          0554.000
  595. C                            SEARCH FAILED TO FIND NON-CHARN            0555.000
  596. C                            CHARACTER.                                 0556.000
  597.       NOFIND = 0                                                        0557.000
  598. C                            INITIALIZE STRING SEARCH POINTER.          0558.000
  599.       I=0                                                               0559.000
  600.   10  CONTINUE                                                          0560.000
  601. C                            POINT TO NEXT CHARACTER IN STRING          0561.000
  602.       I = I + 1                                                         0562.000
  603. C                            BEYOND END OF STRING - SEARCH FAILED.      0563.000
  604.       IF( I .GT. STRLEN ) GO TO 20                                      0564.000
  605. C                            DO IT AGAIN IF THIS CHARACTER MATCHES.     0565.000
  606.       IF( STRING(I:I) .EQ. CHARN ) GO TO 10                             0566.000
  607. C                            MISMATCH ENCOUNTERED - NOTE                0567.000
  608. C                            POSITION AND RETURN.                       0568.000
  609.       NOFIND = I                                                        0569.000
  610. C                                                                       0570.000
  611.   20  CONTINUE                                                          0571.000
  612. C                                                                       0572.000
  613.       RETURN                                                            0573.000
  614.       END                                                               0574.000
  615.       INTEGER FUNCTION LASTCHR (STRING)                                 0575.000
  616.       IMPLICIT     NONE                                                 0576.000
  617. C= Return position of last non-blank character in STRING.               0577.000
  618. C                                                                       0578.000
  619. C                            FIND THE LAST NON-BLANK CHARACTER          0579.000
  620. C                            IN THE INPUT STRING.                       0580.000
  621. C                                                                       0581.000
  622. C                                                                       0582.000
  623.       CHARACTER*(*) STRING   ! GIVEN STRING                             0583.000
  624. C                                                                       0584.000
  625. C     RETURNS LASTCHR        ! POSITION OF LAST NON-BLANK CHARACTER     0585.000
  626. C                                IN STRING                              0586.000
  627. C                                                                       0587.000
  628.       INTEGER CHR                                                       0588.000
  629. C                                                                       0589.000
  630.       INTEGER   LEN                                                     0590.000
  631.       INTRINSIC LEN                                                     0591.000
  632. C                                                                       0592.000
  633.       INTEGER     ZERO,ONE                                              0593.000
  634.       PARAMETER  (ZERO=0,ONE=1)                                         0594.000
  635. C     CHARACTER*1 BLANK                                                 0595.000
  636. C     PARAMETER  (BLANK=' ')                                            0596.000
  637. C                                                                       0597.000
  638. C     REVISED 12/08/82, PDM.  CORRECT TREATMENT OF EMPTY LINE.          0598.000
  639. C                                                                       0599.000
  640. C------------------------------------------------------------------     0600.000
  641. C                                                                       0601.000
  642. C                                                                       0602.000
  643.       CHR = LEN(STRING) + ONE                                           0603.000
  644.   10  CONTINUE                                                          0604.000
  645.            CHR = CHR - ONE                                              0605.000
  646.            IF (CHR.LE.ZERO) GOTO 20                                     0606.000
  647.       IF (STRING(CHR:CHR).EQ.' ') GOTO 10                               0607.000
  648. 20    CONTINUE                                                          0608.000
  649. C                                                                       0609.000
  650.       LASTCHR = CHR                                                     0610.000
  651. C                                                                       0611.000
  652. C                                                                       0612.000
  653.       RETURN                                                            0613.000
  654.       END                                                               0614.000
  655.       SUBROUTINE LADJ(STRING)                                           0615.000
  656.       IMPLICIT NONE                                                     0616.000
  657. C= Left-justify a string.                                               0617.000
  658. C                            Left-justify a string.                     0618.000
  659. C-------------------------------------------------------------------    0619.000
  660. C Written May 6, 1983 by Fred Preller, Simulation Associates, Inc.      0620.000
  661. C-------------------------------------------------------------------    0621.000
  662.       CHARACTER*(*) STRING                                              0622.000
  663. C-------------------------------------------------------------------    0623.000
  664.       INTEGER       FIRST    ! First non-blank character position       0624.000
  665.       CHARACTER*1   BLANK/' '/                                          0625.000
  666. C-------------------------------------------------------------------    0626.000
  667.       INTEGER   NOFIND                                                  0627.000
  668.       EXTERNAL  NOFIND                                                  0628.000
  669. C-------------------------------------------------------------------    0629.000
  670.       FIRST = NOFIND(STRING,BLANK)                                      0630.000
  671. C Note the criteria: FIRST = 0   => totally blank line, and             0631.000
  672. C                    FIRST = 1   => line already justified.             0632.000
  673.       IF( FIRST .GT. 1 ) STRING = STRING(FIRST:)                        0633.000
  674.       RETURN                                                            0634.000
  675.       END                                                               0635.000
  676.       SUBROUTINE BREAKR                                                 0636.000
  677.            IMPLICIT NONE                                                0637.000
  678. C= Establish break receiver                                             0638.000
  679. C                                                                       0639.000
  680. C BREAKR ESTABLISHES A BREAK RECEIVER THAT REMAINS ACTIVE AS            0640.000
  681. C LONG AS THE TASK IS ACTIVE.  WHEN A BREAK IS RECEIVED, THE            0641.000
  682. C BREAK FLAG IS SET.  THE USER MUST CLEAR THE FLAG TO ENSURE            0642.000
  683. C THAT SUBSEQUENT BREAKS ARE DETECTED.                                  0643.000
  684. C                                                                       0644.000
  685.       LOGICAL BREAK                                                     0645.000
  686.       INTEGER ERRSTAT                                                   0646.000
  687.       COMMON /BREAK/ BREAK                                              0647.000
  688. C                                                                       0648.000
  689. C     CALL M_PRIV                                                       0649.000
  690.       CALL X:BRK ($100,ERRSTAT,$50)                                     0650.000
  691.       BREAK = .FALSE.                                                   0651.000
  692.   50  CONTINUE                                                          0652.000
  693. C     CALL M_UPRIV                                                      0653.000
  694.       RETURN                                                            0654.000
  695. C                                                                       0655.000
  696. C BREAK ENTRY POINT                                                     0656.000
  697.  100  BREAK = .TRUE.                                                    0657.000
  698.       CALL X:BRKXIT                                                     0658.000
  699. C                                                                       0659.000
  700.       END                                                               0660.000
  701.       SUBROUTINE SLINE(S)                                               0661.000
  702.           CHARACTER*(*)  S   !tsm line                                  0662.000
  703. C                                                                       0663.000
  704. C= Returns the tsm command line without the execution portion           0664.000
  705. C                                                                       0665.000
  706.       CHARACTER*236  BUFF   !local buffer                               0666.000
  707.       INTEGER      NRESV    !number of reserved words                   0667.000
  708.         PARAMETER (NRESV = 5)                                           0668.000
  709.       CHARACTER*8 RWORDS(NRESV)          !reserved pre words            0669.000
  710.      $   /'RUN', 'EXECUTE ', 'EXEC', 'DEBU', 'DEBUG'/                   0670.000
  711.       CHARACTER*8  R                   !reserved word                   0671.000
  712.       INTEGER   OUT/'OUT'/                                              0672.000
  713.       CHARACTER*1  D                   !delimitor                       0673.000
  714. C                                                                       0674.000
  715. C SLINE                                                                 0675.000
  716. C                                                                       0676.000
  717.       CALL TLINE(BUFF)                 !get tsm command line            0677.000
  718.       CALL LADJ(BUFF)                                                   0678.000
  719. C                                                                       0679.000
  720. C remove leading '$'                                                    0680.000
  721. C                                                                       0681.000
  722.       IF (BUFF(1:1) .EQ. '$') THEN                                      0682.000
  723.         BUFF = BUFF(2:)                                                 0683.000
  724.       END IF                                                            0684.000
  725.       CALL EXTR(R, D, BUFF)               !possible task name/reserved  0685.000
  726. C                                                                       0686.000
  727. C get rid of leading reserved words                                     0687.000
  728. C                                                                       0688.000
  729.       DO 20,I=1, NRESV                                                  0689.000
  730.         IF (R .EQ. RWORDS(I)) THEN                                      0690.000
  731.           CALL EXTR(R, D, BUFF)         !get task path                  0691.000
  732.           LEAVE 20                                                      0692.000
  733.         END IF                                                          0693.000
  734.  20   END DO                                                            0694.000
  735. C                                                                       0695.000
  736. C check for dsc name                                                    0696.000
  737. C                                                                       0697.000
  738.       IF (R(1:1) .EQ. '@' .OR. R(1:1) .EQ. '^' .OR. D .EQ. '(') THEN    0698.000
  739.         CALL EXTR(R, D, BUFF)          !extract directory               0699.000
  740.         CALL EXTR(R, D, BUFF)          !task name                       0700.000
  741.       END IF                                                            0701.000
  742. C                                                                       0702.000
  743. C return remander without task name                                     0703.000
  744. C                                                                       0704.000
  745.       S = BUFF                                                          0705.000
  746.       RETURN                                                            0706.000
  747.       END                                                               0707.000
  748.       SUBROUTINE EXTR(R, D, S)                                          0708.000
  749.            CHARACTER*(*) R             !extracted word                  0709.000
  750.            CHARACTER*1   D             !delimitor                       0710.000
  751.            CHARACTER*(*) S             !word to extract from            0711.000
  752. C                                                                       0712.000
  753. C= Extracts the next word based on TSM's delimitors                     0713.000
  754. C                                                                       0714.000
  755.       CHARACTER*9 DELIM /' ,()=;$!%'/  !delimitors                      0715.000
  756.       CHARACTER*2 QUOTES /'''""'/      !quotes                          0716.000
  757.       INTEGER      NS                  !length of S                     0717.000
  758.       INTEGER      I                                                    0718.000
  759.       LOGICAL      QUOTE           !in quote                            0719.000
  760.       CHARACTER*1  QUOTECH         !character used in quote             0720.000
  761. C                                                                       0721.000
  762. C functions                                                             0722.000
  763. C                                                                       0723.000
  764.       INTEGER      NOFIND              !look until not found            0724.000
  765. C                                                                       0725.000
  766. C extr                                                                  0726.000
  767. C                                                                       0727.000
  768.       QUOTE = .FALSE.                                                   0728.000
  769.       NS = LEN(S)                                                       0729.000
  770.       I = 1                                                             0730.000
  771.       DO 20, WHILE (I .LE. NS)                                          0731.000
  772.         IF (QUOTE) THEN                                                 0732.000
  773.           IF (S(I:I) .EQ. QUOTECH) THEN                                 0733.000
  774.              QUOTE = .FALSE.                                            0734.000
  775.           ENDIF                                                         0735.000
  776.         ELSE                                                            0736.000
  777.           IF (INDEX(QUOTES, S(I:I)) .GT. 0) THEN                        0737.000
  778.             QUOTECH = S(I:I)                                            0738.000
  779.             QUOTE = .TRUE.                                              0739.000
  780.           ELSE IF (INDEX(DELIM, S(I:I)) .GT. 0) THEN                    0740.000
  781.             LEAVE 20                                                    0741.000
  782.           ENDIF                                                         0742.000
  783.         END IF                                                          0743.000
  784.         I = I + 1                                                       0744.000
  785.  20   END DO                                                            0745.000
  786. C                                                                       0746.000
  787. C returned field                                                        0747.000
  788. C                                                                       0748.000
  789.       IF (I .GT. NS) THEN                                               0749.000
  790.         R = S                                                           0750.000
  791.       ELSE IF (I .EQ. 1) THEN                                           0751.000
  792.         R = ' '                                                         0752.000
  793.       ELSE                                                              0753.000
  794.         R = S(:I-1)                                                     0754.000
  795.       END IF                                                            0755.000
  796. C                                                                       0756.000
  797. C delimitor                                                             0757.000
  798. C                                                                       0758.000
  799.       IF (I .GT. NS) THEN                                               0759.000
  800.         D = ' '                                                         0760.000
  801.       ELSE                                                              0761.000
  802.         D = S(I:I)                                                      0762.000
  803.       END IF                                                            0763.000
  804. C                                                                       0764.000
  805. C new buffer                                                            0765.000
  806. C                                                                       0766.000
  807.       IF (I .GT. NS) THEN                                               0767.000
  808.         S = ' '                                                         0768.000
  809.       ELSE IF (I .EQ. NS) THEN                                          0769.000
  810.         S = ' '                                                         0770.000
  811.       ELSE                                                              0771.000
  812.         S = S(I+1:)                                                     0772.000
  813.       END IF                                                            0773.000
  814. C                                                                       0774.000
  815. C remove trailing blanks                                                0775.000
  816. C                                                                       0776.000
  817.       I = NOFIND(S, ' ')                                                0777.000
  818.       IF (I .GT. 0) S = S(I:)                                           0778.000
  819.       RETURN                                                            0779.000
  820.       END                                                               0780.000
  821.       LOGICAL FUNCTION ISFILE(FILNAME)                                  0781.000
  822.            IMPLICIT NONE                                                0782.000
  823.            INTEGER*8    FILNAME            !FILE TO CHECK               0783.000
  824. C                                                                       0784.000
  825. C= Tests to determine if file specified in path exists                  0785.000
  826. C       The M:LOG routine needs the FILENAME to be declared             0786.000
  827. C   as an INTEGER DOUBLE WORD.                                          0787.000
  828. C                                                                       0788.000
  829.       INTEGER*4    RDBUFFER(8)         !RESOURCE DESCR. BUFFER          0789.000
  830.       INTEGER*4    ERRSTAT             !ERROR STATUS                    0790.000
  831.       INTEGER*4    TYPE                !FILE TYPE                       0791.000
  832.       LOGICAL      ISFILE                                               0791.100
  833. C                                                                       0792.000
  834. C                                                                       0793.000
  835. C     CALL X_RID(PATHNAME,RDBUFFER,ERRSTAT)                             0794.000
  836.       ERRSTAT = -1                  !INITIALIZE ERROR STATUS            0795.000
  837.       TYPE = 8Z4E202020   !N   '                                        0795.100
  838.       ISFILE = .TRUE.                                                   0795.200
  839.       CALL M:LOG(TYPE,RDBUFFER,FILNAME,ERRSTAT)   ! X_RID DOES NOT EXIS 0796.000
  840.       ISFILE = ERRSTAT .NE. 0                                           0797.000
  841.       RETURN                                                            0798.000
  842.       END                                                               0799.000
  843.       INTEGER FUNCTION XTOI(S)                                          0800.000
  844.            IMPLICIT NONE                                                0801.000
  845.            CHARACTER*(*)   S           !hex number in ascii             0802.000
  846. C          return          integer value                                0803.000
  847. C                                                                       0804.000
  848. C= Converts an ascii hex string to integer number                       0805.000
  849. C                                                                       0806.000
  850.       INTEGER      N                   !length of string                0807.000
  851.       INTEGER      I                   !string pointer                  0808.000
  852.       INTEGER      C                   !ascii value                     0809.000
  853.       INTEGER      ZERO/X'30'/         !ascii zero                      0810.000
  854.       INTEGER      NINE/X'39'/                                          0811.000
  855.       INTEGER      A   /X'41'/                                          0812.000
  856.       INTEGER      F   /X'46'/                                          0813.000
  857. C                                                                       0814.000
  858. C functions                                                             0815.000
  859. C                                                                       0816.000
  860.       INTRINSIC    ICHAR ,LEN                                           0817.100
  861. C     INTEGER      ICHAR               !char to integer value           0817.200
  862.       INTEGER      LEN                 !length of string                0818.000
  863. C                                                                       0819.000
  864. C xtoi                                                                  0820.000
  865. C                                                                       0821.000
  866.       N = LEN(S)                                                        0822.000
  867.       I = 1                                                             0823.000
  868.       XTOI = 0                                                          0824.000
  869.       DO WHILE (I .LT. N .AND. S(I:I) .EQ. ' ')                         0825.000
  870.         I = I + 1                                                       0826.000
  871.       END DO                                                            0827.000
  872.       DO 20 WHILE (I .LE. N)                                            0828.000
  873.         C = ICHAR(S(I:I))                                               0829.000
  874.         IF (C .GE. ZERO .AND. C .LE. NINE) THEN                         0830.000
  875.           C = C - ZERO                                                  0831.000
  876.         ELSE IF (C .GE. A .AND. C  .LE. F) THEN                         0832.000
  877.           C = C - A + 10                                                0833.000
  878.         ELSE                                                            0834.000
  879.           LEAVE 20                                                      0835.000
  880.         END IF                                                          0836.000
  881.         INLINE                                                          0837.000
  882.           LW     6,XTOI     !get previous value                         0838.000
  883.           LW     7,C        !get current value to add                   0839.000
  884.           SLL    7,28       !left justify                               0840.000
  885.           SLLD   6,4        !move into xtoi                             0841.000
  886.           STW    6,XTOI      !done                                      0842.000
  887.         ENDI                                                            0843.000
  888.         I = I + 1                                                       0844.000
  889.  20   END DO                                                            0845.000
  890.       RETURN                                                            0846.000
  891.       END                                                               0847.000
  892.       CHARACTER*(*) FUNCTION ITOX (X)                                   0848.000
  893.            IMPLICIT NONE                                                0849.000
  894.            INTEGER       X   !hex value                                 0850.000
  895. C                                                                       0851.000
  896. C= Convert integer to hex ascii string                                  0852.000
  897. C  forces a leading numeric character                                   0853.000
  898. C                                                                       0854.000
  899.       CHARACTER*9  T                   !temporary string                0855.000
  900.       INTEGER      I                   !sting pointer                   0856.000
  901.       INTEGER      J                   !local value to convert          0857.000
  902.       INTEGER      C                   !convertion value                0858.000
  903.       INTEGER      A/X'41'/                                             0859.000
  904.       INTEGER      F/X'46'/                                             0860.000
  905.       INTEGER      ZERO/X'30'/                                          0861.000
  906.       INTEGER      NINE/X'39'/                                          0862.000
  907. C                                                                       0863.000
  908. C functions                                                             0864.000
  909. C                                                                       0865.000
  910.       CHARACTER*1  CHAR                !integer to character function   0866.000
  911. C                                                                       0867.000
  912. C ITOX                                                                  0868.000
  913. C                                                                       0869.000
  914.       J = X                                                             0870.000
  915.       T = ' '                                                           0871.000
  916.       I = 9                                                             0872.000
  917.       DO UNTIL (J .EQ. 0)                                               0873.000
  918.         INLINE                                                          0874.000
  919.           LW       6,J                 !get current value               0875.000
  920.           SRLD     6,4                 !get first hex value             0876.000
  921.           SRL      7,28                !right justify                   0877.000
  922.           STW      7,C                 !convert                         0878.000
  923.           STW      6,J                 !new value                       0879.000
  924.         ENDI                                                            0880.000
  925.         IF (C .GE. 10) THEN                                             0881.000
  926.           C = C - 10 + A                                                0882.000
  927.         ELSE                                                            0883.000
  928.           C = C + ZERO                                                  0884.000
  929.         END IF                                                          0885.000
  930.         T(I:I) = CHAR(C)                                                0886.000
  931.         I = I - 1                                                       0887.000
  932.       END DO                                                            0888.000
  933.       IF (T(I+1:I+1) .GT. 'A') THEN                                     0889.000
  934.         T(I:I) = CHAR(ZERO)                                             0890.000
  935.       END IF                                                            0891.000
  936.       CALL LADJ(T)                                                      0892.000
  937.       ITOX = T                                                          0893.000
  938.       RETURN                                                            0894.000
  939.       END                                                               0895.000
  940.       CHARACTER*(*) FUNCTION ITOA (I)                                   0896.000
  941.            IMPLICIT NONE                                                0897.000
  942.            INTEGER       I             !integer to output               0898.000
  943. C                                                                       0899.000
  944. C= Converts an integer number to an ascii string                        0900.000
  945. C                                                                       0901.000
  946.       CHARACTER*20   BUF               !local buffer                    0902.000
  947.       INTEGER        J                 !local integer value             0903.000
  948. C                                                                       0904.000
  949. C format                                                                0905.000
  950. C                                                                       0906.000
  951.  1000 FORMAT (I20)                                                      0907.000
  952. C                                                                       0908.000
  953. C itoa                                                                  0909.000
  954. C                                                                       0910.000
  955.       J = I                                                             0911.000
  956.       WRITE (BUF, 1000, ERR=10) J                                       0912.000
  957.       CALL LADJ(BUF)                                                    0913.000
  958.       ITOA = BUF                                                        0914.000
  959.       RETURN                                                            0915.000
  960.  10   CONTINUE                                                          0916.000
  961.       ITOA = '0'                                                        0917.000
  962.       RETURN                                                            0918.000
  963.       END                                                               0919.000
  964.       SUBROUTINE GETEMSG(STRNG)                                         0920.000
  965.            IMPLICIT NONE                                                0921.000
  966.            INTEGER  STRNG(1000)                                         0922.000
  967. C                                                                       0923.000
  968. C= Produce an error message string for the current error                0924.000
  969. CLT 2.3 THIS ROUTINE TRW'D TO PRODUCE CORRECT ERROR MESSAGES            0925.000
  970. C                                                                       0926.000
  971.       INCLUDE      K.KERMD                                              0927.000
  972.       INCLUDE      K.PROTC                                              0928.000
  973. C                                                                       0929.000
  974.       INTEGER      I                                                    0930.000
  975. C                                                                       0931.000
  976.       I = 1                                                             0932.000
  977.       IF (ABORTYP(SENDING)) THEN                                        0933.000
  978.         CALL DPC2AS('SENDING',STRNG(I), 7)                              0934.000
  979.         I = I + 7                                                       0935.000
  980.       ELSE                                                              0936.000
  981.         CALL DPC2AS('RECEIVING',STRNG(I),9)                             0937.000
  982.         I = I + 9                                                       0938.000
  983.       ENDIF                                                             0939.000
  984.       IF (ABORTYP(INITERR)) THEN                                        0940.000
  985.         CALL DPC2AS(' INIT',STRNG(I),5)                                 0941.000
  986.         I = I + 5                                                       0942.000
  987.       ELSE IF (ABORTYP(FILERR)) THEN                                    0943.000
  988.         CALL DPC2AS(' FILE NAME',STRNG(I),10)                           0944.000
  989.         I = I + 10                                                      0945.000
  990.       ELSE IF (ABORTYP(DATAERR)) THEN                                   0946.000
  991.         CALL DPC2AS(' DATA',STRNG(I),5)                                 0947.000
  992.         I = I + 5                                                       0948.000
  993.       ELSE IF (ABORTYP(EOFERR)) THEN                                    0949.000
  994.         CALL DPC2AS(' EOF',STRNG(I),4)                                  0950.000
  995.         I = I + 4                                                       0951.000
  996.       ELSE                                                              0952.000
  997.         CALL DPC2AS(' BREAK',STRNG(I),6)                                0953.000
  998.         I = I + 6                                                       0954.000
  999.       ENDIF                                                             0955.000
  1000.       CALL DPC2AS(' PACKET,',STRNG(I),7)                                0956.000
  1001.       I = I + 7                                                         0957.000
  1002.       IF (ABORTYP(TOOMANY)) THEN                                        0958.000
  1003.         CALL DPC2AS(' TOO MANY RETRIES',STRNG(I),17)                    0959.000
  1004.         I = I + 17                                                      0960.000
  1005.       ELSE IF (ABORTYP(INVALID)) THEN                                   0961.000
  1006.         CALL DPC2AS(' RECV. INVALID PACKET',STRNG(I),20)                0962.000
  1007.         I = I + 20                                                      0963.000
  1008.       ELSE IF (ABORTYP(SEQERR)) THEN                                    0964.000
  1009.         CALL DPC2AS(' RECV. OUT OF SEQ. PACKET',STRNG(I),25)            0965.000
  1010.         I = I + 25                                                      0966.000
  1011.       ELSE IF (ABORTYP(LCLFILE)) THEN                                   0967.000
  1012.         CALL DPC2AS(' FAILED TO OPEN FILE',STRNG(I), 21)                0968.000
  1013.         I = I + 21                                                      0969.000
  1014.       ELSE                                                              0970.000
  1015.         CALL DPC2AS(' UNANTICIPATED ERROR',STRNG(I),20)                 0971.000
  1016.         I = I + 20                                                      0972.000
  1017.       ENDIF                                                             0973.000
  1018.       STRNG(I) = 0                                                      0974.000
  1019.       I = I+1                                                           0975.000
  1020.       RETURN                                                            0976.000
  1021.       END                                                               0977.000
  1022.