program k11hex c c c 02-Mar-84 13:50:23 Brian Nelson c c c Written in Fortran-77 since if written it in MACRO-11 I c would need two versions (one for RSX and RSTS and another c for RT) c c pack and unpack the so-called HEX file for kermit c byte mode byte infil(40),outfil(40) c c note: For encoding, RT fortran does not know about c eof for direct access files. Will have to fix c for RT when I get the rt version done. c c c c to compile: c c f77 k11hex=k11hex c ftb c k11hex=k11hex,lb:f4pots/lb c / c maxbuf=1000 c // c c c Be sure to include MAXBUF=1000 for FTB (or TKB) otherwise c it won't run. c c- call errset(39,.true.,.false.,.true.,.false.,32000) c write (5,30000) read (5,30010) infil write (5,30020) read (5,30010) outfil infil(40) = 0 outfil(40) = 0 10 continue write (5,30030) read (5,30010) mode if (mode.eq.'e' .or. mode.eq.'E') go to 100 if (mode.eq.'d' .or. mode.eq.'D') go to 200 type *,'Please enter E for ENCODE or D for DECODE' goto 10 c c 100 continue open (unit=1,type='OLD',name=infil,access='DIRECT', 1 recordsize=512/4 ,readonly,form='UNFORMATTED') open (unit=2,type='NEW',name=outfil,carriagecontrol='LIST') call crehex close (unit=1) close (unit=2) stop c 200 continue open (unit=1,type='OLD',name=infil,readonly, 1 carriagecontrol='LIST') open (unit=2,type='NEW',name=outfil,access='DIRECT', 1 recordsize=512/4,form='UNFORMATTED') call cretsk close (unit=1) close (unit=2) stop c c c c 30000 format (1x,'Input file ? '$) 30010 format (80a1) 30020 format (1x,'Output file ? '$) 30030 format (1x,'Encode or Decode ? '$) c end c c c c subroutine crehex implicit integer (a-z) byte buffer(512) c c rnum = 1 10 continue read(1'rnum,end=1000,err=1000) buffer offset = 1 do 20 j = 1 , 16 check = 0 do 15 k = offset,offset+31 check = check + ord(buffer(k)) 15 continue write(2,30000) (buffer(k),k=offset,offset+31),check offset = offset + 32 20 continue rnum = rnum + 1 go to 10 1000 type *,'All done' return c 30000 format (32z2.2,':',z6.6) end c c c subroutine cretsk implicit integer (a-z) byte buffer(512) byte lbuff(64) byte cbuff(6) byte chr integer chmap(256) data chmap /256*0/ c chmap(48) = 0 chmap(49) = 1 chmap(50) = 2 chmap(51) = 3 chmap(52) = 4 chmap(53) = 5 chmap(54) = 6 chmap(55) = 7 chmap(56) = 8 chmap(57) = 9 chmap(65) = 10 chmap(66) = 11 chmap(67) = 12 chmap(68) = 13 chmap(69) = 14 chmap(70) = 15 c c rnum = 1 10 continue off = 1 do 90 j = 1 , 16 read(1,30010,end=100,err=100) lbuff,cbuff i = 1 do 20 k = off,off+31 buffer(k) = chr( chmap(lbuff(i))*16 + chmap(lbuff(i+1)) ) i = i + 2 20 continue check = chmap( cbuff(6) ) 1 + chmap( cbuff(5) ) * 16 2 + chmap( cbuff(4) ) * 256 3 + chmap( cbuff(3) ) * 4096 c c- read(1,30000,end=100,err=100)(buffer(k),k=off,off+31),check comchk = 0 do 70 k = off,off+31 comchk = comchk + ord(buffer(k)) 70 continue if (comchk.eq.check) go to 80 type *,'Checksum error ',check,comchk stop 80 continue off = off + 32 90 continue write(2'rnum) buffer rnum = rnum + 1 go to 10 c 100 continue type *,'all done' type *,'For RSX, please make the task image contiguous as in' type *,' ' type *,' PIP [1,54]KERMIT.TSK/CO=KERMIT.TSK' type *,' ' type *,'For RSTS, make the task contiguous, set the protection' type *,'to <104> and the rts name to RSX as in' type *,' ' type *,' PIP [1,2]KERMIT.TSK<104>/MO:16/RTS:RSX=KERMIT.TSK' type *,' ' return c c for f77 only, the format was '30000 format (32z2,1x,z6)' c 30010 format (64a1,1x,6a1) c end c c c integer function ord(b) byte b byte ch(2) integer i equivalence (ch(1),i) ch(1) = b ord = i return end c c byte function chr(i) integer i byte b(2) integer ch equivalence (b(1),ch) ch = i chr = b(1) return end