SUBROUTINE W3FI32(LARRAY,KIDNT)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: W3FI32 PACK ID'S INTO OFFICE NOTE 84 FORMAT
C PRGMMR: NIEROW, A. ORG: W345 DATE: 86-02-07
C
C ABSTRACT: CONVERTS AN ARRAY OF THE 27 DATA FIELD IDENTIFIERS INTO
C AN ARRAY OF THE FIRST 8 IDENTIFICATION WORDS OF THE FORMAT DE-
C SCRIBED IN NMC OFFICE NOTE 84 (89-06-15, PAGE-35). ON A CRAY
C THEY WILL FIT INTO FOUR 64 BIT INTEGER WORDS.
C
C PROGRAM HISTORY LOG:
C 86-02-07 A.NIEROW
C 89-10-24 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN
C 91-03-19 R.E.JONES CHANGES FOR BIG RECORDS
C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE
C 1999-03-15 Gilbert Specified 8-byte integer array explicitly
C
C USAGE: CALL W3FI32(LARRAY, KIDNT)
C INPUT ARGUMENT LIST:
C LARRAY - INTEGER ARRAY CONTAINING 27 DATA FIELD
C IDENTIFIERS (SEE O.N. 84)
C
C OUTPUT ARGUMENT LIST:
C KIDNT - INTEGER ARRAY OF 6 WORDS, 12 OFFICE NOTE 84 32 BIT
C WORDS, FIRST 4 WORDS ARE MADE BY W3FI32, IF YOU ARE
C USING PACKER W3AI00, IT WILL COMPUTE WORD 5 AND 6.
C (OFFICE NOTE 84 WORDS 9,10, 11 AND 12). IF J THE
C WORD COUNT IN WORD 27 OF LARRAY IS GREATER THAN
C 32743 THEN BITS 15-0 OF THE 4TH ID WORD ARE SET TO
C ZERO, J IS STORED IN BITS 31-0 OF THE 6TH ID WORD.
C ID WORD 5 IS SET ZERO, BIT 63-32 OF THE 6TH ID
C WORD ARE SET ZERO. NOTE: BIS ARE NUMBER LEFT TO
C RIGHT ON THE CRAY AS 63-0.
C
C OUTPUT FILES:
C UNIT6 - STANDARD FORTRAN PRINT FILE
C
C SUBPROGRAMS CALLED:
C LIBRARY:
C BIT MANIPULATION - IAND, IOR ISHFT
C
C REMARKS: EXIT STATES PRINTED MESSAGES:
C IF ANY NUMBER N IN (LARRAY(I),I=1,27) IS ERRONEOUSLY LARGE:
C 'VALUE IN LARRAY(I)=N IS TOO LARGE TO PACK'
C IF ANY NUMBER N IN (LARRAY(I),I=1,27) IS ERRONEOUSLY NEGATIVE:
C 'VALUE IN LARRAY(I)=N SHOULD NOT BE NEGATIVE'
C IN EITHER OF THE ABOVE SITUATIONS, THAT PORTION OF THE PACKED
C WORD CORRESPONDING TO LARRAY(I) WILL BE SET TO BINARY ONES.
C
C ATTRIBUTES:
C LANGUAGE: CRAY CFT77 FORTRAN INTEGER=64
C MACHINE: CRAY Y-MP8/864
C
C$$$
C
INTEGER(8) LARRAY(27)
INTEGER(8) ITABLE(27)
INTEGER(8) KIDNT(*)
INTEGER(8) KX,MASK,MASK16,ISC,ITEMP8
C
SAVE
C
DATA ITABLE/X'0000000000340C01',X'0000000000280C01',
& X'0000000000200801',X'00000000001C0401',
& X'0000000001081401',X'0000000001000801',
& X'00000000003C0402',X'0000000000340802',
& X'0000000000280C02',X'0000000000200802',
& X'00000000001C0402',X'0000000001081402',
& X'0000000001000802',X'0000000000380803',
& X'0000000000300803',X'0000000000280803',
& X'0000000000200803',X'00000000001C0403',
& X'0000000000100C03',X'0000000000001003',
& X'0000000000380804',X'0000000000300804',
& X'0000000000280804',X'0000000000200804',
& X'0000000000180804',X'0000000000100804',
& X'0000000000001004'/
DATA KX /X'00000000FFFFFFFF'/
DATA MASK /X'00000000000000FF'/
DATA MASK16/X'FFFFFFFFFFFF0000'/
C
C MAKE KIDNT = 0
C
DO 10 I = 1,4
KIDNT(I) = 0
10 CONTINUE
C
ISIGN = 0
C
DO 90 I = 1,27
ISC = ITABLE(I)
I1 = IAND(ISC,MASK)
I2 = IAND(ISHFT(ISC,-8_8), MASK)
I3 = IAND(ISHFT(ISC,-16_8),MASK)
I4 = IAND(ISHFT(ISC,-24_8),MASK)
C
C SIGN TEST
C
IV = LARRAY(I)
IF (IV.GE.0) GO TO 50
IF (I4.NE.0) GO TO 30
WRITE (6,20) I, IV
20 FORMAT(/,1X,' W3FI32 - VALUE IN LARRAY(',I2,') =',I11,
& ' SHOULD NOT BE NEGATIVE',/)
GO TO 70
C
30 CONTINUE
IV = IABS(IV)
MSIGN = 1
ISIGN = MSIGN
K = I2 / 4
C
DO 40 M = 1,K
ISIGN = ISHFT(ISIGN,4)
40 CONTINUE
C
ISIGN = ISHFT(ISIGN,-1)
IV = IOR(IV,ISIGN)
C
50 CONTINUE
C
C MAG TEST
C
IF (ISHFT(IV,-I2).EQ.0) GO TO 80
IF (LARRAY(27).GT.32743) GO TO 70
PRINT 60, I , IV
60 FORMAT(/,1X,' W3FI32 - VALUE IN LARRAY(',I2,') =',I11,
& ' IS TOO LARGE TO PACK',/)
C
70 CONTINUE
IV = KX
IA = 32 - I2
IV = ISHFT(IV,-IA)
C
C SHIFT
C
80 CONTINUE
ITEMP=ISHFT(IV,I3)
ITEMP8=ITEMP
KIDNT(I1) = IOR(KIDNT(I1),ITEMP8)
C
90 CONTINUE
C
C TEST FOR BIG RECORDS, STORE J THE WORD COUNT IN THE 6TH
C ID WORD IF GREATER THAN 32743.
C
IF (LARRAY(27).EQ.0) THEN
PRINT *,' W3FI32 - ERROR, WORD COUNT J = 0'
ELSE IF (LARRAY(27).GT.32743) THEN
KIDNT(4) = IAND(KIDNT(4),MASK16)
KIDNT(5) = 0
KIDNT(6) = LARRAY(27)
END IF
C
RETURN
END