home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / mskermit / msbpct.for < prev    next >
Text File  |  2020-01-01  |  15KB  |  424 lines
  1. C     PROGRAM BOO2BIN
  2. C
  3. C****** GISBERT W.SELKE (RECK@DBNUAMA1.BITNET), 05/11/87
  4. C     WISSENSCHAFTLICHES INSTITUT DER ORTSKRANKENKASSEN,
  5. C     KORTRIJKER STRASSE 1, D-5300 BONN 2, WEST GERMANY
  6. C     RECK@DBNUAMA1.BITNET
  7. C
  8. C     UNBOOING PROGRAM IN FORTRAN IV
  9. C
  10. C     THIS IS A UTILITY PROGRAMME TO CONVERT THE OUTPUT OF A
  11. C     BOOING PROGRAMME STANDARD ASCII TEXT) BACK INTO BINARY DATA
  12. C     (E.G., THE OUTPUT OF BIN2BOO.FOR)
  13. C
  14. C     IT IS NOT MEANT TO BE A TRANSFER PROTOCOL REPLACEMENT; IT
  15. C     JUST MAKES TRANSFER POSSIBLE ACROSS LINES (E.G., DATA NETWORKS)
  16. C     WHEN NO KERMITS ARE AVAILABLE OR ONE OF THEM CAN'T COPE WITH
  17. C     BINARY STUFF.
  18. C
  19. C     BEWARE OF GREMLINS, THOUGH; ESPECIALLY EBCDIC <-> ASCII
  20. C     TRANSLATION MAY BE A PROBLEM FOR SOME OF THE CHARACTERS ...
  21. C
  22. C     BOO2BIN REVERSES THE FOLLOWING PROCESS:
  23. C     BASICALLY, 3 BYTES = 24 BITS ARE ENCODED INTO 4 CHARACTERS
  24. C     BY DIVIDING THEM INTO 6-BIT-PIECES AND THEN ADDING ASCII-ZERO
  25. C     TO MAKE THESE PIECES PRINTABLE. THE RESULT LIES IN THE RANGE
  26. C     ASCII-ZERO TO ASCII-SMALL-O. - IN ADDITION, NULL COMPRESSION
  27. C     TAKES PLACE; CONSECUTIVE NULL BYTES (WHICH OCCUR FREQUENTLY
  28. C     IN EXECUTABLE FILES, E.G.) ARE ENCODED WITH A TILDE LEAD-IN
  29. C     FOLLOWED BY THE NUMBER OF NULLS (UP TO 78), AGAIN RENDERED
  30. C     PRINTABLE BY ADDING ASCII-ZERO. THE RESULTING CHARACTER IS IN
  31. C     THE RANGE ASCII-ZERO (WELL, ASCII-TWO OR -THREE, REALLY) TO
  32. C     TILDE (ASCII CODE 126). - CHUNKS OF FOUR CHARACTERS BELONGING
  33. C     TOGETHER (RSP. TILDE AND NULL REPEAT COUNT) SHOULD NOT BE
  34. C     DIVIDED ACROSS LINES. A LINE HAS A MAXIMUM LENGTH OF 76
  35. C     CHARACTERS. - IN ADDITION, THE FIRST LINE OF THE FILE CONTAINS
  36. C     THE NAME OF THE ORIGINAL FILE (IF KNOWN - OTHERWISE A DUMMY NAME)
  37. C     AND NOTHING ELSE. THIS LINE IS EFFECTIVELY IGNORED BY THIS
  38. C     PROGRAMME SINCE FORTRAN IV HAS NO WAY OF CREATING FILES; RATHER,
  39. C     AN OUTPUT FILE MUST HAVE BEEN CREATED BEFORE AND MADE AVAILABLE
  40. C     AS I/O UNIT 7. THE ORIGINAL NAME IS OUTPUT TO THE CONTROL CHANNEL
  41. C     FOR DOCUMENTATION PURPOSES ONLY.
  42. C
  43. C     SIBLING PROGRAMMES TO ENCODE BINARY DATA EXIST IN A VARIETY OF
  44. C     LANGUAGES, MOST NOTABLY C, PASCAL, BASIC, AND FORTRAN, OF COURSE.
  45. C
  46. C     THE BOO-FORMAT WAS DEVELOPPED FOR SAFE (WELL, NOT *REALLY* SAFE...)
  47. C     BOOTSTRAPPING PURPOSES DURING KERMIT EVOLUTION BY BILL CATCHINGS
  48. C     AND FRANK DA CRUZ OF COLUMBIA UNIVERSITY, OR SO I THINK.
  49. C
  50. C     THANKS TO FRANK, BILL, DAPHNE AND MANY OTHER PEOPLE FOR ALL
  51. C     THEY'VE DONE TO MAKE LIFE EASIER!
  52. C
  53. C     CERTAIN SYSTEM SPECIFIC FEATURES CANNOT BE AVOIDED; HENCE,
  54. C     YOU SHOULD CHECK THE CODE BELOW CAREFULLY. I HAVE TRIED TO
  55. C     INDICATE THE PLACES WHERE PROBLEMS ARE LIKELY TO OCCUR;
  56. C     THESE INCLUDE WORD-SIZE DEPENDANCIES AND THE WAY BINARY
  57. C     I/O (I.E., UNHAMPERED BY ANY CONTROL CHARACTERS) IS
  58. C     ACCOMPLISHED. ALSO, THE INPUT RECORD SIZE WILL NEED CHECKING.
  59. C
  60. C     AS FAR AS POSSIBLE, PARAMETERS ARE SET IN DATA STATEMENTS IN
  61. C     THE SUBROUTINES TO WHICH THEY PERTAIN; I/O CHANNEL NUMBERS
  62. C     ARE ASSIGNED IN A DATA STATEMENT IN THE MAIN PROGRAMME (BELOW).
  63. C
  64. C     IMPROVEMENTS ARE WELCOME AND SHOULD BE SENT EITHER DIRECTLY
  65. C     TO THE AUTHOR OR TO THE KERMIT MAINTAINERS AT COLUMBIA UNIVERSITY,
  66. C     NEW YORK, USA.
  67. C
  68. C      PARAMETERS ARE SET AS FOLLOWS:
  69. C     INPUT  : I/O UNIT 5; TEXT FILE WITH UP TO 80 CHARACTERS PER LINE
  70. C     OUTPUT : I/O UNIT 7; 256 BYTE RECORDS. MUST HAVE BEEN CREATED EXTERNALLY.
  71. C     CONTROL OUTPUT: I/O UNIT 6 (NOT REALLY NECESSARY)
  72. C
  73. C     NO REWIND WILL BE PERFORMED ON EITHER INPUT OR OUTPUT BEFORE OR
  74. C     AFTER PROCESSING. OUTPUT FILE WILL HAVE A SINGLE FILE MARK AT END.
  75. C
  76. C     ALL VARIABLES ARE ASSUMED TO BE 32-BIT-QUANTITIES
  77. C
  78. C
  79.       IMPLICIT INTEGER*4 (A-Z)
  80.       LOGICAL ZEND
  81.       DIMENSION NAME(12),CHUNK(4),BYTES(3)
  82. C     NOW INITIALIZE SOME PSEUDO-CHARACTER CONSTANTS, RIGHT-JUSTIFIED
  83. C     WITHIN EACH VARIABLE:
  84.       DATA CREP/126/, CZERO/48/, CTILDE/126/, RBYTE/255/, CO/111/
  85.       DATA NULL/0/
  86. C     THE FOLLWOING CONTAINS HEX-07 = BELL AS ITS FIRST BYTE; CHANGE
  87. C     THIS TO 1824, IF YOU'RE WORKING WITH INTEGER*2 VARIABLES:
  88.       DATA BELL/119545888/
  89. C --- I/O UNITS:
  90.       DATA INPUT/5/, OUTPUT/7/, CONTRL/6/
  91. C
  92. C --- INITIALISATION:
  93.       OUTCT = 0
  94.       OUTBYT = 0
  95.       OUTPT = 0
  96.       NULLCT = 0
  97.       ERRCT = 0
  98.       ZEND = .FALSE.
  99.       WRITE (CONTRL,10000)
  100. 10000 FORMAT (//' Conversion from boo to binary format starts.'/)
  101. C --- READ ORIGINAL FILE NAME:
  102.       CALL RDINI(NAME,INPUT,INCT,INCHAR,INPT,BLKCT,CONTRL,ZEND)
  103.       IF (ZEND) GOTO 210
  104.       WRITE (CONTRL,11000) NAME
  105. 11000 FORMAT (' Original file name was ',12A1/)
  106. 10    CONTINUE
  107. C --- MAIN INPUT LOOP:
  108.       CALL RDCHAR(C,INPUT,INCT,INCHAR,INPT,BLKCT,CONTRL,ZEND)
  109.       IF (ZEND) GOTO 200
  110. C --- GOT CHAR; IS IT NULL REPEAT CHAR?
  111.       IF (C.NE.CREP) GOTO 30
  112. C --- YES; GET REPEAT COUNT:
  113.       CALL RDCHAR(C,INPUT,INCT,INCHAR,INPT,BLKCT,CONTRL,ZEND)
  114.       IF (ZEND) GOTO 100
  115. C --- IS IT IN THE PROPER RANGE?
  116.       IF (C.LT.CZERO .OR. C.GT.CTILDE) GOTO 25
  117. C --- YES, OUTPUT PROPER NUMBER OF NULLS:
  118.       IMAX = C - CZERO
  119.       IF (IMAX.EQ.0) GOTO 90
  120.       DO 15 I=1,IMAX
  121.       CALL PUTBYT(NULL,OUTPUT,OUTCT,OUTBYT,OUTPT,CONTRL,ZEND)
  122.       IF (ZEND) GOTO 140
  123. 15    CONTINUE
  124.       NULLCT = NULLCT + IMAX
  125.       GOTO 90
  126. 25    CONTINUE
  127. C --- IMPROPER REPEAT COUNT:
  128.       WRITE (CONTRL,17000) INCT,INPT,C
  129. 17000 FORMAT ('+IMPROPER NULL COUNT AT INPUT LINE',I6,', COLUMN',
  130.      *        I4,': HEX VALUE',Z3/
  131.      *        ' REPEAT COUNT WILL BE IGNORED.'/)
  132.       ERRCT = ERRCT + 1
  133.       GOTO 90
  134. 30    CONTINUE
  135. C --- ORDINARY CHUNK:
  136.       I = 1
  137.       CHUNK(I) = C
  138. C --- ASSEMBLE CHUNK:
  139. 35    CONTINUE
  140.       IF (CHUNK(I).GE.CZERO .AND. CHUNK(I).LE.CO) GOTO 40
  141. C --- IMPROPER CHARACTER:
  142.       WRITE (CONTRL,17100) INCT,INPT,CHUNK(I)
  143. 17100 FORMAT ('+IMPROPER CHARACTER AT INPUT LINE',I6,', COLUMN',
  144.      *        I4,': HEX VALUE',Z3/
  145.      *        ' CHARACTER WILL BE IGNORED.'/)
  146.       ERRCT = ERRCT + 1
  147.       GOTO 45
  148. 40    CONTINUE
  149.       CHUNK(I) = CHUNK(I) - CZERO
  150.       I = I + 1
  151. 45    CONTINUE
  152. C --- GET NEXT CHARACTER, IF NECESSARY:
  153.       IF (I.GT.4) GOTO 50
  154.       CALL RDCHAR(CHUNK(I),INPUT,INCT,INCHAR,INPT,BLKCT,CONTRL,ZEND)
  155.       IF (ZEND) GOTO 120
  156.       GOTO 35
  157. 50    CONTINUE
  158. C --- CHUNK COMPLETE; COMBINE BITS:
  159.       BYTES(1) = IOR(ISHFT(CHUNK(1),2),ISHFT(CHUNK(2),-4))
  160.       BYTES(2) = IAND(IOR(ISHFT(CHUNK(2),4),ISHFT(CHUNK(3),-2)),RBYTE)
  161.       BYTES(3) = IAND(IOR(ISHFT(CHUNK(3),6),CHUNK(4)),RBYTE)
  162. C --- OUTPUT 3 BYTES:
  163.       DO 55 I=1,3
  164.       CALL PUTBYT(BYTES(I),OUTPUT,OUTCT,OUTBYT,OUTPT,CONTRL,ZEND)
  165.       IF (ZEND) GOTO 140
  166. 55    CONTINUE
  167. 90    CONTINUE
  168. C --- LOOP FOR NEXT CHAR:
  169.       GOTO 10
  170. 100   CONTINUE
  171. C --- END OF FILE WITHIN REPEAT SPEC:
  172.       WRITE (CONTRL,17200)
  173. 17200 FORMAT (' INPUT FILE TERMINATED WITHIN NULL REPEAT.',
  174.      *        ' SPECIFICATION.'/)
  175.       ERRCT = ERRCT + 1
  176.       GOTO 200
  177. 120   CONTINUE
  178. C --- END OF FILE WITHIN CHUNK:
  179.       WRITE (CONTRL,17300)
  180. 17300 FORMAT (' INPUT FILE TERMINATED WITHIN CHUNK.'/)
  181.       ERRCT = ERRCT + 1
  182.       GOTO 200
  183. 140   CONTINUE
  184. C --- ERROR ON WRITING TO OUTPUT FILE:
  185.       WRITE (CONTRL,17400)
  186. 17400 FORMAT (/' ERROR ON WRITING TO OUTPUT FILE.'/)
  187.       ERRCT = ERRCT + 1
  188. 200   CONTINUE
  189. C --- END OF FILE; FLUSH OUTPUT BUFFER BY PADDING WITH NULLS:
  190.       CALL FLSHBO(OUTPUT,OUTCT,OUTPT,CONTRL,ZEND)
  191.       WRITE (CONTRL,19000) NAME,INCT,INCHAR,OUTCT,OUTBYT,BLKCT,NULLCT,
  192.      *                     ERRCT
  193. 19000 FORMAT (///' Name of originating file was: ',12A1
  194.      *        /' Number of  input lines  :',I9,
  195.      *         '; number of  input chars:',I9
  196.      *        /' Number of output sectors:',I9,
  197.      *         '; number of output bytes:',I9
  198.      *        /' Number of blanks read   :',I9,
  199.      *         '; number of nulls       :',I9
  200.      *        /' Number of errors        :',I9/)
  201.       IF (ERRCT.GT.0) WRITE (CONTRL,19100) BELL
  202. 19100 FORMAT (' OUTPUT FILE MAY BE INCORRECT.',A1/)
  203. 210   CONTINUE
  204.       STOP
  205.       END
  206. C
  207. C
  208.       SUBROUTINE RDCHAR(C,INPUT,INCT,INCHAR,INPT,BLKCT,CONTRL,ZEND)
  209. C
  210. C     GET A NON-BLANK CHARACTER FROM INPUT; RETURN AS C(1).
  211. C     IF END OF FILE, RETURN ZEND = .TRUE.
  212. C     UPDATE LINES READ (INCT), CHARS READ (INCHAR), POINTER TO INPUT LINE
  213. C     (INPT), NUMBER OF BLANKS READ (BLKCT).
  214. C
  215. C     CALL RDINI FIRST FOR INITIALISATION.
  216. C
  217. C     WILL RETURN ORIGINAL FILE NAME IN C(1)..C(12)
  218. C
  219.       IMPLICIT INTEGER*4 (A-Z)
  220.       LOGICAL ZEND
  221.       DIMENSION C(1),INBUFF(19)
  222. C     PSEUDO-CHARACTER BLANK:
  223.       DATA CBLANK/32/
  224. C
  225. C --- MAKE SURE WE'RE NOT CALLED AFTER END OF FILE:
  226.       C(1) = 0
  227. C     IF (ZFOUND) GOTO 90
  228. 10    CONTINUE
  229.       IF (INPT.GE.BUFLG) GOTO 30
  230. C --- SIMPLY GET FROM BUFFER:
  231.       INPT = INPT + 1
  232.       CALL EXTRCH(C(1),INBUFF,INPT)
  233. C --- IS C BLANK?
  234.       IF (C(1).NE.CBLANK) GOTO 90
  235. C --- YES, TRY AGAIN:
  236.       BLKCT = BLKCT + 1
  237.       GOTO 10
  238. 30    CONTINUE
  239. C --- BUFFER EMPTY; READ NEXT LINE:
  240.       INPT = 0
  241.       INCT = INCT + 1
  242. C --- REPORT PROGRESS ON CONTRL FROM TIME TO TIME:
  243.       IF (MOD(INCT,64).EQ.0) WRITE (CONTRL,13000) INCT
  244. 13000 FORMAT ('+line',I9)
  245. C --- ADAPT IF NECESSARY; SET BUFLG TO ACTUAL NUMBER OF CHARS READ, IF KNOWN:
  246.       READ (INPUT,20000,END=15) INBUFF
  247. 20000 FORMAT (19A4)
  248.       BUFLG = 76
  249.       GOTO 10
  250. 15    CONTINUE
  251. C --- END OF FILE; SORRY, NO MORE CHARS:
  252.       C(1) = 0
  253.       ZEND = .TRUE.
  254.       GOTO 90
  255. C
  256. C --- ENTRY RDINI:
  257. C
  258.       ENTRY RDINI(C,INPUT,INCT,INCHAR,INPT,BLKCT,CONTRL,ZEND)
  259. C
  260.       INCT = 0
  261.       INCHAR = -1
  262.       INPT = 0
  263.       BLKCT = 0
  264.       DO 55 I=1,12
  265. 55    C(I) = CBLANK
  266. C --- ALL INITIALIZATIONS FOR READING THE INPUT FILE GO HERE:
  267. C     ..................
  268. C --- READ FIRST LINE, WHICH WILL CONTAIN ORIGINAL FILE NAME:
  269. C --- ADAPT IF NECESSARY; SET BUFLG TO NUMBER OF CHARS ACTUALLY READ:
  270.       READ (INPUT,20000,END=70) INBUFF
  271.       BUFLG = 76
  272.       IF (BUFLG.GT.12) BUFLG = 12
  273. C --- WRITE NAME LEFT-JUSTIFIED INTO ARRAY C, ONE CHAR PER ELEMENT:
  274.       DO 60 I=1,BUFLG
  275.       CALL EXTRCH(C(I),INBUFF,I)
  276.       C(I) = ISHFT(C(I),24)
  277. 60    CONTINUE
  278. C --- ADAPT IF NECESSARY; SET BUFLG TO NUMBER OF CHARS ACTUALLY READ:
  279.       READ (INPUT,20000,END=65) INBUFF
  280.       BUFLG = 76
  281.       GOTO 90
  282. 65    CONTINUE
  283.       ZEND = .TRUE.
  284.       GOTO 90
  285. 70    CONTINUE
  286. C --- EMPTY INPUT FILE:
  287.       ZEND = .TRUE.
  288.       WRITE (CONTRL,17500)
  289. 17500 FORMAT (/' EMPTY INPUT FILE.'/)
  290. 90    CONTINUE
  291.       INCHAR = INCHAR + 1
  292.       RETURN
  293.       END
  294. C
  295. C
  296.       SUBROUTINE PUTBYT(BYTE,OUTPUT,OUTCT,OUTBYT,OUTPT,CONTRL,ZEND)
  297. C
  298. C     OUTPUTS ONE BYTE, UPDATES COUNT OF SECTORS (OUTCT), COUNT OF OUTPUT
  299. C     BYTES (OUTBYT) (EVEN IF THAT'S NEARLY REDUNDANT...); AND POINTER
  300. C     INTO OUTPUT BUFFER (OUTPT).
  301. C     ENTRY FLSHBO MUST BE CALLED TO FINISH OFF.
  302. C
  303.       IMPLICIT INTEGER*4 (A-Z)
  304.       LOGICAL ZEND
  305.       DIMENSION SECTOR(64),UFT(5)
  306. C     LBIT IS GOING TO BE A VARIABLE WITH ONLY THE LEFT-MOST BIT SET;
  307. C     UNFORTUNATELY, ON MANY COMPILERS SUCH A VALUE CANNOT BE SPECIFIED
  308. C     WITHOUT SUBTERFUGE. HENCE, WE INITIALIZE RBIT TO 1 AND LATER SET
  309. C     LBIT TO RBIT, SHIFTED LEFT BY 31 POSITIONS. (IF YOU USE INTEGER*2
  310. C     VARIABLES, YOU WILL WANT TO CHANGE THAT TO 15 POSITIONS.)
  311. C     IF YOUR MACHINE DOESN'T USE TWO'S COMPLEMENT, YOU HAVE TO START
  312. C     THINKING YOURSELF:
  313.       DATA RBIT/1/
  314.       DATA NULL/0/
  315. C --- SECLEN IS NUMBER OF BYTES IN A TYPICAL, FIXED-LENGTH BINARY RECORD:
  316. C     IT CORRESPONDS TO LENGTH OF ARRAY SECTOR MEASURED IN BYTES;
  317. C     OPTION IS NEEDED FOR MODCOMP ONLY:
  318.       DATA SECLEN/256/, OPTION/36864/
  319. C
  320. C --- NOW SET LBIT TO WHAT IT ALWAYS SHOULD HAVE BEEN:
  321.       LBIT = ISHFT(RBIT,31)
  322.       IF (OUTPT.LT.SECLEN) GOTO 20
  323. C --- OUTPUT BUFFER IS FULL; WRITE A BINARY RECORD:
  324.       IF (OUTCT.NE.0) GOTO 10
  325. C --- ON FIRST CALL, INITIALIZE OUTPUT FILE FOR WRITING BINARY RECORDS;
  326. C     WRITING MUST BE UNDISTURBED BY ANY CONTROL CHARACTERS.
  327. C --- ON MODCOMP, THAT MEANS INITIALIZING A UFT; REPLACE WITH WHATEVER
  328. C     YOU NEED:
  329.       CALL BLDUFT(UFT,0,ICAN4(OUTPUT),OPTION)
  330. 10    CONTINUE
  331. C --- DO A BINARY WRITE OF SECLEN BYTES = ONE RECORD:
  332. C     AGAIN, REPLACE WITH WHATEVER YOU NEED. MAYBE A PLAIN WRITE WITH
  333. C     FORMAT (64A4) WILL DO FOR YOU.
  334.       CALL WRITE4(UFT,SECTOR,SECLEN)
  335. C --- CHECK FOR ERROR CONDITION; ADAPT OR OMIT:
  336.       IF (IAND(UFT(1),LBIT).NE.0) GOTO 80
  337.       OUTCT = OUTCT + 1
  338.       OUTPT = 0
  339. 20    CONTINUE
  340. C --- MOVE BYTE TO OUTPUT BUFFER:
  341.       OUTBYT = OUTBYT + 1
  342.       OUTPT = OUTPT + 1
  343.       CALL INSRCH(BYTE,SECTOR,OUTPT)
  344.       GOTO 90
  345. C
  346. C --- ENTRY FLSHBO:
  347. C
  348.       ENTRY FLSHBO(OUTPUT,OUTCT,OUTPT,CONTRL,ZEND)
  349. C
  350.       IF (OUTCT.NE.0) GOTO 25
  351. C --- JUST TO MAKE SURE, IF THE FILE WAS VERY SHORT:
  352. C --- ANOTHER COPY OF THE INITIALIZATION STATEMENTS; CF. ABOVE:
  353.       CALL BLDUFT(UFT,0,ICAN4(OUTPUT),OPTION)
  354. 25    CONTINUE
  355.       IF (OUTPT.EQ.SECLEN) GOTO 40
  356. C --- PAD WITH NULLS:
  357.       IMAX = SECLEN - OUTPT
  358.       DO 30 I=1,IMAX
  359.       CALL INSRCH(NULL,SECTOR,OUTPT+I)
  360. 30    CONTINUE
  361.       OUTPT = SECLEN
  362. 40    CONTINUE
  363. C --- BINARY WRITE OF SECLEN BYTES = ONE RECORD; ADAPT IF NECESSARY
  364. C     (CF. ABOVE).
  365.       CALL WRITE4(UFT,SECTOR,SECLEN)
  366. C --- CHECK FOR ERROR CONDITION; ADAPT OR OMIT:
  367.       IF (IAND(UFT(1),LBIT).NE.0) GOTO 80
  368.       OUTCT = OUTCT + 1
  369.       OUTPT = 0
  370. C --- CLOSE OUTPUT FILE IN AN ORDERLY FASHION:
  371.       ENDFILE OUTPUT
  372.       GOTO 90
  373. 80    CONTINUE
  374.       WRITE (CONTRL,13700)
  375. 13700 FORMAT (/' ERROR ON WRITING TO OUTPUT FILE.'/)
  376.       ZEND = .TRUE.
  377. 90    CONTINUE
  378.       RETURN
  379.       END
  380. C
  381. C
  382.       SUBROUTINE EXTRCH(C,BUFFER,POS)
  383. C
  384. C     GET POS-TH BYTE FROM BUFFER, RETURN IT RIGHT-JUSTIFIED WITHIN C:
  385. C
  386.       IMPLICIT INTEGER*4 (A-Z)
  387.       DIMENSION BUFFER(1)
  388. C     THE LAST 8 BITS:
  389.       DATA RBYTE/255/
  390. C
  391.       I = (POS+3) / 4
  392.       K = POS - 4*(I-1)
  393.       C = BUFFER(I)
  394. C --- NOW SHIFT; BUT FOR THE BENEFIT OF SOME FAULTY COMPILERS,
  395. C     DONT'T IF SHIFT COUNT IS 0:
  396.       IF (K.NE.4) C = ISHFT(C,8*K-32)
  397.       C = IAND(C,RBYTE)
  398.       RETURN
  399.       END
  400. C
  401. C
  402.       SUBROUTINE INSRCH(C,BUFFER,POS)
  403. C
  404. C     INSERT RIGHT-MOST BYTE OF C INTO POS-TH BYTE OF BUFFER.
  405. C     ASSUME C IS 0 IN 3 FIRST BYTES AND THERE ARE NO SIGNIFICANT BYTES
  406. C     AFTER POS IN BUFFER
  407. C
  408.       IMPLICIT INTEGER*4 (A-Z)
  409.       DIMENSION BUFFER(1)
  410. C     A VARIABLE WITH EACH AND EVERY BIT SET; IF YOUR MACHINE DOESN'T USE
  411. C     TWO'S COMPLEMENT, YOU GOT TO DO SOME MORE THINKING:
  412.       DATA FULLBT/-1/
  413. C
  414.       I = (POS+3)/4
  415.       K = POS - 4*(I-1)
  416.       CA = C
  417. C --- NOW SHIFT; BUT FOR THE BENEFIT OF SOME FORTRAN COMPILERS,
  418. C     DON'T IF SHIFT COUNT IS ZERO:
  419.       IF (K.NE.4) CA = ISHFT(CA,32-8*K)
  420.       MASK = ISHFT(FULLBT,40-8*K)
  421.       BUFFER(I) = IOR(IAND(BUFFER(I),MASK),CA)
  422.       RETURN
  423.       END
  424.