SUBROUTINE GRIBIT(IFLD,ILVL,GRID,IMOUT,JMOUT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . C SUBPROGRAM: GRIBIT POST FIELDS IN GRIB1 C PRGRMMR: TREADON ORG: W/NP2 DATE: 93-06-18 C C ABSTRACT: C THIS ROUTINE POSTS THE DATA IN THE PASSED ARRAY GRID C TO THE OUTPUT FILE IN GRIB1 FORMAT. C C PROGRAM HISTORY LOG: C 93-06-18 RUSS TREADON C 93-11-23 RUSS TREADON - REMOVED CODE GENERATING GRIB INDEX FILE. C 98-07-17 MIKE BALDWIN - REMOVED LABL84, NOW USING ID C 02-06-17 MIKE BALDWIN - WRF VERSION C 05-12-05 H CHUANG - ADD CAPABILITY TO OUTPUT OFF-HOUR FORECAST WHICH HAS c NO INPACTS ON ON-HOUR FORECAST C C USAGE: CALL GRIBIT(IFLD,ILVL,GRID,IMOUT,JMOUT) C INPUT ARGUMENT LIST: C IFLD - FIELD ID TAG. C ILVL - INTEGER TAG FOR LEVEL OF FIELD. C GRID - FIELD TO BE POSTED IN GRIB. C IMOUT - FIRST DIMENSION OF OUTPUT GRID. C JMOUT - SECOND DIMENSION OF OUTPUT GRID. C C OUTPUT ARGUMENT LIST: C C OUTPUT FILES: C C SUBPROGRAMS CALLED: C UTILITIES: C GETENV - CRAY SUBROUTINE TO GET VALUE OF ENVIRONMENT VARIABLE. C MINMAX - DETERMINES MIN/MAX VALUES IN AN ARRAY. C WRYTE - WRITE DATA OUT BY BYTES. C GET_BITS - COMPUTE NUMBER OF BITS C VARIOUS W3LIB ROUTINES C LIBRARY: C COMMON - CTLBLK C RQSTFLD C C ATTRIBUTES: C LANGUAGE: FORTRAN C MACHINE : CRAY C-90 C$$$ C C C INCLUDE 'mpif.h' C C INCLUDE GRID DIMENSIONS. SET/DERIVE PARAMETERS. C ! INCLUDE "parmeta" ! INCLUDE "parmout" common/jjt/time_output, time_e2out ! PARAMETER (LP1=LM+1,D01=0.01,D50=0.5E0) ! PARAMETER (D01=0.01,D50=0.5E0) ! PARAMETER (IMT=2*IM-1,JMT=JM,IMJMT=IMT*JMT) ! PARAMETER (SMALL=1.E-6) C C GRIB1 PARAMETERS. C MNBIT = MINIMUM NUMBER OF BITS TO USE IN PACKING. C MXBIT = MAXIMUM NUMBER OF BITS TO USE IN PACKING. C LENPDS = LENGTH OF GRIB1 PDS. C LENGDS = LENGTH OF GRIB1 GDS. C PARAMETER (MNBIT=0,MXBIT=16,LENPDS=28,LENGDS=32) INCLUDE "params" C C INCLUDE COMMON BLOCKS. INCLUDE "CTLBLK.comm" INCLUDE "RQSTFLD.comm" INCLUDE "GRIDSPEC.comm" C C DECLARE VARIABLES. C LOGICAL RUN,FIRST,RESRT,SIGMA,OLDRD,STRD LOGICAL NORTH CHARACTER*1 KBUF(30+LENPDS+LENGDS+IM*JM*(MXBIT+2)/8) CHARACTER*1 KBUF_S(30+LENPDS+LENGDS+IM*JM*(MXBIT+2)/8) CHARACTER*1 IFLAG CHARACTER*4 RESTHR,BLANK CHARACTER*6 CRUN,PROJ CHARACTER*10 DESCR2,DESCR3 CHARACTER*28 PDS CHARACTER*50 ENVAR CHARACTER*80 FNAME,FNAME_S,OPATH,PGBOUT CHARACTER*90 CMD character CFHOUR*40,CFORM*40 integer ndig INTEGER IBDSFL(9) ! INTEGER IGRD(IMOUT,JMOUT),IGDS(18),IBMASK(IMOUT,JMOUT) ! REAL GRID(IMOUT,JMOUT),GRIDO(IMOUT,JMOUT) ! INTEGER IGRD(IM,JM),IGDS(18),IBMASK(IM,JM) INTEGER IGRD(IM,JM),IBMASK(IM,JM) REAL GRID(IM,JM),GRIDO(IM,JM) ! real(8) ist, rtc, time_output, time_e2out INTEGER DXVAL,DYVAL,CENLAT,CENLON,TRUELAT1,TRUELAT2,STANDLON INTEGER LATSTART,LONSTART C C THE BELOW VARIABLE ARE ONLY NEEDED FOR THE CALL TO W3FI63. ! REAL DATAFLD(IMOUT,JMOUT) ! INTEGER IBMAP(IMOUT,JMOUT) REAL DATAFLD(IM,JM) INTEGER IBMAP(IM,JM) INTEGER KGDS(20),KPTR(16) ! LOGICAL KBMS(IMOUT,JMOUT) LOGICAL KBMS(IM,JM) LOGICAL DONE, NEWFILE, NEWFILE_S INTEGER IH(5) INTEGER ICHECK, ILOAD INTEGER STATUS(MPI_STATUS_SIZE) INTEGER LUNOUT_S C C SET DEFAULT GRIB1 PARAMETERS. C PARAMETERS MNBIT, MXBIT, IBX, AND NBIT ARE USED C IN THE CALL TO GET_BITS. C IBX = DESIRED BINARY PRECISION. C NBIT = NUMBER OF BITS TO USE IN PACKING DATA. C DATA IBX,NBIT / 0, 12 / DATA BLANK /' '/ DATA DONE /.FALSE./ DATA ICHECK / 1 / DATA ILOAD / 1 / DATA IH / 5* MPI_REQUEST_NULL / SAVE OPATH ! SAVE IH, NEWFILE, NEWFILE_S, KBUF, KBUF_S, ! * DONE, FNAME, FNAME_S, ! * LUNOUT_S C C***************************************************************************** C START GRIBIT HERE. C C ALL TASKS MUST CALL COLLECT BUT ONLY TASK 0 CAN EXECUTE THE REMAINDER C OF GRIBIT C LUNOUT=70 CALL COLLECT(GRID,GRIDO) IF ( ME .EQ. 0 ) THEN ! ist = rtc() NEWFILE = .FALSE. cjjt C SET NUMBER OF OUTPUT GRID POINTS. ! IJOUT = IMOUT*JMOUT IJOUT = IM*JM C C PREPARE GRIB PDS C C SET ARRAY ID VALUES TO GENERATE GRIB1 PDS. C ID(1) = NUMBER OF BYTES IN PRODUCT DEFINITION SECTION (PDS) C ID(2) = PARAMETER TABLE VERSION NUMBER C ID(3) = IDENTIFICATION OF ORIGINATING CENTER C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER) C ID(5) = GRID IDENTIFICATION C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED C ID(8) = INDICATOR OF PARAMETER AND UNITS (TABLE 2) C ID(9) = INDICATOR OF TYPE OF LEVEL (TABLE 3) C ID(10) = VALUE 1 OF LEVEL (=0 FOR 1-100,102,103,105,107, C 109,111,113,115,117,119,125,160,200,201 LEVEL IS IN ID WORD 11) C ID(11) = VALUE 2 OF LEVEL C ID(12) = YEAR OF CENTURY C ID(13) = MONTH OF YEAR C ID(14) = DAY OF MONTH C ID(15) = HOUR OF DAY C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0) C ID(17) = FCST TIME UNIT C ID(18) = P1 PERIOD OF TIME C ID(19) = P2 PERIOD OF TIME C ID(20) = TIME RANGE INDICATOR C ID(21) = NUMBER INCLUDED IN AVERAGE C ID(22) = NUMBER MISSING FROM AVERAGES C ID(23) = CENTURY C ID(24) = RESERVED - SET TO 0 C ID(25) = SCALING POWER OF 10 C C C PREPARE DATE PART OF GRIB PDS RECORD. ICENT = (SDAT(3)-1)/100 + 1 IYY = SDAT(3) - (ICENT-1)*100 IMM = SDAT(1) IDD = SDAT(2) AYEAR0 = IYY AMNTH0 = IMM ADAY0 = IDD AGMT0 = IHRST ID(01) = 28 IF (ID(2) .NE. 129)THEN IF(ID(2).NE. 130)THEN ID(2) = 2 END IF END IF ID(03) = 7 ID(12) = IYY ID(13) = IMM ID(14) = IDD ID(15) = IHRST ! ID(16) = 0 ID(16) = IMIN ID(17) = 1 C C ASSUMING ID(18-20), (P1, P2, TIME RANGE INDICATOR) C ARE PASSED IN CORRECTLY IF NOT AN INSTANTANEOUS FIELD C IF (ID(20).EQ.0) THEN ID(18) = IFHR ID(19) = 0 ENDIF if(IFHR>256)then if(ID(20)==0)then ID(20)=10 ! use timerange 10 to store fhr with 2 bytes else if (ID(20)==2 .OR. ID(20)==3 .OR. ID(20)==4)then ! INTERVAL=12 ! use 3,6 or 12 hourly to specify time ranges INTERVAL=NINT(TPREC) ! use fcst unit based on precip bucket IF(INTERVAL==3)then ID(17)=10 else if(INTERVAL==6)then ID(17)=11 else if(INTERVAL==12)then ID(17)=12 else if(INTERVAL==24)then ID(17)=2 end if ID(18)=ID(18)/INTERVAL ID(19)=ID(19)/INTERVAL end if end if ! operational GFS uses time range 10 even for hours less than 256, will unify this soon IF (ID(20)==0 .AND. MODELNAME=='GFS')ID(20)=10 ! ! CHUANG: TO OUTPUT OFF-HOUR FORECAST, I USED MIN INSTEAD OF HOUR AS FORECAST UNIT ! ALOS, SINCE ONLT TIME RANGE TYPE 10 USES 2 BYTES TO STORE TIME, MODIFICATION WAS ! MADE TO USE TYPE 10 AS TIME RANGE INDICATOE WHEN FORECST MINS ARE LARGER THAN 254, ! WHICH MEANS ALL THE ACCUMULATED AND TIME-AVERAGED QUANTITY ARE VERIFIED AT ONE TIME ! INSTEAD OF AT A TIME RANGE. IF(IFMIN .GE. 1)THEN ID(17) = 0 TOTMIN=IFHR*60+IFMIN IF(TOTMIN .LE. 256)THEN IF (ID(20).EQ.0)ID(18)=IFHR*60+IFMIN ELSE ID(20)=10 ID(18)=IFHR*60+IFMIN END IF END IF ID(21) = 0 ID(22) = 0 ID(23) = ICENT ID(24) = 0 C C C SET OUTPUT GRID TYPE. WE ASSUME KGYTPE HOLDS THE GRIB C ID FOR THE OUTPUT GRID. C KGTYP = KGTYPE C C SET GRID TYPE ID(5) C GENERATING PROGRAM ID(4) C ! IJOUT = IMOUT*JMOUT IJOUT = IM*JM ID(4) = IMDLTY ID(5) = KGTYP C C ID(6) =0 IF NO GDS SECTION, =1 IF GDS INCLUDED, C ALWAYS INCLUDE GDS C ID(6) = 1 C C SET DATA TYPE ID(8) AND SURFACE ID(9). C C DON'T SET PARAMETER IF PRECIP TYPE, SINCE THERE ARE C 4 PARAMETER NUMBERS FOR THE SAME IFLD C ! IF (ID(8).LT.140.OR.ID(8).GT.143) ID(8) = IQ(IDENT(IFLD)) C 05-08-24 GEOFF MANIKIN - ADDED IN DOMINANT PRECIP TYPE C TO PTYPE IF STATEMENT IF (ID(8).LT.140.OR.ID(8).GT.143) THEN IF (ID(8).LT.203.OR.ID(8).GT.206 * .OR.ID(2).NE.129) THEN ID(8)=IQ(IDENT(IFLD)) ENDIF ENDIF ! Iredell decided to change GRIB ID OF GSS SHUELL SLP TO 1 BECAUSE THE UNIFIED ! POST DOES NOT PERFORM FILTERING. THE GFS FILTERINF OF SLP WILL BE DONE IN ! THE POSTGP SCRIPT BY USING COPYGB. THE GRIB ID OF NEW FILTERED GFS SLP WILL ! BE 2 IF (MODELNAME=='GFS' .AND. ID(8)==2)ID(8) = 1 IF (ID(9).EQ.0) ID(9) = IS(IDENT(IFLD)) C C SET VALUE OF LEVEL IF ON PRESSURE OR ETA SURFACE. C OTHERWISE, WE ASSUME ID(10) AND (11) ARE SET C APPROPRIATELY PRIOR TO ENTERING GRIBIT. C IF (ID(9).EQ.100) THEN ISVALUE = NINT(SPL(ILVL)*D01) ID(10) = 0 ID(11) = ISVALUE !MEB ELSEIF (ID(9).EQ.119) THEN !MEB ISVALUE = ILVL !MEB ISVALUE = NINT(AETA(ILVL)*10000.) C C TKE IS ON THE ETA INTERFACE AT THE BOTTOM OF THE LAYER ILVL C !MEB IF (ID(8).EQ.158) ISVALUE = NINT(ETA(ILVL+1)*10000.) !MEB ID(10) = 0 !MEB ID(11) = ISVALUE ELSEIF (ID(9) .EQ. 109) THEN ISVALUE = ILVL ID(10) = 0 ID(11) = ISVALUE ENDIF ! GFS uses different ID for convective clouds, hoping to unify soon IF (MODELNAME=='GFS')THEN IF(ID(8)==72 .AND. ID(9)==200 )THEN ID(8) = 71 ID(9)=244 END IF ! GFS uses Grib ID 11 for soil temperature IF(ID(8)==85 .AND. ID(9)==112 )THEN ID(8) = 11 END IF ! GFS uses Grib ID 76 for total column cloud water IF(ID(8)==136 .AND. ID(9)==200 )THEN ID(8) = 76 ID(2)=2 END IF ! GFS uses level ID=1 for surface lifted index IF(ID(8)==131 .AND. ID(9)==101 )THEN ID(9)=1 ID(10)=0 ID(11)=0 where(GRIDO/=SPVAL)GRIDO=GRIDO-TFRZ END IF ! GFS uses level ID=1 for best lifted index IF(ID(8)==132 .AND. ID(9)==116 )THEN ID(9)=1 ID(10)=0 ID(11)=0 END IF END IF C C END OF GRIB PDS LABEL PREPARATION. C C C SET DECIMAL SCALING (IDECI) FROM LIST IN INCLUDE FILE C RQSTFLD. A CALL TO GET_BITS WILL COMPUTE THE NUMBER OF C BITS NECESSARY TO PACK THE DATA BASED ON THE RANGE OF C THE FIELD. THE FIELD IS SCALED TO THIS PRECISION AND C RETURNED FOR PACKING BY THE GRIB PACKER. C IBM = 0 IBITM = 0 SGDG = DEC(IFLD) ! set bitmap ! DO J=1,JMOUT ! DO I=1,IMOUT DO J=1,JM DO I=1,IM IF(ABS(GRIDO(I,J)-SPVAL).GT.SMALL) THEN ibmap(i,j) = 1 ibitm = ibitm+1 ELSE ibmap(i,j) = 0 ENDIF ENDDO ENDDO ! set bitmap C C ID(7) =0 IF NO BMS SECTION, =1 IF BMS INCLUDED C IF (IBITM.EQ.IJOUT) THEN ID(7) = 0 IBM = 0 ELSE ID(7) = 1 IBM = 1 ENDIF IF(MODELNAME=='GFS')THEN ! use decimal precision instead of significant digit precision IF(SGDG<0.)THEN ISGDG=0 IBS=-1*NINT(SGDG) ELSE ISGDG=NINT(SGDG) IBS=0 END IF ! CALL GTBITS(IBM,ISGDG,IJOUT,IBMAP,GRIDO, ! & GRIDO,GMIN,GMAX,NBIT) CALL GETBIT(IBM,IBS,ISGDG,IJOUT,IBMAP,GRIDO, & GRIDO,GMIN,GMAX,NBIT) ID(25) = ISGDG ELSE CALL GET_BITS(IBM,SGDG,IJOUT,IBMAP,GRIDO, & IDECI,GRIDO,GMIN,GMAX,NBIT) C C ID(25) = SCALING POWER OF 10 C ID(25) = IDECI END IF C C GENERATE COMPLETE GRIB1 MESSAGE USING W3FI72. C ITYPE = 0 SPECIFIES REAL DATA TO BE PACKED. C IGRD = DUMMY ARRAY FOR INTEGER DATA. C IBITL = NBIT TELLS W3FI72 TO PACK DATA USING NBIT BITS. C IPFLAG = 0 IS PDS INFORMATION IN USER ARRAY ID. C 1 IS PDS (GENERATED ABOVE BY W3FP12). C ID = (DUMMY) ARRAY FOR USER DEFINED PDS. C IGFLAG = 0 TELLS W3FI72 TO MAKE GDS USING IGRID. C 1 IS GDS GENERATED BY USER IN ARRAY IGDS C IGRID = GRIB1 GRID TYPE (TABLE B OF ON388). C IGDS = ARRAY FOR USER DEFINED GDS. C ICOMP = 0 FOR EARTH ORIENTED WINDS, C 1 FOR GRID ORIENTED WINDS. C IBFLAG = 0 TELLS W3FI72 TO MAKE BIT MAP FROM USER C SUPPLIED DATA. C IBMASK = ARRAY CONTAINING USER DEFINED BIT MAP. C IBLEN = LENGTH OF ARRAY IBMASK. C IBDSFL = ARRAY CONTAINING TABLE 11 (ON388) FLAG INFORMATION. C NPTS = LENGTH OF ARRAY GRID OR IGRD. MUST AGREE WITH IBLEN. C C INTIALIZE VARIABLES. ITYPE = 0 C IBITL = MIN(NBIT,MXBIT) C IPFLAG = 0 C !MEB IGFLAG = 0 IGFLAG = 1 ! set to 1 so that IGDS is defined here instead of w3lib IGRID = ID(5) print*,'GRID NUMBER = ',IGRID IF (IGRID.EQ.26) IGRID=6 ! IF INPUT IS GRIB, THE IGDS WERE MADE IN INITPOST print*,'IOFORM in GRIBIT =', IOFORM IF (TRIM(IOFORM) /= 'grib' )THEN DO 20 K = 1,18 IGDS(K) = 0 20 CONTINUE END IF IF(MAPTYPE.EQ.1)THEN !LAmbert Conformal IGDS( 1) = 0 IGDS( 2) = 255 IGDS( 3) = 3 IGDS( 4) = IM IGDS( 5) = JM IGDS( 6) = LATSTART IGDS( 7) = LONSTART IGDS( 8) = 8 ! IGDS( 9) = CENLON IGDS( 9) = STANDLON IGDS(10) = DXVAL IGDS(11) = DYVAL IGDS(12) = 0 IGDS(13) = 64 IGDS(14) = 0 IGDS(15) = TRUELAT2 IGDS(16) = TRUELAT1 IGDS(17) = 0 IGDS(18) = 0 ELSE IF(MAPTYPE.EQ.2)THEN !Polar stereographic IGDS( 1) = 0 IGDS( 2) = 255 IGDS( 3) = 5 IGDS( 4) = IM IGDS( 5) = JM IGDS( 6) = LATSTART IGDS( 7) = LONSTART IGDS( 8) = 8 ! IGDS( 9) = CENLON IGDS( 9) = STANDLON IGDS(10) = DXVAL IGDS(11) = DYVAL IGDS(12) = 0 IGDS(13) = 64 ELSE IF(MAPTYPE.EQ.3)THEN !Mercator IGDS( 1) = 0 IGDS( 2) = 255 IGDS( 3) = 1 IGDS( 4) = IM IGDS( 5) = JM IGDS( 6) = LATSTART IGDS( 7) = LONSTART IGDS( 8) = 8 IGDS( 9) = LATLAST IGDS(10) = LONLAST IGDS(11) = DYVAL IGDS(12) = DXVAL IGDS(13) = TRUELAT1 IGDS(14) = 64 ELSE IF(MAPTYPE.EQ.203)THEN !ARAKAWA STAGGERED E-GRID IGDS( 1) = 0 IGDS( 2) = 255 IGDS( 3) = 203 IGDS( 4) = IM IGDS( 5) = JM IGDS( 6) = LATSTART IGDS( 7) = LONSTART IGDS( 8) = 136 IGDS( 9) = CENLAT IGDS(10) = CENLON IGDS(11) = DXVAL IGDS(12) = DYVAL IGDS(13) = 64 IGDS(14) = 0 ! Only define Gaussian grid again if it is not defined in ! INITPOST_GFS ELSE IF(MAPTYPE.EQ.4 .AND. IGDS(4)==0)THEN !Gaussian grid print*,'set up IGDS in GRIBIT for Gaussian grid' IGDS( 1) = 0 IGDS( 2) = 255 IGDS( 3) = 4 IGDS( 4) = IM IGDS( 5) = JM IGDS( 6) = LATSTART IGDS( 7) = LONSTART IGDS( 8) = 128 IGDS( 9) = LATLAST IGDS(10) = LONLAST IGDS(11) = NINT(JM/2.0) IGDS(12) = NINT(360./(IM-1)*1000.) IGDS(13) = 0 IGDS(14) = 0 IGDS(15) = 0 IGDS(16) = 0 IGDS(17) = 0 IGDS(18) = 0 ! Only define Latlon grid again if it is not defined in ! INITPOST_GFS ELSE IF(MAPTYPE.EQ.0 .AND. IGDS(4)==0)THEN !Latlon grid print*,'set up IGDS in GRIBIT for Latlon grid' IGDS( 1) = 0 IGDS( 2) = 255 IGDS( 3) = 0 IGDS( 4) = IM IGDS( 5) = JM IGDS( 6) = LATSTART IGDS( 7) = LONSTART IGDS( 8) = 128 IGDS( 9) = LATLAST IGDS(10) = LONLAST IGDS(11) = NINT(180./(JM-1)*1000.) IGDS(12) = NINT(360./(IM)*1000.) IGDS(13) = 0 IGDS(14) = 0 IGDS(15) = 0 IGDS(16) = 0 IGDS(17) = 0 IGDS(18) = 0 END IF C write(6,*) 'IGDS in GRIBIT= ', IGDS C LAMBERT CONFORMAL: C IGDS( 1) = NUMBER OF VERTICAL COORDINATES C IGDS( 2) = PV, PL OR 255 C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) C IGDS( 4) = NO. OF POINTS ALONG X-AXIS C IGDS( 5) = NO. OF POINTS ALONG Y-AXIS C IGDS( 6) = LATITUDE OF ORIGIN (SOUTH -IVE) C IGDS( 7) = LONGITUTE OF ORIGIN (WEST -IVE) C IGDS( 8) = RESOLUTION FLAG (CODE TABLE 7) C IGDS( 9) = LONGITUDE OF MERIDIAN PARALLEL TO Y-AXIS C IGDS(10) = X-DIRECTION GRID LENGTH (INCREMENT) C IGDS(11) = Y-DIRECTION GRID LENGTH (INCREMENT) C IGDS(12) = PROJECTION CENTER FLAG (0=NORTH POLE ON PLANE, C 1=SOUTH POLE ON PLANE, C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) C IGDS(14) = NOT USED C IGDS(15) = FIRST LATITUDE FROM THE POLE AT WHICH THE C SECANT CONE CUTS THE SPERICAL EARTH C IGDS(16) = SECOND LATITUDE ... C IGDS(17) = LATITUDE OF SOUTH POLE (MILLIDEGREES) C IGDS(18) = LONGITUDE OF SOUTH POLE (MILLIDEGREES) C ICOMP = 1 ! IF (INDEX(PROJ,'LOLA').NE.0) ICOMP = 0 IF(IGDS(8)==128)ICOMP = 0 ! print*,'ICOMP in GRIBIT=',ICOMP IBFLAG = 0 IBLEN = IJOUT DO 30 K = 1,9 IBDSFL(K) = 0 30 CONTINUE C CALL W3FI72(ITYPE,GRIDO,IGRD,IBITL, X IPFLAG,ID,PDS, X IGFLAG,IGRID,IGDS,ICOMP, X IBFLAG,IBMAP,IBLEN, X IBDSFL, X NPTS,KBUF,ITOT,IER) C C EXPLICITLY SET BYTE 12 OF KBUF (BYTE 4 OF THE PDS) C TO 2. THIS WILL REFER ALL QUANTITIES TO PARAMETER C TABLE VERSION 2 OF WHICH TABLE VERSION 1 IS A SUBSET. C THIS IS NEEDED BECAUSE THE W3 ROUTINES HARDWIRE THIS C VALUE TO 1 YET SOME OF THE OUTPUT VARIABLES ARE ONLY C DEFINED IN VERSION 2 OF THE PARAMETER TABLE. C !--- Comment out; BYTE 4 (PDS Octet 4) = 2 or 129 (see ON388, Table 2) ! !! KBUF(12)=CHAR(2) C IF (IER.NE.0) THEN WRITE(6,1040) IER,FIELD(IFLD) 1040 FORMAT('GRIBIT: ***W3FI72 ERROR IER=',I8, X ' FOR ',A20) WRITE(6,*)'GRIBIT: DID NOT POST THIS FIELD' ! time_output = time_output + rtc() - ist RETURN ENDIF C C ON FIRST ENTRY MAKE OUTPUT DIRECTORY. SET SWITCH (RITEHD) C TO FALSE FOR SUBSEQUENT ENTRIES. IF (RITEHD) THEN C C PUT FORECAST HOUR INTO DIR PREFIX FOR GRIB FILE. IHR = IFHR C C GET FULL PATH FOR OUTPUT FILE FROM ENVIRONMENT VARIABLE C COMSP WHICH IS SET IN THE SCRIPT RUNNING THE MODEL. C C CONSTRUCT FULL PATH-FILENAME FOR OUTPUT FILE ENVAR = ' ' RESTHR = ' ' PGBOUT = ' ' CALL GETENV('COMSP',ENVAR) CALL GETENV('tmmark',RESTHR) CALL GETENV('PGBOUT',PGBOUT) KDAT = INDEX(DATSET,' ') -1 IF (KDAT.LE.0) KDAT = LEN(DATSET) KENV = INDEX(ENVAR,' ') -1 IF (KENV.LE.0) KENV = LEN(ENVAR) KTHR = INDEX(RESTHR,' ') -1 IF (KTHR.LE.0) KTHR = LEN(RESTHR) C C CONSTRUCT FULL PATH-FILENAME FOR OUTPUT FILE IF(MODELNAME=='GFS'.AND.PGBOUT(1:4).NE.BLANK)THEN FNAME = PGBOUT PRINT*,' FNAME FROM PGBOUT=',FNAME C ELSEIF (ENVAR(1:4).EQ.BLANK.AND.RESTHR(1:4).EQ.BLANK) THEN IF(IFMIN .GE. 1)THEN WRITE(DESCR2,1011) IHR WRITE(DESCR3,1011) IFMIN FNAME = DATSET(1:KDAT) // DESCR2 //':'// DESCR3(1:2) ELSE NDIG=MAX(LOG10(IHR+0.5)+1.,2.) ! WRITE(CFORM,'("('.GrbF',I",I1,".",I1,")")') NDIG,NDIG WRITE(CFORM,'("(I",I1,".",I1,")")') NDIG,NDIG WRITE(CFHOUR,CFORM) IHR FNAME = DATSET(1:KDAT) //'.GrbF'// CFHOUR print *,' FNAME=',FNAME ! ! IF(IHR.LT.100)THEN ! WRITE(DESCR2,1011) IHR ! ELSE ! WRITE(DESCR2,1013) IHR ! END IF 1011 FORMAT('.GrbF',I2.2) !1013 FORMAT('.GrbF',I3.3) ! FNAME = DATSET(1:KDAT) // DESCR2 END IF C ELSEIF(ENVAR(1:4).EQ.BLANK.AND.RESTHR(1:4).NE.BLANK) THEN IF(IFMIN .GE. 1)THEN WRITE(DESCR3,1012) IFMIN IF (IHR.LT.100) THEN WRITE(DESCR2,1012) IHR FNAME = DATSET(1:KDAT) // DESCR2(1:2) //':'// DESCR3(1:2) & //'.'// RESTHR ELSE WRITE(DESCR2,1014) IHR FNAME = DATSET(1:KDAT) // DESCR2(1:3) //':'// DESCR3(1:2) & //'.'// RESTHR ENDIF ELSE IF (IHR.LT.100) THEN WRITE(DESCR2,1012) IHR FNAME = DATSET(1:KDAT) // DESCR2(1:2) //'.'// RESTHR ELSE WRITE(DESCR2,1014) IHR FNAME = DATSET(1:KDAT) // DESCR2(1:3) //'.'// RESTHR ENDIF end if ELSE IF(IFMIN .GE. 1)THEN WRITE(DESCR3,1012) IFMIN IF (IHR.LT.100) THEN WRITE(DESCR2,1012) IHR FNAME = ENVAR(1:KENV) // DATSET(1:KDAT) // DESCR2(1:2) & //':'// DESCR3(1:2) //'.'// RESTHR ELSE WRITE(DESCR2,1014) IHR FNAME = ENVAR(1:KENV) // DATSET(1:KDAT) // DESCR2(1:3) & //':'// DESCR3(1:2) //'.'// RESTHR ENDIF ELSE IF (IHR.LT.100) THEN WRITE(DESCR2,1012) IHR FNAME = ENVAR(1:KENV) // DATSET(1:KDAT) // DESCR2(1:2) & //'.'// RESTHR 1012 FORMAT(I2.2) 1014 FORMAT(I3.3) ELSE WRITE(DESCR2,1014) IHR FNAME = ENVAR(1:KENV) // DATSET(1:KDAT) // DESCR2(1:3) & //'.'// RESTHR ENDIF end if ENDIF C C ASSIGN AND OPEN UNIT FOR GRIB DATA FILE. if ( num_servers .eq. 0 ) then CLOSE(LUNOUT) ! CALL BAOPEN(LUNOUT,FNAME,IER) ! USE BAOPENWT INSTEAD SO THAT FILE WILL BE OPEN WITH 0 BYTE CALL BAOPENWT(LUNOUT,FNAME,IER) IF (IER.NE.0) WRITE(6,*) X 'GRIBIT: BAOPEN ERROR FOR GRIB DATA ', X 'FILE. IER=',IER WRITE(6,*)'GRIBIT: OPENED ',LUNOUT, X ' FOR GRIB DATA ',FNAME end if C C SET OPEN-UNIT FLAGS TO FALSE. RITEHD = .FALSE. NEWFILE = .TRUE. ENDIF C C SEND DATA TO I/O SERVERS C C if ( num_servers .gt. 0 ) then DO I = 1, 5 CALL MPI_WAIT(IH(I),STATUS,IERR) END DO NEWFILE_S = NEWFILE LUNOUT_S = LUNOUT FNAME_S = FNAME KBUF_S(1:ITOT) = KBUF(1:ITOT) CALL MPI_ISEND(DONE,1,MPI_LOGICAL, * 0,1,MPI_COMM_INTER,IH(1),IERR) CALL MPI_ISEND(NEWFILE_S,1,MPI_LOGICAL, * 0,2,MPI_COMM_INTER,IH(2),IERR) CALL MPI_ISEND(LUNOUT_S,1,MPI_INTEGER, * 0,3,MPI_COMM_INTER,IH(3),IERR) CALL MPI_ISEND(FNAME_S,80,MPI_CHARACTER, * 0,4,MPI_COMM_INTER,IH(4),IERR) CALL MPI_ISEND(KBUF_S,ITOT,MPI_CHARACTER, * 0,5,MPI_COMM_INTER,IH(5),IERR) C else C C WRITE GRIB1 MESSAGE TO OUTPUT FILE. CALL WRYTE(LUNOUT,ITOT,KBUF) end if C C WRITE DIAGNOSTIC MESSAGE. C ID(8) = INDICATOR OF PARAMETER AND UNITS (TABLE 2) C ID(9) = INDICATOR OF TYPE OF LEVEL (TABLE 3) C ID(10) = VALUE 1 OF LEVEL (0 FOR 1-100,102,103,105,107 C 111,160 LEVEL IS IN ID WORD 11) C ID(11) = VALUE 2 OF LEVEL 666 WRITE(6,1050) ID(8),FIELD(IFLD),ID(9),ID(10),ID(11) 1050 FORMAT('GRIBIT: ',I3,1X,A20,1X,I3,1X,I5,1X,I5) C C END OF ROUTINE. C END IF ! time_output = time_output + rtc() - ist RETURN END C IGDS VARIES DEPENDING ON GRID REPRESENTATION TYPE. C C LAT/LON GRID: C IGDS( 1) = NUMBER OF VERTICAL COORDINATES C IGDS( 2) = PV, PL OR 255 C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) C IGDS( 4) = NO. OF POINTS ALONG A LATITUDE C IGDS( 5) = NO. OF POINTS ALONG A LONGITUDE MERIDIAN C IGDS( 6) = LATITUDE OF ORIGIN (SOUTH - IVE) C IGDS( 7) = LONGITUDE OF ORIGIN (WEST -IVE) C IGDS( 8) = RESOLUTION FLAG (CODE TABLE 7) C IGDS( 9) = LATITUDE OF EXTREME POINT (SOUTH - IVE) C IGDS(10) = LONGITUDE OF EXTREME POINT (WEST - IVE) C IGDS(11) = LATITUDE INCREMENT C IGDS(12) = LONGITUDE INCREMENT C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) C IGDS(14) = ... THROUGH ... C IGDS(18) = ... NOT USED FOR THIS GRID C IGDS(19) - IGDS(91) FOR GRIDS 37-44, NUMBER OF POINTS C IN EACH OF 73 ROWS. C C GAUSSIAN GRID: C IGDS( 1) = ... THROUGH ... C IGDS(10) = ... SAME AS LAT/LON GRID C IGDS(11) = NUMBER OF LATITUDE LINES BETWEEN A POLE C AND THE EQUATOR C IGDS(12) = LONGITUDE INCREMENT C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) C IGDS(14) = ... THROUGH ... C IGDS(18) = ... NOT USED FOR THIS GRID C C SPHERICAL HARMONICS: C IGDS( 1) = NUMBER OF VERTICAL COORDINATES C IGDS( 2) = PV, PL OR 255 C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) C IGDS( 4) = J - PENTAGONAL RESOLUTION PARAMETER C IGDS( 5) = K - PENTAGONAL RESOLUTION PARAMETER C IGDS( 6) = M - PENTAGONAL RESOLUTION PARAMETER C IGDS( 7) = REPRESENTATION TYPE (CODE TABLE 9) C IGDS( 8) = REPRESENTATION MODE (CODE TABLE 10) C IGDS( 9) = ... THROUGH ... C IGDS(18) = ... NOT USED FOR THIS GRID C C POLAR STEREOGRAPHIC: C IGDS( 1) = NUMBER OF VERTICAL COORDINATES C IGDS( 2) = PV, PL OR 255 C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) C IGDS( 4) = NO. OF POINTS ALONG X-AXIS C IGDS( 5) = NO. OF POINTS ALONG Y-AXIS C IGDS( 6) = LATITUDE OF ORIGIN (SOUTH -IVE) C IGDS( 7) = LONGITUTE OF ORIGIN (WEST -IVE) C IGDS( 8) = RESOLUTION FLAG (CODE TABLE 7) C IGDS( 9) = LONGITUDE OF MERIDIAN PARALLEL TO Y-AXIS C IGDS(10) = X-DIRECTION GRID LENGTH (INCREMENT) C IGDS(11) = Y-DIRECTION GRID LENGTH (INCREMENT) C IGDS(12) = PROJECTION CENTER FLAG (0=NORTH POLE ON PLANE, C 1=SOUTH POLE ON PLANE, C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) C IGDS(14) = ... THROUGH ... C IGDS(18) = .. NOT USED FOR THIS GRID C C MERCATOR: C IGDS( 1) = ... THROUGH ... C IGDS(12) = ... SAME AS LAT/LON GRID C IGDS(13) = LATITUDE AT WHICH PROJECTION CYLINDER C INTERSECTS EARTH C IGDS(14) = SCANNING MODE FLAGS C IGDS(15) = ... THROUGH ... C IGDS(18) = .. NOT USED FOR THIS GRID C C LAMBERT CONFORMAL: C IGDS( 1) = NUMBER OF VERTICAL COORDINATES C IGDS( 2) = PV, PL OR 255 C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) C IGDS( 4) = NO. OF POINTS ALONG X-AXIS C IGDS( 5) = NO. OF POINTS ALONG Y-AXIS C IGDS( 6) = LATITUDE OF ORIGIN (SOUTH -IVE) C IGDS( 7) = LONGITUTE OF ORIGIN (WEST -IVE) C IGDS( 8) = RESOLUTION FLAG (CODE TABLE 7) C IGDS( 9) = LONGITUDE OF MERIDIAN PARALLEL TO Y-AXIS C IGDS(10) = X-DIRECTION GRID LENGTH (INCREMENT) C IGDS(11) = Y-DIRECTION GRID LENGTH (INCREMENT) C IGDS(12) = PROJECTION CENTER FLAG (0=NORTH POLE ON PLANE, C 1=SOUTH POLE ON PLANE, C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) C IGDS(14) = NOT USED C IGDS(15) = FIRST LATITUDE FROM THE POLE AT WHICH THE C SECANT CONE CUTS THE SPERICAL EARTH C IGDS(16) = SECOND LATITUDE ... C IGDS(17) = LATITUDE OF SOUTH POLE (MILLIDEGREES) C IGDS(18) = LONGITUDE OF SOUTH POLE (MILLIDEGREES) C C ARAKAWA SEMI-STAGGERED E-GRID ON ROTATED LAT/LON GRID C IGDS( 1) = NUMBER OF VERTICAL COORDINATES C IGDS( 2) = PV, PL OR 255 C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) [201] C IGDS( 4) = NI - TOTAL NUMBER OF ACTUAL DATA POINTS C INCLUDED ON GRID C IGDS( 5) = NJ - DUMMY SECOND DIMENSION; SET=1 C IGDS( 6) = LA1 - LATITUDE OF FIRST GRID POINT C IGDS( 7) = LO1 - LONGITUDE OF FIRST GRID POINT C IGDS( 8) = RESOLUTION AND COMPONENT FLAG (CODE TABLE 7) C IGDS( 9) = LA2 - NUMBER OF MASS POINTS ALONG C SOUTHERNMOST ROW OF GRID C IGDS(10) = LO2 - NUMBER OF ROWS IN EACH COLUMN C IGDS(11) = DI - LONGITUDINAL DIRECTION INCREMENT C IGDS(12) = DJ - LATITUDINAL DIRECTION INCREMENT C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) C IGDS(14) = ... THROUGH ... C IGDS(18) = ... NOT USED FOR THIS GRID (SET TO ZERO) C C ARAKAWA FILLED E-GRID ON ROTATED LAT/LON GRID C IGDS( 1) = NUMBER OF VERTICAL COORDINATES C IGDS( 2) = PV, PL OR 255 C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) [202] C IGDS( 4) = NI - TOTAL NUMBER OF ACTUAL DATA POINTS C INCLUDED ON GRID C IGDS( 5) = NJ - DUMMY SECOND DIMENTION; SET=1 C IGDS( 6) = LA1 - LATITUDE LATITUDE OF FIRST GRID POINT C IGDS( 7) = LO1 - LONGITUDE OF FIRST GRID POINT C IGDS( 8) = RESOLUTION AND COMPONENT FLAG (CODE TABLE 7) C IGDS( 9) = LA2 - NUMBER OF (ZONAL) POINTS IN EACH ROW C IGDS(10) = LO2 - NUMBER OF (MERIDIONAL) POINTS IN EACH C COLUMN C IGDS(11) = DI - LONGITUDINAL DIRECTION INCREMENT C IGDS(12) = DJ - LATITUDINAL DIRECTION INCREMENT C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) C IGDS(14) = ... THROUGH ... C IGDS(18) = ... NOT USED FOR THIS GRID C C ARAKAWA STAGGERED E-GRID ON ROTATED LAT/LON GRID C IGDS( 1) = NUMBER OF VERTICAL COORDINATES C IGDS( 2) = PV, PL OR 255 C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) [203] C IGDS( 4) = NI - NUMBER OF DATA POINTS IN EACH ROW C IGDS( 5) = NJ - NUMBER OF ROWS C IGDS( 6) = LA1 - LATITUDE OF FIRST GRID POINT C IGDS( 7) = LO1 - LONGITUDE OF FIRST GRID POINT C IGDS( 8) = RESOLUTION AND COMPONENT FLAG (CODE TABLE 7) C IGDS( 9) = LA2 - CENTRAL LATITUDE C IGDS(10) = LO2 - CENTRAL LONGTITUDE C IGDS(11) = DI - LONGITUDINAL DIRECTION INCREMENT C IGDS(12) = DJ - LATITUDINAL DIRECTION INCREMENT C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) C IGDS(14) = ... THROUGH ... C IGDS(18) = ... NOT USED FOR THIS GRID C