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