SUBROUTINE W3AI40(KFLD,KOUT,KLEN,KNUM,KOFF) C$$$ SUBPROGRAM DOCUMENTATION BLOCK *** C . . . . C SUBPROGRAM: W3AI41 CONSTANT SIZE BINARY STRING PACKER C PRGMMR: ALLARD, R. ORG: W342 DATE: 80-04-01 C C C ABSTRACT: PACKS CONSTANT SIZE BINARY STRINGS INTO AN ARRAY. THIS C PACKING REPLACES BITS IN THE PART OF THE OUTPUT ARRAY INDICATED C BY THE OFFSET VALUE. W3AI40 IS THE REVERSE OF W3AI41. (SEE W3AI32 C TO PACK VARIABLE SIZE BINARY STRINGS.) C C PROGRAM HISTORY LOG: C 80-04-01 R.ALLARD (ORIGINAL AUTHOR) ASMEMBLER LANGUAGE VERSION. C 84-07-05 R.E.JONES RECOMPILED FOR NAS-9050 C 89-11-04 R.E.JONES WROTE FORTRAN VERSION OF W3AI40 TO PACK C CONSTANT SIZE BINARY STRINGS C 89-11-05 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE C C USAGE: CALL W3AI40 (KFLD,KOUT,KLEN,KNUM,KOFF) C C INPUT: C KFLD - INTEGER INPUT ARRAY OF RIGHT ADJUSTED STRINGS C KLEN - INTEGER NUMBER OF BITS PER STRING (0 < KLEN < 33) C KNUM - INTEGER NUMBER OF STRINGS IN 'KFLD' TO PACK C KOFF - INTEGER NUMBER SPECIFYING THE BIT OFFSET OF THE C FIRST OUTPUT STRING. THE OFFSET VALUE IS RESET TO C INCLUDE THE LOW ORDER BIT OF THE LAST PACKED STRING C OUTPUT: C KOUT - INTEGER OUTPUT ARRAY TO HOLD PACKED STRING(S) C C EXIT STATES: C ERROR - KOFF < 0 IF KLEN HAS AN ILLEGAL VALUE OR KNUM < 1 C THEN KOUT HAS NO STRINGS STORED. C C EXTERNAL REFERENCES: NONE C C REMARKS: THIS SUBROUTINE SHOULD BE WRITTEN IN ASSEMBLER LANGUAGE. C THE FORTRAN VERSION RUNS TWO OR THREE TIMES SLOWER THAN THE ASEMBLER C VERSION. THE FORTRAN VERSION CAN BE CONVERTED TO RUN ON OTHER C COMPUTERS WITH A FEW CHANGES. THE BIT MANIPULATION FUNCTIONS ARE THE C SAME IN IBM370 VS FORTRAN 4.1, MICROSOFT FORTRAN 4.10, VAX FORTRAN. C MOST MODERN FORTRAN COMPILER HAVE AND, OR, SHIFT FUNCTIONS. IF YOU C ARE RUNNING ON A PC, VAX AND YOUR INPUT WAS MADE ON A IBM370, APOLLO C SUN, H.P.. ETC. YOU MAY HAVE TO ADD MORE CODE TO REVERSE THE ORDER O C BYTES IN AN INTEGER WORD. NCAR SBYTES CAN BE USED INSTEAD OF THIS C SUBROUTINE. PLEASE USE NCAR SBYTES SUBROUTINE INSTEAD OF THIS C SUBROUTINE. C C ATTRIBUTES: C LANGUAGE: CRAY CFT77 FORTRAN C MACHINE: CRAY Y-MP8/832 C C$$$ C INTEGER KFLD(*) INTEGER KOUT(*) INTEGER BIT INTEGER OFFSET INTEGER WRD C DATA MASK /-1/ C OFFSET = KOFF IF (OFFSET.LT.0) RETURN IF (KLEN.GT.64.OR.KLEN.LT.1) THEN KOFF = -1 RETURN ENDIF C IF (KNUM.LT.1) THEN KOFF = -1 RETURN ENDIF C JCOUNT = 64 - KLEN LENGTH = KLEN MASKWD = ISHFT(MASK,JCOUNT) C DO 100 I = 1,KNUM WRD = ISHFT(OFFSET,-6) + 1 BIT = MOD(OFFSET,64) MASK8 = NOT(ISHFT(MASKWD,-BIT)) OFFSET = OFFSET + LENGTH JTEMP = IAND(KOUT(WRD),MASK8) NCOUNT = 64 - BIT IF (NCOUNT.LT.LENGTH) THEN MASK9 = NOT(ISHFT(MASKWD,NCOUNT)) NTEMP = IAND(KOUT(WRD+1),MASK9) ENDIF ITEMP = ISHFT(ISHFT(KFLD(I),JCOUNT),-BIT) KOUT(WRD) = IOR(ITEMP,JTEMP) IF (NCOUNT.LT.LENGTH) THEN ITEMP = ISHFT(KFLD(I),(JCOUNT+NCOUNT)) KOUT(WRD+1) = IOR(ITEMP,NTEMP) ENDIF 100 CONTINUE KOFF = OFFSET RETURN END