home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / archives / kermit11.tar.gz / kermit11.tar / k11hex.ftn < prev    next >
Text File  |  1989-06-13  |  4KB  |  209 lines
  1.     program k11hex
  2. c
  3. c
  4. c    02-Mar-84  13:50:23  Brian Nelson
  5. c
  6. c
  7. c     Written in Fortran-77 since if written it in  MACRO-11 I
  8. c    would need two versions (one for RSX and RSTS and another
  9. c    for RT)
  10. c
  11. c    pack and unpack the so-called HEX file for kermit
  12. c
  13.     byte    mode
  14.     byte    infil(40),outfil(40)
  15. c
  16. c    note:    For encoding, RT fortran does not know about
  17. c        eof for direct access files. Will have to fix
  18. c        for RT when I get the rt version done.
  19. c
  20. c
  21. c
  22. c    to compile:
  23. c
  24. c    f77 k11hex=k11hex
  25. c    ftb
  26. c    k11hex=k11hex,lb:f4pots/lb
  27. c    /
  28. c    maxbuf=1000
  29. c    //
  30. c
  31. c
  32. c    Be sure to include MAXBUF=1000 for FTB (or TKB) otherwise
  33. c    it won't run.
  34. c
  35. c-    call errset(39,.true.,.false.,.true.,.false.,32000)
  36. c
  37.     write (5,30000)
  38.     read  (5,30010) infil
  39.     write (5,30020)
  40.     read  (5,30010) outfil
  41.     infil(40)  = 0
  42.     outfil(40) = 0
  43. 10    continue
  44.     write (5,30030)
  45.     read  (5,30010) mode
  46.     if (mode.eq.'e' .or. mode.eq.'E') go to 100
  47.     if (mode.eq.'d' .or. mode.eq.'D') go to 200
  48.     type *,'Please enter E for ENCODE or D for DECODE'
  49.     goto 10
  50. c
  51. c
  52. 100    continue
  53.     open    (unit=1,type='OLD',name=infil,access='DIRECT',
  54.     1     recordsize=512/4 ,readonly,form='UNFORMATTED')
  55.     open    (unit=2,type='NEW',name=outfil,carriagecontrol='LIST')
  56.     call crehex
  57.     close (unit=1)
  58.     close (unit=2)
  59.     stop
  60. c
  61. 200    continue
  62.     open    (unit=1,type='OLD',name=infil,readonly,
  63.     1     carriagecontrol='LIST')
  64.     open    (unit=2,type='NEW',name=outfil,access='DIRECT',
  65.     1     recordsize=512/4,form='UNFORMATTED')
  66.     call cretsk
  67.     close (unit=1)
  68.     close (unit=2)
  69.     stop
  70. c
  71. c
  72. c    
  73. c
  74. 30000    format (1x,'Input  file ? '$)
  75. 30010    format (80a1)
  76. 30020    format (1x,'Output file ? '$)
  77. 30030    format (1x,'Encode or Decode ? '$)
  78. c
  79.     end
  80. c
  81. c
  82. c
  83. c
  84.     subroutine crehex
  85.     implicit integer (a-z)
  86.     byte buffer(512)
  87. c
  88. c
  89.     rnum = 1
  90. 10    continue
  91.     read(1'rnum,end=1000,err=1000) buffer
  92.     offset = 1
  93.     do 20 j = 1 , 16
  94.     check = 0
  95.     do 15 k = offset,offset+31
  96.      check = check + ord(buffer(k))
  97. 15    continue
  98.     write(2,30000) (buffer(k),k=offset,offset+31),check
  99.     offset = offset + 32
  100. 20    continue
  101.     rnum = rnum + 1
  102.     go to 10
  103. 1000    type *,'All done'
  104.     return
  105. c
  106. 30000    format (32z2.2,':',z6.6)
  107.     end
  108. c
  109. c
  110. c
  111.     subroutine cretsk
  112.     implicit integer (a-z)
  113.     byte buffer(512)
  114.     byte lbuff(64)
  115.     byte cbuff(6)
  116.     byte chr
  117.     integer chmap(256)
  118.     data chmap /256*0/
  119. c
  120.     chmap(48) = 0
  121.     chmap(49) = 1
  122.     chmap(50) = 2
  123.     chmap(51) = 3
  124.     chmap(52) = 4
  125.     chmap(53) = 5
  126.     chmap(54) = 6
  127.     chmap(55) = 7
  128.     chmap(56) = 8
  129.     chmap(57) = 9
  130.     chmap(65) = 10
  131.     chmap(66) = 11
  132.     chmap(67) = 12
  133.     chmap(68) = 13
  134.     chmap(69) = 14
  135.     chmap(70) = 15
  136. c
  137. c
  138.     rnum = 1
  139. 10    continue
  140.     off = 1
  141.     do 90 j = 1 , 16
  142.       read(1,30010,end=100,err=100) lbuff,cbuff
  143.       i = 1
  144.       do 20 k = off,off+31
  145.        buffer(k) = chr( chmap(lbuff(i))*16 + chmap(lbuff(i+1)) )
  146.        i = i + 2
  147. 20      continue
  148.       check = chmap( cbuff(6) )
  149.      1        + chmap( cbuff(5) ) * 16
  150.      2        + chmap( cbuff(4) ) * 256
  151.      3        + chmap( cbuff(3) ) * 4096
  152. c
  153. c-      read(1,30000,end=100,err=100)(buffer(k),k=off,off+31),check
  154.       comchk = 0
  155.       do 70 k = off,off+31
  156.        comchk = comchk + ord(buffer(k))
  157. 70      continue
  158.       if (comchk.eq.check) go to 80
  159.        type *,'Checksum error ',check,comchk
  160.        stop
  161. 80      continue
  162.       off = off + 32
  163. 90    continue
  164.     write(2'rnum) buffer
  165.     rnum = rnum + 1
  166.     go to 10
  167. c
  168. 100    continue
  169.     type *,'all done'
  170.     type *,'For RSX, please make  the task image  contiguous as in'
  171.     type *,' '
  172.     type *,'   PIP [1,54]KERMIT.TSK/CO=KERMIT.TSK'
  173.     type *,' '
  174.     type *,'For RSTS, make the task contiguous, set the protection'
  175.     type *,'to <104> and the rts name to RSX as in'
  176.     type *,' '
  177.     type *,'   PIP [1,2]KERMIT.TSK<104>/MO:16/RTS:RSX=KERMIT.TSK'
  178.     type *,' '
  179.     return
  180. c
  181. c    for f77 only, the format was '30000    format (32z2,1x,z6)'
  182. c
  183. 30010    format (64a1,1x,6a1)
  184. c
  185.     end
  186. c
  187. c
  188. c
  189.     integer function ord(b)
  190.     byte b
  191.     byte ch(2)
  192.     integer i
  193.     equivalence (ch(1),i)
  194.     ch(1) = b
  195.     ord = i
  196.     return
  197.     end
  198. c
  199. c
  200.     byte function chr(i)
  201.     integer i
  202.     byte b(2)
  203.     integer ch
  204.     equivalence (b(1),ch)
  205.     ch = i
  206.     chr = b(1)
  207.     return
  208.     end
  209.