SUBROUTINE WRITDX(LUNIT,LUN,LUNDX) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C C SUBPROGRAM: WRITDX C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06 C C ABSTRACT: THIS SUBROUTINE WRITES BUFR TABLE (DICTIONARY) MESSAGES TO C THE BEGINNING OF AN OUTPUT BUFR FILE IN LUNIT. THE TABLE MESSAGES C ARE READ FROM ARRAYS IN INTERNAL MEMORY (COMMON BLOCK /TABABD/). C AN INITIAL CALL TO BUFR ARCHIVE LIBRARY SUBROUTINE READDX GENERATES C THESE INTERNAL ARRAYS. C C PROGRAM HISTORY LOG: C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR C 1995-06-28 J. WOOLLEN -- INCREASED THE SIZE OF INTERNAL BUFR TABLE C ARRAYS IN ORDER TO HANDLE BIGGER FILES C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB C ROUTINE "BORT" C 1999-11-18 J. WOOLLEN -- THE NUMBER OF BUFR FILES WHICH CAN BE C OPENED AT ONE TIME INCREASED FROM 10 TO 32 C (NECESSARY IN ORDER TO PROCESS MULTIPLE C BUFR FILES UNDER THE MPI) C 2000-09-19 J. WOOLLEN -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 10,000 TO 20,000 BYTES C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE C INTERDEPENDENCIES C 2003-11-04 D. KEYSER -- UNIFIED/PORTABLE FOR WRF; ADDED C DOCUMENTATION (INCLUDING HISTORY); OUTPUTS C MORE COMPLETE DIAGNOSTIC INFO WHEN ROUTINE C TERMINATES ABNORMALLY C 2004-08-09 J. ATOR -- MAXIMUM MESSAGE LENGTH INCREASED FROM C 20,000 TO 50,000 BYTES C C USAGE: CALL WRITDX (LUNIT, LUN, LUNDX) C INPUT ARGUMENT LIST: C LUNIT - INTEGER: FORTRAN LOGICAL UNIT NUMBER FOR BUFR FILE C BEING WRITTEN C LUN - INTEGER: I/O STREAM INDEX INTO INTERNAL MEMORY ARRAYS C (ASSOCIATED WITH FILE CONNECTED TO LOGICAL UNIT LUNIT) C LUNDX - INTEGER: FORTRAN LOGICAL UNIT NUMBER CONTAINING C DICTIONARY TABLE INFORMATION TO BE USED (BY READDX) TO C CREATE INTERNAL TABLES WRITTEN TO LUNIT (SEE READDX); C IF SET EQUAL TO LUNIT, THIS SUBROUTINE CALLS BORT C C REMARKS: C THIS ROUTINE CALLS: ADN30 BORT DXMINI IPKM C IUPM MSGWRT PKB PKC C READDX C THIS ROUTINE IS CALLED BY: OPENBF C Normally not called by any application C programs. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 C MACHINE: PORTABLE TO ALL PLATFORMS C C$$$ INCLUDE 'bufrlib.prm' COMMON /TABABD/ NTBA(0:NFILES),NTBB(0:NFILES),NTBD(0:NFILES), . MTAB(MAXTBA,NFILES),IDNA(MAXTBA,NFILES,2), . IDNB(MAXTBB,NFILES),IDND(MAXTBD,NFILES), . TABA(MAXTBA,NFILES),TABB(MAXTBB,NFILES), . TABD(MAXTBD,NFILES) COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), . LD30(10),DXSTR(10) CHARACTER*600 TABD CHARACTER*128 BORT_STR CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*56 DXSTR CHARACTER*6 ADN30 CHARACTER*1 MOCT(MXMSGL) DIMENSION MBAY(MXMSGLD4) EQUIVALENCE (MOCT(1),MBAY(1)) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK UNITS, TABLE MUST BE COMING FROM AN INPUT FILE C ---------------------------------------------------- IF(LUNIT.EQ.LUNDX) GOTO 900 C MUST FIRST CALL READDX TO GENERATE INTERNAL DICTIONARY TABLE C ------------------------------------------------------------ CALL READDX(LUNIT,LUN,LUNDX) C NEXT CALL DXMINI TO WRITE PRELIMINARY INFO TO BUFR DICTIONARY MESSAGE C --------------------------------------------------------------------- CALL DXMINI(LUN,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD) LDA = LDXA(IDXV+1) LDB = LDXB(IDXV+1) LDD = LDXD(IDXV+1) L30 = LD30(IDXV+1) C COPY TABLE A CONTENTS TO A BUFR DICTIONARY MESSAGE C -------------------------------------------------- DO I=1,NTBA(LUN) IF(MBYT+LDA+8.GT.MAXDX) THEN CALL MSGWRT(LUNIT,MBAY,MBYT) CALL DXMINI(LUN,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD) ENDIF CALL IPKM(MOCT(MBY4),3,IUPM(MOCT(MBY4),24)+LDA) CALL IPKM(MOCT(MBYA),1,IUPM(MOCT(MBYA), 8)+ 1) MBIT = 8*(MBYB-1) CALL PKC(TABA(I,LUN),LDA,MBAY,MBIT) CALL PKB( 0, 8,MBAY,MBIT) CALL PKB( 0, 8,MBAY,MBIT) MBYT = MBYT+LDA MBYB = MBYB+LDA MBYD = MBYD+LDA ENDDO C COPY TABLE B CONTENTS TO A BUFR DICTIONARY MESSAGE C -------------------------------------------------- DO I=1,NTBB(LUN) IF(MBYT+LDB+8.GT.MAXDX) THEN CALL MSGWRT(LUNIT,MBAY,MBYT) CALL DXMINI(LUN,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD) ENDIF CALL IPKM(MOCT(MBY4),3,IUPM(MOCT(MBY4),24)+LDB) CALL IPKM(MOCT(MBYB),1,IUPM(MOCT(MBYB), 8)+ 1) MBIT = 8*(MBYD-1) CALL PKC(TABB(I,LUN),LDB,MBAY,MBIT) CALL PKB( 0, 8,MBAY,MBIT) MBYT = MBYT+LDB MBYD = MBYD+LDB ENDDO C COPY TABLE D CONTENTS TO A BUFR DICTIONARY MESSAGE C -------------------------------------------------- DO I=1,NTBD(LUN) NSEQ = IUPM(TABD(I,LUN)(LDD+1:LDD+1),8) LEND = LDD+1 + L30*NSEQ IF(MBYT+LEND+8.GT.MAXDX) THEN CALL MSGWRT(LUNIT,MBAY,MBYT) CALL DXMINI(LUN,MBAY,MBYT,MBY4,MBYA,MBYB,MBYD) ENDIF CALL IPKM(MOCT(MBY4),3,IUPM(MOCT(MBY4),24)+LEND) CALL IPKM(MOCT(MBYD),1,IUPM(MOCT(MBYD), 8)+ 1) MBIT = 8*(MBYT-4) CALL PKC(TABD(I,LUN),LDD,MBAY,MBIT) CALL PKB( NSEQ, 8,MBAY,MBIT) DO J=1,NSEQ JJ = LDD+2 + (J-1)*2 IDN = IUPM(TABD(I,LUN)(JJ:JJ),16) CALL PKC(ADN30(IDN,L30),L30,MBAY,MBIT) ENDDO MBYT = MBYT+LEND ENDDO C WRITE THE UNWRITTEN MESSAGE C --------------------------- CALL MSGWRT(LUNIT,MBAY,MBYT) C EXITS C ----- RETURN 900 WRITE(BORT_STR,'("BUFRLIB: WRITDX - FILES CONTAINING BUFR DATA '// . 'AND DICTIONARY TABLE CANNOT BE THE SAME (HERE BOTH SHARE '// . 'FORTRAN UNIT NUMBER ",I3,")")') LUNIT CALL BORT(BORT_STR) END