#include "w3macros.h" !/ ------------------------------------------------------------------- / PROGRAM W3GRIB !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | !/ | H. L. Tolman | !/ | A. Chawla | !/ | J.-H. Alves | !/ | FORTRAN 90 | !/ | Last update : 01-Mar-2013 | !/ +-----------------------------------+ !/ !/ 01-Nov-1999 : Final FORTRAN 77 ( version 1.18 + error fix ) !/ 24-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) !/ 25-Jan-2001 : Flat grid error exit added ( version 2.06 ) !/ 29-Apr-2002 : Adding output fields 17-18. ( version 2.20 ) !/ 08-May-2002 : Replace XLF switch with NCEP1. ( version 2.21 ) !/ 13-Nov-2002 : Add stress vector. ( version 3.00 ) !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) !/ 20-Jul-2005 : Additional output parameters. ( version 3.07 ) !/ 11-Apr-2007 : Additional output parameters. ( version 3.11 ) !/ 18-May-2007 : Update GRIB1 for partitioning. ( version 3.11 ) !/ 16-Jul-2007 : Adding GRIB2 capability. ( version 3.11 ) !/ (A. Chawla) !/ 01-Aug-2007 : Update FLGRIB for GRIB2. ( version 3.11 ) !/ 29-May-2009 : Preparing distribution version. ( version 3.14 ) !/ 30-Oct-2009 : Implement run-time grid selection. ( version 3.14 ) !/ (W. E. Rogers & T. J. Campbell, NRL) !/ 05-Oct-2011 : Updating to the 53 output parameter ( version 4.05 ) !/ (Arun Chawla) !/ 01-Mar-2013 : Adding double-index output fields ( version 4.11 ) !/ (J-Henrique Alves) !/ 01-Dec-2016 : Adding lambert conformal grid ( version 6.01 ) !/ (J.H. Alves) !/ !/ Copyright 2009 National Weather Service (NWS), !/ National Oceanic and Atmospheric Administration. All rights !/ reserved. WAVEWATCH III is a trademark of the NWS. !/ No unauthorized use without permission. !/ ! 1. Purpose : ! ! Post-processing of grid output. ! ! 2. Method : ! ! Data is read from the grid output file out_grd.ww3 (raw data) ! and from the file ww3_grib.inp ( NDSI, output requests ). ! Model definition and raw data files are read using WAVEWATCH III ! subroutines. ! GRIB packing is performed using NCEP's W3 library (not supplied). ! ! When adding new parameters to GRIB packing, keep in mind that ! packing is done differently for scalar and vector quantities ! ! 3. Parameters : ! ! 4. Subroutines used : ! ! Name Type Module Description ! ---------------------------------------------------------------- ! W3NMOD Subr. W3GDATMD Set number of model. ! W3SETG Subr. Id. Point to selected model. ! W3NDAT Subr. W3WDATMD Set number of model for wave data. ! W3SETW Subr. Id. Point to selected model for wave data. ! W3NAUX Subr. W3ADATMD Set number of model for aux data. ! W3SETA Subr. Id. Point to selected model for aux data. ! ITRACE Subr. W3SERVMD Subroutine tracing initialization. ! STRACE Subr. Id. Subroutine tracing. ! NEXTLN Subr. Id. Get next line from input filw ! EXTCDE Subr. Id. Abort program as graceful as possible. ! STME21 Subr. W3TIMEMD Convert time to string. ! TICK21 Subr. Id. Advance time. ! DSEC21 Func. Id. Difference between times. ! W3IOGR Subr. W3IOGRMD Reading/writing model definition file. ! W3IOGO Subr. W3IOGOMD Reading/writing raw gridded data file. ! W3READFLGRD Subr. W3IOGOMD Reading output fields flags. ! W3EXGB Subr. Internal Execute grib output. ! BAOPEN Subr. NCEP library routine. ! BAOPENW Subr. NCEP library routine. ! ---------------------------------------------------------------- ! ! 5. Called by : ! ! None, stand-alone program. ! ! 6. Error messages : ! ! Checks on input, checks in W3IOxx. ! ! 7. Remarks : ! ! 8. Structure : ! ! See source code. ! ! 9. Switches : ! ! !/S Enable subroutine tracing. ! ! !/NCO NCEP NCO modifications for operational implementation. ! ! !/NOGRB No GRIB package included. ! !/NCEP1 NCEP IBM links to GRIB1 packing routines. ! !/NCEP2 NCEP IBM links to GRIB2 packing routines. ! ! 10. Source code : ! !/ ------------------------------------------------------------------- / USE CONSTANTS ! ! USE W3GDATMD, ONLY: W3NMOD, W3SETG USE W3WDATMD, ONLY: W3NDAT, W3SETW ! USE W3ADATMD, ONLY: W3NAUX, W3SETA USE W3ODATMD, ONLY: W3NOUT, W3SETO USE W3IOGRMD, ONLY: W3IOGR USE W3IOGOMD, ONLY: W3READFLGRD, W3IOGO USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE USE W3TIMEMD, ONLY: STME21, TICK21, DSEC21 ! USE W3GDATMD USE W3WDATMD, ONLY: TIME, WLV, ICE, UST, USTDIR ! USE W3ADATMD, ONLY: DW, UA, UD, AS, CX, CY, HS, WLM, T0M1, THM, & ! THS, FP0, THP0, FP1, THP1, DTDYN, FCUT, & ! PHS, PTP, PLP, PDIR, PSI, PWS, PWST, PNR, & ! USERO USE W3ADATMD USE W3ODATMD, ONLY: NDSE, NDST, NDSO, NOGRP, NGRPP, IDOUT, UNDEF,& FLOGRD, FNMPRE, NOSWLL, NOGE, FLOGD ! IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Local variables !/ INTEGER :: NDSI, NDSM, NDSOG, NDSDAT, NDSTRC, & NTRACE, IERR, IOTEST, I,J,K, IFI,IFJ,& ISEA, IX, IY, TOUT(2), NOUT, TDUM(2),& FTIME(2), CID, PID, GID, GDS, IOUT, & GDTN INTEGER, ALLOCATABLE :: IFIA(:),IFJA(:) ! GRIB1 specific variables ! GRIB2 specific variables INTEGER :: KPDS(200), KGDS(200) ! !----------------------------------------------------------------------- ! Data representation section for GRIB2 encoding. Note that IDRS is a ! temporary work array that is modified during ADDFIELD. The IDRS must ! be must be reset to original values before the next call to ADDFIELD, ! or the data may be encoded wrong. ! ! IDRS = work array for G2 library. At input, it specifies encoding settings. ! IDRS1 = IDRS settings for when there is at least one point that is not undef. ! IDRS0 = IDRS settings for when all data is undef. ! ! IDRSNUM = encoding method temporary variable ! IDRSNUM1 = encoding method for when at least one point is not undef. ! IDRSNUM0 = encoding method for when all points are undef ! INTEGER :: IDRS(200), IDRS1(200), IDRS0(200) INTEGER, TARGET :: IDRSNUM, IDRSNUM1, IDRSNUM0 !----------------------------------------------------------------------- ! INTEGER :: LISTSEC0(3), LISTSEC1(13),IGDS(5) INTEGER :: IDEFLIST, IDEFNUM, KPDSNUM, NUMCOORD INTEGER :: IBMP, LCGRIB, LENGRIB REAL :: COORDLIST, XN CHARACTER(LEN=1), ALLOCATABLE :: CGRIB(:) INTEGER :: LATAN1, LONV, SCNMOD, LATIN1, & LATIN2, LATSP, LONSP REAL :: DSX, DSY REAL :: YN, X0N, Y0N REAL :: DTREQ, DTEST, RFTIME LOGICAL :: FLREQ(NOGRP,NGRPP), FLGRIB(NOGRP,NGRPP) CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11 !/ !/ ------------------------------------------------------------------- / !/ ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 1. IO set-up. ! CALL W3NMOD ( 1, 6, 6 ) CALL W3SETG ( 1, 6, 6 ) CALL W3NDAT ( 6, 6 ) CALL W3SETW ( 1, 6, 6 ) CALL W3NAUX ( 6, 6 ) CALL W3SETA ( 1, 6, 6 ) CALL W3NOUT ( 6, 6 ) CALL W3SETO ( 1, 6, 6 ) ! NDSI = 10 NDSM = 20 NDSOG = 20 NDSDAT = 50 ! NDSTRC = 6 NTRACE = 10 ! WRITE (NDSO,900) ! CALL ITRACE ( NDSTRC, NTRACE ) ! OPEN (NDSI,FILE='ww3_grib.inp',STATUS='OLD',ERR=800,IOSTAT=IERR) READ (NDSI,'(A)',END=801,ERR=802) COMSTR IF (COMSTR.EQ.' ') COMSTR = '$' WRITE (NDSO,901) COMSTR ! CALL BAOPENW (NDSDAT,'gribfile',IERR) ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 2. Read model definition file. ! CALL W3IOGR ( 'READ', NDSM ) WRITE (NDSO,920) GNAME ! IF ( .NOT. FLAGLL ) GOTO 810 ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 3. Read requests from input file. ! Output times ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802) TOUT, DTREQ, NOUT DTREQ = MAX ( 0. , DTREQ ) IF ( DTREQ.EQ.0 ) NOUT = 1 NOUT = MAX ( 1 , NOUT ) ! CALL STME21 ( TOUT , IDTIME ) WRITE (NDSO,940) IDTIME ! TDUM(1) = 0 TDUM(2) = 0 CALL TICK21 ( TDUM , DTREQ ) CALL STME21 ( TDUM , IDTIME ) IF ( DTREQ .GE. 86400. ) THEN WRITE (IDDDAY,'(I10,1X)') INT(DTREQ/86400.) ELSE IDDDAY = ' ' END IF IDTIME(1:11) = IDDDAY IDTIME(21:23) = ' ' WRITE (NDSO,941) IDTIME, NOUT ! ! ... Initialize FLGRD array ! FLREQ(:,:)=.FALSE. ! ! ... Call to interface for reading flags or namelists ! CALL W3READFLGRD ( NDSI, NDSO, 9, NDSE, COMSTR, FLOGD, FLREQ, & 1, 1, IERR ) ! ! Inform user of parameters that were requested but failed to make the ! grade, as they are not available for grib encoding, or are not ! included presently ! WRITE (NDSO,944) ! Reset flags for variables not yet implemented in grib output ! interface ! IFI = 3 ! Entire group Frequency-dependent parameters DO IFJ = 1,NOGE(IFI) IF ( FLREQ(IFI,IFJ) ) THEN WRITE (NDSO,946) IDOUT(IFI,IFJ), & '*** NOT YET CODED INTO WW3_GRIB ***' FLREQ(IFI,IFJ) = .FALSE. END IF END DO ! IFI = 5 ! Atm-waves layer, all except for friction velocity DO IFJ = 2,10 IF ( FLREQ(IFI,IFJ) ) THEN WRITE (NDSO,946) IDOUT(IFI,IFJ), & '*** NOT YET CODED INTO WW3_GRIB ***' FLREQ(IFI,IFJ) = .FALSE. END IF END DO DO IFI = 6,8 ! Entire groups wave-ocean interaction, wave-bottom ! layer and spectrum parameters DO IFJ = 1,NOGE(IFI) IF ( FLREQ(IFI,IFJ) ) THEN WRITE (NDSO,946) IDOUT(IFI,IFJ), & '*** NOT YET CODED INTO WW3_GRIB ***' FLREQ(IFI,IFJ) = .FALSE. END IF END DO END DO IF ( FLREQ(9,5) ) THEN ! CFL number for K advection WRITE (NDSO,946) IDOUT(9,5),'*** NOT YET CODED INTO WW3_GRIB ***' FLREQ(9,5) = .FALSE. END IF IFI = 10 ! User defined parameters DO IFJ = 1,NOGE(IFI) IF ( FLREQ(IFI,IFJ) ) THEN WRITE (NDSO,946) IDOUT(IFI,IFJ), & '*** NOT YET CODED INTO WW3_GRIB ***' FLREQ(IFI,IFJ) = .FALSE. END IF END DO ! ! Compatibility with NCEP operational codes, same effect as old FLGRIB ! lists variables that have no code for variable names (not 100% ! correct in old codes... ) ! ! Chage this as parameters become available in grib2 tables ! ALLOCATE ( IFIA (16), IFJA(16) ) IFIA = (/ 1, 1, 2, 2, 2, 2, 4, 4, 4, 4, 4, 5, 9, 9, 9, 9 /) IFJA = (/ 1, 4, 2 ,3, 5, 8, 3, 5, 6, 7, 8, 1, 1, 2, 3, 4 /) DO I = 1, 16 IF ( FLREQ(IFIA(I),IFJA(I)) ) THEN FLREQ(IFIA(I),IFJA(I)) = .FALSE. WRITE(NDSO,946) IDOUT(IFIA(I),IFJA(I)), & '*** EXCLUDED FROM GRIB OUTPUT ***' END IF END DO ! ! Write to stdout parameters that have successfully been requested ! WRITE (NDSO,945) DO I=1, NOGRP DO J=1, NGRPP IF ( FLREQ(I,J) ) WRITE (NDSO,931) IDOUT(I,J) END DO END DO ! ! ... GRIB specific parameters ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802) FTIME, CID, PID, GID, GDS, GDTN ! ! Check if grid type is curvilinear, and only go on if Lambert conformal ! IF ( GTYPE .EQ. CLGTYPE ) THEN IF ( GDTN .NE. 30 ) THEN WRITE(NDSE,*)'PROGRAM W3GRIB: CURVILINEAR GRID SUPPORT '// & 'FOR GRIB OUTPUT IS NOT YET IMPLEMENTED. NOW STOPPING' CALL EXTCDE ( 1 ) ENDIF END IF ! ! Coded up to now only for Lamber conformal grids (GDTN=30) ! For regular grids use GDTN=0 ! IF ( GDTN .EQ. 30 ) THEN CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=801,ERR=802) LATAN1, LONV, DSX, DSY, & SCNMOD, LATIN1, LATIN2, LATSP, LONSP ENDIF ! CALL STME21 ( FTIME , IDTIME ) WRITE (NDSO,948) IDTIME, CID, PID, GID, GDS ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 4. Read general data and first fields from file ! 4.a Read file. ! CALL W3IOGO ( 'READ', NDSOG, IOTEST ) ! ! 4.b Output fields in file ! WRITE (NDSO,930) DO I=1, NOGRP DO J=1, NGRPP IF ( FLOGRD(I,J) ) WRITE (NDSO,931) IDOUT(I,J) END DO END DO ! IF ( GDTN .EQ. 0 ) THEN ! 4.c Flip MAPSF for REGULAR/RECTILINEAR grids ! DO ISEA=1, NSEA IX = MAPSF(ISEA,1) IY = MAPSF(ISEA,2) MAPSF(ISEA,2) = NY + 1 - IY MAPSF(ISEA,3) = IY +( IX-1)*NY END DO ENDIF ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - ! 5. Set grib encoding parameter Sections ! ! ... Initialize KPDS and KGDS (for both NCEP1 and NCEP2) ! KPDS = 0 KGDS = 0 ! ! ... Set PDS GRIB1 elements ! ! ( 1) ID OF CENTER ! ( 2) GENERATING PROCESS ID NUMBER ! ( 3) GRID DEFINITION ! ( 4) GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) ! ** ( 5) INDICATOR OF PARAMETER ! ( 6) TYPE OF LEVEL ! ( 7) HEIGHT/PRESSURE , ETC OF LEVEL ! * ( 8) YEAR of century ! * ( 9) MONTH OF YEAR ! * (10) DAY OF MONTH ! * (11) HOUR OF DAY ! (12) MINUTE OF HOUR ! (13) INDICATOR OF FORECAST TIME UNIT ! * (14) TIME RANGE 1 ! (15) TIME RANGE 2 ! (16) TIME RANGE FLAG ! (17) NUMBER INCLUDED IN AVERAGE ! (18) VERSION NR OF GRIB SPECIFICATION ! (19) VERSION NR OF PARAMETER TABLE ! (20) NR MISSING FROM AVERAGE/ACCUMULATION ! * (21) CENTURY OF REFERENCE TIME OF DATA ! (22) UNITS DECIMAL SCALE FACTOR ! (23) SUBCENTER NUMBER ! (24) PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS ! (25) PDS BYTE 30, NOT USED ! ! * : Changing on the fly in main program ! ** : Changing on the fly in W3EXGB ! ! ... Set GDS GRIB1 elements ! ! ( 1) DATA REPRESENTATION TYPE ! ( 2) N(I) NR POINTS ON LATITUDE CIRCLE ! ( 3) N(J) NR POINTS ON LONGITUDE MERIDIAN ! ( 4) LA(1) LATITUDE OF ORIGIN ! ( 5) LO(1) LONGITUDE OF ORIGIN ! ( 6) RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) ! ( 7) LA(2) LATITUDE OF EXTREME POINT ! ( 8) LO(2) LONGITUDE OF EXTREME POINT ! ( 9) DI LONGITUDINAL DIRECTION OF INCREMENT ! (10) DJ LATITUDINAL DIRECTION INCREMENT ! (11) SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) ! (19) NUMBER OF VERTICAL COORDINATE PARAMETERS ! (20) OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE ! PARAMETERS OR OCTET NUMBER OF THE LIST OF NUMBERS ! OF POINTS IN EACH ROW OR 255 IF NEITHER ARE PRESENT ! (21) FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID ! (22) NUMBER OF WORDS IN EACH ROW ! ! ... Set GRIB2 packing arrays ! LCGRIB = 4*NX*NY ALLOCATE(CGRIB(LCGRIB)) ! ! ... Set GRIB2 Indicator Section ! ( 1) Discipline-GRIB Master Table Number (see Code Table 0.0) ! 0 = Metereological; 10 = Oceanographic ! ( 2) GRIB Edition Number ! ( 3) LISTSEC0 = 0 LISTSEC0(1) = 10 LISTSEC0(2) = 2 ! ! ... Set GRIB2 Identification Section ! ( 1) ID OF CENTER ! ( 2) ID OF SUB-CENTER ! ( 3) GRIB Master Tables Version Number (Code Table 1.0) ! ( 4) GRIB Local Tables Version Number (Code Table 1.0) ! ( 5) Significance of Reference Time (Code Table 1.2) ! * ( 6) YEAR (4 digits) ! * ( 7) MONTH OF YEAR ! * ( 8) DAY OF MONTH ! * ( 9) HOUR OF DAY ! (10) MINUTE OF HOUR ! (11) SECOND OF MINUTE ! (12) Production status of data (Code Table 1.3) ! (13) Type of processed data (Code Table 1.4) ! LISTSEC1 = 0 LISTSEC1(1) = CID LISTSEC1(3) = 2 LISTSEC1(4) = 1 LISTSEC1(5) = 1 LISTSEC1(13) = 1 ! ! ... Set GRIB2 IGDS elements ! ( 1) Source of grid definition (Code Table 3.0) ! ( 2) Number of grid points ! ( 3) Number of octets needed for each additional grid points definition ! ( 4) Interpretation of list for optional points definition (Code Table 3.11) ! ( 5) Grid definition template number (Code Table 3.1) ! IF ( GDTN .EQ. 30 .AND. GTYPE .EQ. CLGTYPE ) THEN IGDS = 0 ! Defined in code IGDS(2) = NX*NY IGDS(5)=GDTN IDEFNUM = 1 IDEFLIST = 0 ELSEIF ( GDTN .EQ. 0 ) THEN IGDS = 0 IGDS(2) = NX*NY IDEFNUM = 0 IDEFLIST = 0 ELSE WRITE(NDSE,*)'PROGRAM W3GRIB: SUPPORT FOR CHOSEN '// & 'GRIB2 GRID DEFINITION TEMPLATE NOT YET IMPLEMENTED' CALL EXTCDE ( 2 ) ENDIF ! ! ... Set GRIB2 KGDS elements ! ( 1) Coordinate system (6 = spherical coordinate system with radius of 6,371,229 m) ! ( 2) ! ( 3) ! ( 4) ! ( 5) ! ( 6) ! ( 7) ! ( 8) Number of points along parallel ! ( 9) Number of points along meridian ! (10) ! (11) ! (12) Latitude of first grid point ! (13) Longitude of first grid point ! (14) Res and comp flags ! (15) Latitude of last grid point ! (16) Longitude of last grid point ! (17) Increment of longitude ! (18) Increment of latitude ! (19) Scanning mode ! KGDS( 1) = 6 KGDS( 8) = NX KGDS( 9) = NY IF ( GDTN .EQ. 30 ) THEN X0 = MOD(XGRD(1,1) + 360.,360.) XN = MOD(XGRD(NY,NX) + 360., 360.) X0N = MOD(XGRD(NY,1) + 360., 360.) KGDS(11)=KNINT(1000000.*X0) Y0 = YGRD(1,1) YN = YGRD(NY,NX) Y0N = YGRD(NY,1) KGDS(10)=KNINT(1000000.*Y0) KGDS(12)=0 KGDS(13)=DBLE(1000000.*LATAN1) KGDS(14)=DBLE(1000000.*LONV) KGDS(15)=KNINT(1000000*DSX) KGDS(16)=KNINT(1000000*DSY) KGDS(17)=0 KGDS(18)=SCNMOD KGDS(19)=DBLE(1000000.*LATIN1) KGDS(20)=DBLE(1000000.*LATIN2) KGDS(21)=DBLE(1000000.*LATSP) KGDS(22)=DBLE(1000000.*LONSP) ELSEIF (GDTN .EQ. 0 ) THEN KGDS(12) = KNINT(1000000.*(Y0+(REAL(NY-1)*SY))) X0 = MOD(X0 + 360.,360.) KGDS(13) = KNINT(1000000.*X0) KGDS(14) = 48 KGDS(15) = KNINT(1000000.*Y0) XN = MOD(X0+REAL(NX-1)*SX + 360., 360.) KGDS(16) = KNINT(1000000.*XN) KGDS(17) = KNINT(1000000.*SX) KGDS(18) = KNINT(1000000.*SY) ENDIF ! ! ... Set GRIB2 PDS elements ! KPDSNUM (0 indicates forecast at a horizontal level) ! ( 1) Parameter category (Code Table 4.1) ! For oceanographic products -- 0 = waves; 1 = currents; 2 = ice ! For atmospheric products -- 2 = momentum ! ( 2) Parameter number (Code Table 4.2) ! ( 3) Generating process (Code Table 4.3) ! ( 4) Background generating process identifier (center specific) ! ( 5) Process or model number ! ( 6) Hours of observational data cutoff after reference time ! ( 7) Minutes of observational data cutoff after reference time ! ( 8) Indicator of forecast time unit (Code Table 4.4) ! ( 9) Time range ! (10) Type of level (Code Table 4.5) 1st level ! (11) Scaled factor of (10) ! (12) Scaled value of (10) ! (13) Type of level (Code Table 4.5) 2nd level ! (14) Scaled factor of (13) ! (15) Scaled value of (13) ! KPDSNUM = 0 KPDS( 3) = 2 KPDS( 4) = 0 KPDS( 5) = PID KPDS( 8) = 1 KPDS(10) = 1 KPDS(12) = 1 KPDS(13) = 255 ! ! ... Set GRIB2 vertical layer information ! NUMCOORD = 0 COORDLIST = 0.0 ! ! ... Set GRIB2 bitmap information ! 0 Bitmap is provided ! IBMP = 0 ! ! ... Set GRIB2 Data Representation Template Number (Code Table 5.0) ! ! Option to use when all data is masked out: IDRSNUM0 = 0 ! fallback if no data (all mask = false) ! ! Option for when data is present: !IDRSNUM1 = 40 !jpeg2000 *** SEGFAULTS in some linux ! clusters with Intel compiler *** !IDRSNUM1 = 0 !simple packing !IDRSNUM1 = 41 !png packing !IDRSNUM1 = 2 !Complex Packing (Grid Point Data) IDRSNUM1=32 ! Complex Packing (2nd order diff) ! ! ... Set GRIB2 IDRS elements ! ( 1) Reference value (R) (IEEE 32-bit floating-point value) ! ( 2) Binary Scale Factor (E) ! ( 3) Decimal Scale Factor (D) ! ( 4) Number of bits used for each packed value ! ( 5) Type of original field values (Code Table 5.1) ! ! IDRS0 is fallback if no data (all mask = false) IDRS0 = 0 IDRS0(3)= 2 ! IDRS1 is used if data is present (any mask /= false) IDRS1 = 0 IDRS1(3) = 2 IF(IDRSNUM1==31 .or. IDRSNUM1==32) THEN IDRS1(17)=MOD(IDRSNUM1,10) IDRSNUM1=3 IDRS1(6)=1 IDRS1(7)=1 call mkieee(undef,IDRS1(8),1) ENDIF ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 6. Time management. ! IOUT = 0 WRITE (NDSO,970) ! DO DTEST = DSEC21 ( TIME , TOUT ) IF ( DTEST .GT. 0. ) THEN CALL W3IOGO ( 'READ', NDSOG, IOTEST ) IF ( IOTEST .EQ. -1 ) THEN WRITE (NDSO,942) GOTO 888 END IF CYCLE END IF IF ( DTEST .LT. 0. ) THEN CALL TICK21 ( TOUT , DTREQ ) CYCLE END IF ! IOUT = IOUT + 1 CALL STME21 ( TOUT , IDTIME ) ! RFTIME = DSEC21 ( FTIME , TIME ) / 3600. IF ( RFTIME .LT. 0. ) THEN LISTSEC1( 6) = TIME(1)/10000 LISTSEC1( 7) = MOD(TIME(1),10000) / 100 LISTSEC1( 8) = MOD(TIME(1),100) LISTSEC1( 9) = TIME(2) / 10000 KPDS( 9) = 0 WRITE (NDSO,972) IDTIME ELSE LISTSEC1( 6) = FTIME(1)/10000 LISTSEC1( 7) = MOD(FTIME(1),10000) / 100 LISTSEC1( 8) = MOD(FTIME(1),100) LISTSEC1( 9) = FTIME(2) / 10000 KPDS( 9) = NINT(RFTIME) WRITE (NDSO,971) IDTIME, NINT(RFTIME) END IF ! CALL W3EXGB ( NX, NY, NSEA ) CALL TICK21 ( TOUT , DTREQ ) IF ( IOUT .GE. NOUT ) EXIT END DO ! GOTO 888 ! ! Escape locations read errors : ! 800 CONTINUE WRITE (NDSE,1000) IERR CALL EXTCDE ( 3 ) ! 801 CONTINUE WRITE (NDSE,1001) CALL EXTCDE ( 4 ) ! 802 CONTINUE WRITE (NDSE,1002) IERR CALL EXTCDE ( 5 ) ! 810 CONTINUE IF ( .NOT. FLAGLL ) THEN WRITE (NDSE,1010) CALL EXTCDE ( 10 ) END IF ! 888 CONTINUE WRITE (NDSO,999) ! ! Formats ! 900 FORMAT (/15X,' *** WAVEWATCH III GRIB output postp. *** '/ & 15X,'=============================================='/) 901 FORMAT ( ' Comment character is ''',A,''''/) 902 FORMAT (/' *** WARNING : NO GRIB PACKAGE LINKED ***'/) ! 920 FORMAT ( ' Grid name : ',A/) ! 930 FORMAT ( ' Fields in file : '/ & ' --------------------------') 931 FORMAT ( ' ',A) ! 940 FORMAT (/' Output time data : '/ & ' -----------------------------------------------------'/ & ' First time : ',A) 941 FORMAT ( ' Interval : ',A/ & ' Number of requests : ',I4) 942 FORMAT (/' End of file reached '/) ! 944 FORMAT (/' Requested output fields not yet available: '/ & ' -----------------------------------------------------') ! 945 FORMAT (/' Successfully requested output fields : '/ & ' -----------------------------------------------------') 946 FORMAT ( ' ',A,1X,A) ! 948 FORMAT (/' Additional GRIB parameters : '/ & ' -----------------------------------------------------'/ & ' Run time : ',A/ & ' GRIB center ID : ',I4/ & ' GRIB gen. proc. ID : ',I4/ & ' GRIB grid ID : ',I4/ & ' GRIB GDS parameter : ',I4) ! 970 FORMAT (//' Generating file '/ & ' -----------------------------------------------------') 971 FORMAT ( ' Data for ',A,' ',I3,'H forecast.') 972 FORMAT ( ' Data for ',A,' hindcast.') ! 999 FORMAT (/' End of program '/ & ' ========================================='/ & ' WAVEWATCH III GRIB output '/) ! 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRIB : '/ & ' ERROR IN OPENING INPUT FILE'/ & ' IOSTAT =',I5/) ! 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRIB : '/ & ' PREMATURE END OF INPUT FILE'/) ! 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRIB : '/ & ' ERROR IN READING FROM INPUT FILE'/ & ' IOSTAT =',I5/) ! 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3GRIB : '/ & ' OUTPUT REQUESTED FOR FIELDS THAT SHARE KPDS(5)'/ & ' FIRST FIELD : ',A/ & ' SECOND FIELD : ',A/) ! 1010 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRIB : '/ & ' GRIB REQUIRES SPHERICAL GRID'/) !/ !/ Internal subroutine W3EXGB ---------------------------------------- / !/ CONTAINS !/ ------------------------------------------------------------------- / SUBROUTINE W3EXGB ( NX, NY, NSEA ) !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | !/ | H. L. Tolman | !/ | A. Chawla | !/ | FORTRAN 90 | !/ | Last update : 16-Jul-2007 | !/ +-----------------------------------+ !/ !/ 10-Jun-1999 : Final FORTRAN 77 ( version 1.18 ) !/ 24-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) !/ Massive changes to logistics. !/ 29-Apr-2002 : Adding output fields 17-18. ( version 2.20 ) !/ 24-Dec-2004 : Multiple grid version. ( version 3.06 ) !/ 18-May-2007 : Update GRIB1 for partitioning. ( version 3.11 ) !/ 16-Jul-2007 : Adding GRIB2 capability ( version 3.11 ) !/ (A. Chawla) !/ ! 1. Purpose : ! ! Perform actual GRIB output. ! ! 3. Parameters : ! ! Parameter list ! ---------------------------------------------------------------- ! NX, NY, NSEA ! Int. I Array dimensions. ! ---------------------------------------------------------------- ! ! Internal parameters ! ---------------------------------------------------------------- ! X1, X2, XX, XY ! R.A. Output fields ! BITMAP L.A. Data / no data bitmap ! ---------------------------------------------------------------- ! ! 4. Subroutines used : ! ! Name Type Module Description ! ---------------------------------------------------------------- ! STRACE Subr. W3SERVMD Subroutine tracing. ! EXTCDE Subr. Id. Abort program as graceful as possible. ! W3S2XY Subr. Id. Convert from storage to spatial grid. ! PUTGB Subr. NCEP GRIB1 library routine. ! GRIBCREATE Subr. NCEP GRIB2 library routine. ! ADDGRID Subr. NCEP GRIB2 library routine. ! ADDFIELD Subr. NCEP GRIB2 library routine. ! GRIBEND Subr. NCEP GRIB2 library routine. ! WRYTE Subr. NCEP GRIB2 library routine. ! ---------------------------------------------------------------- ! ! 5. Called by : ! ! Program in which it is contained. ! ! 6. Error messages : ! ! None. ! ! 7. Remarks : ! ! - Note that arrays CX and CY of the main program now contain ! the absolute current speed and direction respectively. ! ! 8. Structure : ! ! See source code. ! ! 9. Switches : ! ! !/S Enable subroutine tracing. ! !/T Enable test output. ! !/NCEP1 NCEP IBM calls to GRIB1 packer. ! !/NCEP2 NCEP IBM calls to GRIB2 packer (follows updated grib2 ! tables under verification as of 02/10/2012). ! ! 10. Source code : ! !/ ------------------------------------------------------------------- / USE W3SERVMD, ONLY : W3S2XY !/ !/ ------------------------------------------------------------------- / !/ Parameter list !/ INTEGER, INTENT(IN) :: NX, NY, NSEA !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ INTEGER :: J, IXY, NDATA INTEGER :: IO REAL :: X1(NX*NY), X2(NX*NY), XX(NX*NY), & XY(NX*NY), CABS, UABS, & YY(NX*NY,0:NOSWLL), KPDS5A, KPDS5B LOGICAL*1 :: BITMAP(NX*NY) LOGICAL :: FLONE, FLTWO, FLDIR, FLTRI, FLPRT INTEGER :: NMASK !/ !/ ------------------------------------------------------------------- / !/ ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 1. Preparations ! X1 = UNDEF X2 = UNDEF XX = UNDEF XY = UNDEF YY = UNDEF ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 2. Loop over output fields. ! DO IFI=1, NOGRP DO IFJ=1, NGRPP IF ( FLREQ(IFI,IFJ) ) THEN ! ! Initialize array dimension flags ! FLONE = .FALSE. FLTWO = .FALSE. FLDIR = .FALSE. FLTRI = .FALSE. FLPRT = .FALSE. ! ! 2.a Set output arrays and parameters ! ! Water depth ! IF ( IFI .EQ. 1 .AND. IFJ .EQ. 1 ) THEN FLONE = .TRUE. KPDS(2) = 255 KPDS(1) = 255 CALL W3S2XY ( NSEA, NSEA, NX, NY, DW(1:NSEA) & , MAPSF, X1 ) ! ! Current ! ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 2 ) THEN FLTWO = .TRUE. KPDS(2) = 1 KPDS(1) = 1 CALL W3S2XY ( NSEA, NSEA, NX, NY, CX(1:NSEA) & , MAPSF, XX ) CALL W3S2XY ( NSEA, NSEA, NX, NY, CY(1:NSEA) & , MAPSF, XY ) DO ISEA=1, NSEA IF (CX(ISEA) .NE. UNDEF) THEN CABS = SQRT(CX(ISEA)**2+CY(ISEA)**2) IF ( CABS .GT. 0.001 ) THEN CY(ISEA) = MOD ( 630. - & RADE*ATAN2(CY(ISEA),CX(ISEA)) , 360. ) ELSE CY(ISEA) = 0. END IF ELSE CABS = UNDEF CY(ISEA) = UNDEF END IF CX(ISEA) = CABS END DO CALL W3S2XY ( NSEA, NSEA, NX, NY, CX(1:NSEA) & , MAPSF, X1 ) CALL W3S2XY ( NSEA, NSEA, NX, NY, CY(1:NSEA) & , MAPSF, X2 ) ! ! Wind speed ! ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 3 ) THEN FLTWO = .TRUE. KPDS(2) = 1 KPDS(1) = 2 LISTSEC0(1) = 0 CALL W3S2XY ( NSEA, NSEA, NX, NY, UA(1:NSEA) & , MAPSF, XX ) CALL W3S2XY ( NSEA, NSEA, NX, NY, UD(1:NSEA) & , MAPSF, XY ) DO ISEA=1, NSEA IF (UA(ISEA) .NE. UNDEF) THEN UABS = SQRT(UA(ISEA)**2+UD(ISEA)**2) IF ( UABS .GT. 0.001 ) THEN UD(ISEA) = MOD ( 630. - & RADE*ATAN2(UD(ISEA),UA(ISEA)) , 360. ) ELSE UD(ISEA) = 0. END IF ELSE UABS = UNDEF UD(ISEA) = UNDEF END IF UA(ISEA) = UABS END DO CALL W3S2XY ( NSEA, NSEA, NX, NY, UA(1:NSEA) & , MAPSF, X1 ) CALL W3S2XY ( NSEA, NSEA, NX, NY, UD(1:NSEA) & , MAPSF, X2 ) ! ! Air-sea temp. dif. ! ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 4 ) THEN FLONE = .TRUE. KPDS(2) = 255 KPDS(1) = 255 CALL W3S2XY ( NSEA, NSEA, NX, NY, AS(1:NSEA) & , MAPSF, X1 ) ! ! Water level ! ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 5 ) THEN FLONE = .TRUE. KPDS(2) = 1 KPDS(1) = 3 CALL W3S2XY ( NSEA, NSEA, NX, NY, WLV , MAPSF, X1 ) ! ! Ice concentration ! ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 6 ) THEN FLONE = .TRUE. KPDS(2) = 0 KPDS(1) = 2 CALL W3S2XY ( NSEA, NSEA, NX, NY, ICE , MAPSF, X1 ) ! ! Significant wave height ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 1 ) THEN FLONE = .TRUE. KPDS(2) = 3 CALL W3S2XY ( NSEA, NSEA, NX, NY, HS , MAPSF, X1 ) ! ! Mean wave length ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 2 ) THEN FLONE = .TRUE. KPDS(2) = 255 CALL W3S2XY ( NSEA, NSEA, NX, NY, WLM , MAPSF, X1 ) ! ! Mean wave period (based on second moment) ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 3 ) THEN FLONE = .TRUE. KPDS(2) = 28 CALL W3S2XY ( NSEA, NSEA, NX, NY, T02 , MAPSF, X1 ) ! ! Mean wave period (based on first moment) ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 4 ) THEN FLONE = .TRUE. KPDS(2) = 15 CALL W3S2XY ( NSEA, NSEA, NX, NY, T0M1 , MAPSF, X1 ) ! ! Mean wave period (based on first inverse moment) ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 5 ) THEN FLONE = .TRUE. KPDS(2) = 25 CALL W3S2XY ( NSEA, NSEA, NX, NY, T01 , MAPSF, X1 ) ! ! Peak frequency ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 6 ) THEN FLONE = .TRUE. KPDS(2) = 11 DO ISEA=1, NSEA IF ( FP0(ISEA) .NE. UNDEF .AND. FP0(ISEA) .NE. 0 ) THEN FP0(ISEA) = 1. / FP0(ISEA) END IF END DO CALL W3S2XY ( NSEA, NSEA, NX, NY, FP0 , MAPSF, X1 ) ! ! Mean wave direction ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 7 ) THEN FLONE = .TRUE. KPDS(2) = 14 DO ISEA=1, NSEA IF ( THM(ISEA) .NE. UNDEF ) & THM(ISEA) = MOD ( 630. - RADE*THM(ISEA) , 360. ) END DO CALL W3S2XY ( NSEA, NSEA, NX, NY, THM , MAPSF, X1 ) ! ! Directional spread ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 8 ) THEN FLONE = .TRUE. KPDS(2) = 31 CALL W3S2XY ( NSEA, NSEA, NX, NY, THS , MAPSF, X1 ) ! ! Peak direction ! ELSE IF ( IFI .EQ. 2 .AND. IFJ .EQ. 9 ) THEN FLONE = .TRUE. KPDS(2) = 10 DO ISEA=1, NSEA IF ( THP0(ISEA) .NE. UNDEF ) THEN THP0(ISEA) = MOD ( 630-RADE*THP0(ISEA) , 360. ) END IF END DO CALL W3S2XY ( NSEA, NSEA, NX, NY, THP0 , MAPSF, X1 ) ! ! Partitioned wave height ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 1 ) THEN FLPRT = .TRUE. KPDS5A = 5 KPDS5B = 8 CALL W3S2XY & ( NSEA, NSEA, NX, NY, PHS(:,0), MAPSF, YY(:,0) ) DO I=1, NOSWLL CALL W3S2XY & ( NSEA, NSEA, NX, NY, PHS(:,I), MAPSF, YY(:,I) ) END DO ! ! Partitioned peak period ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 2 ) THEN FLPRT = .TRUE. KPDS5A = 6 KPDS5B = 9 CALL W3S2XY & ( NSEA, NSEA, NX, NY, PTP(:,0), MAPSF, YY(:,0) ) DO I=1, NOSWLL CALL W3S2XY & ( NSEA, NSEA, NX, NY, PTP(:,I), MAPSF, YY(:,I) ) END DO ! ! Partitioned peak wave length ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 3 ) THEN FLPRT = .TRUE. KPDS5A = 255 KPDS5B = 255 CALL W3S2XY & ( NSEA, NSEA, NX, NY, PLP(:,0), MAPSF, YY(:,0) ) DO I=1, NOSWLL CALL W3S2XY & ( NSEA, NSEA, NX, NY, PLP(:,I), MAPSF, YY(:,I) ) END DO ! ! Partitioned mean direction ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 4 ) THEN FLPRT = .TRUE. KPDS5A = 4 KPDS5B = 7 DO ISEA = 1,NSEA DO I = 0,NOSWLL IF ( PDIR(ISEA,I) .NE. UNDEF ) THEN PDIR(ISEA,I) = MOD ( 630 - RADE*PDIR(ISEA,I) , 360. ) END IF END DO END DO CALL W3S2XY & ( NSEA, NSEA, NX, NY, PDIR(:,0), MAPSF, YY(:,0) ) DO I=1, NOSWLL CALL W3S2XY & ( NSEA, NSEA, NX, NY, PDIR(:,I), MAPSF, YY(:,I) ) END DO ! ! Partitioned Directional spread ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 5 ) THEN FLPRT = .TRUE. KPDS5A = 255 KPDS5B = 255 CALL W3S2XY & ( NSEA, NSEA, NX, NY, PSI(:,0), MAPSF, YY(:,0) ) DO I=1, NOSWLL CALL W3S2XY & ( NSEA, NSEA, NX, NY, PSI(:,I), MAPSF, YY(:,I) ) END DO ! ! Partitioned wind sea fraction ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 6 ) THEN FLPRT = .TRUE. KPDS5A = 255 KPDS5B = 255 CALL W3S2XY & ( NSEA, NSEA, NX, NY, PWS(:,0), MAPSF, YY(:,0) ) DO I=1, NOSWLL CALL W3S2XY & ( NSEA, NSEA, NX, NY, PWS(:,I), MAPSF, YY(:,I) ) END DO ! ! Total wind sea fraction ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 7 ) THEN FLONE = .TRUE. KPDS(2) = 255 CALL W3S2XY ( NSEA, NSEA, NX, NY, PWST , MAPSF, X1 ) ! ! Number of fields in partition ! ELSE IF ( IFI .EQ. 4 .AND. IFJ .EQ. 8 ) THEN FLONE = .TRUE. KPDS(2) = 255 CALL W3S2XY ( NSEA, NSEA, NX, NY, PNR , MAPSF, X1 ) ! ! Friction velocity ! ELSE IF ( IFI .EQ. 5 .AND. IFJ .EQ. 1 ) THEN FLTWO = .TRUE. KPDS(2) = 255 KPDS(1) = 1 CALL W3S2XY ( NSEA, NSEA, NX, NY, UST(1:NSEA) & , MAPSF, X1 ) CALL W3S2XY ( NSEA, NSEA, NX, NY, USTDIR(1:NSEA) & , MAPSF, X2 ) ! ! Average source term time step ! ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 1 ) THEN FLONE = .TRUE. KPDS(2) = 255 DO ISEA=1, NSEA IF ( DTDYN(ISEA) .NE. UNDEF ) & DTDYN(ISEA) = DTDYN(ISEA) / 60. END DO CALL W3S2XY ( NSEA, NSEA, NX, NY, DTDYN , MAPSF, X1 ) ! ! Cut-off frequency ! ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 2 ) THEN FLONE = .TRUE. KPDS(2) = 255 CALL W3S2XY ( NSEA, NSEA, NX, NY, FCUT , MAPSF, X1 ) ! ! CFL Maximum (in spatial space) ! ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 3 ) THEN FLONE = .TRUE. KPDS(2) = 255 CALL W3S2XY ( NSEA, NSEA, NX, NY, CFLXYMAX , MAPSF, X1 ) ! ! CFL Maximum (in spectral space) ! ELSE IF ( IFI .EQ. 9 .AND. IFJ .EQ. 4 ) THEN FLONE = .TRUE. KPDS(2) = 255 CALL W3S2XY ( NSEA, NSEA, NX, NY, CFLTHMAX , MAPSF, X1 ) ! ELSE WRITE (NDSE,999) CALL EXTCDE ( 1 ) ! END IF ! ! 3 Perform output ! NDATA = NX*NY ! ! 3.a Partitioned data ! IF ( FLPRT ) THEN ! KPDS(2) = KPDS5A NMASK=0 DO IXY=1, NX*NY BITMAP(IXY) = YY(IXY,0) .NE. UNDEF IF(YY(IXY,0) .NE. UNDEF) THEN NMASK=NMASK+1 ENDIF END DO if(nmask==0) then IDRS=IDRS0 IDRSNUM=IDRSNUM0 else IDRS=IDRS1 IDRSNUM=IDRSNUM1 end if CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) IF (IO .NE. 0) GOTO 810 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & IDEFNUM, IO) IF (IO .NE. 0) GOTO 820 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & COORDLIST,NUMCOORD,IDRSNUM, IDRS, & 200,YY(:,0), NDATA, IBMP, BITMAP, IO) IF (IO .NE. 0) GOTO 820 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) IF (IO .NE. 0) GOTO 830 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) ! KPDS(2) = KPDS5B KPDS(10) = 241 DO I=1, NOSWLL KPDS(12) = I NMASK=0 DO IXY=1, NX*NY BITMAP(IXY) = YY(IXY,I) .NE. UNDEF IF(YY(IXY,I) .NE. UNDEF) THEN NMASK=NMASK+1 ENDIF END DO if(nmask==0) then IDRS=IDRS0 IDRSNUM=IDRSNUM0 else IDRS=IDRS1 IDRSNUM=IDRSNUM1 end if CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) IF (IO .NE. 0) GOTO 810 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & IDEFNUM, IO) IF (IO .NE. 0) GOTO 820 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & COORDLIST, NUMCOORD,IDRSNUM, IDRS,& 200,YY(:,I), NDATA, IBMP, BITMAP, IO) IF (IO .NE. 0) GOTO 820 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) IF (IO .NE. 0) GOTO 830 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) END DO KPDS(10) = 1 KPDS(12) = 1 ! ! 3.b Other data ! ELSE IF (FLONE) THEN ! NMASK=0 DO IXY=1, NX*NY BITMAP(IXY) = X1(IXY) .NE. UNDEF IF(X1(IXY) .NE. UNDEF) THEN NMASK=NMASK+1 ENDIF END DO if(nmask==0) then IDRS=IDRS0 IDRSNUM=IDRSNUM0 else IDRS=IDRS1 IDRSNUM=IDRSNUM1 end if CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) IF (IO .NE. 0) GOTO 810 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & IDEFNUM, IO) IF (IO .NE. 0) GOTO 820 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & COORDLIST, NUMCOORD, IDRSNUM, IDRS, & 200,X1, NDATA, IBMP, BITMAP, IO) IF (IO .NE. 0) GOTO 820 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) IF (IO .NE. 0) GOTO 830 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) ! ELSE IF ( FLTWO ) THEN ! NMASK=0 DO IXY=1, NX*NY BITMAP(IXY) = X1(IXY) .NE. UNDEF IF(X1(IXY) .NE. UNDEF) THEN NMASK=NMASK+1 ENDIF END DO if(nmask==0) then IDRS=IDRS0 IDRSNUM=IDRSNUM0 else IDRS=IDRS1 IDRSNUM=IDRSNUM1 end if CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) IF (IO .NE. 0) GOTO 810 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & IDEFNUM, IO) IF (IO .NE. 0) GOTO 820 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & COORDLIST,NUMCOORD,IDRSNUM,IDRS, & 200,X1, NDATA, IBMP, BITMAP, IO) IF (IO .NE. 0) GOTO 820 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) IF (IO .NE. 0) GOTO 830 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) KPDS(2) = 0 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) IF (IO .NE. 0) GOTO 810 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & IDEFNUM, IO) IF (IO .NE. 0) GOTO 820 if(nmask==0) then IDRS=IDRS0 IDRSNUM=IDRSNUM0 else IDRS=IDRS1 IDRSNUM=IDRSNUM1 end if CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & COORDLIST,NUMCOORD,IDRSNUM,IDRS, & 200,X2, NDATA, IBMP, BITMAP, IO) IF (IO .NE. 0) GOTO 820 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) IF (IO .NE. 0) GOTO 830 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) KPDS(2) = 2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) IF (IO .NE. 0) GOTO 810 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & IDEFNUM, IO) IF (IO .NE. 0) GOTO 820 if(nmask==0) then IDRS=IDRS0 IDRSNUM=IDRSNUM0 else IDRS=IDRS1 IDRSNUM=IDRSNUM1 end if CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & COORDLIST,NUMCOORD,IDRSNUM,IDRS, & 200,XX, NDATA, IBMP, BITMAP, IO) IF (IO .NE. 0) GOTO 820 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) IF (IO .NE. 0) GOTO 830 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) KPDS(2) = 3 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) IF (IO .NE. 0) GOTO 810 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & IDEFNUM, IO) IF (IO .NE. 0) GOTO 820 if(nmask==0) then IDRS=IDRS0 IDRSNUM=IDRSNUM0 else IDRS=IDRS1 IDRSNUM=IDRSNUM1 end if CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & COORDLIST,NUMCOORD,IDRSNUM,IDRS, & 200,XY, NDATA, IBMP, BITMAP, IO) IF (IO .NE. 0) GOTO 820 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) IF (IO .NE. 0) GOTO 830 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) ! END IF LISTSEC0(1) = 10 KPDS(1) = 0 ! ! ... End of fields loop ! END IF END DO END DO ! RETURN ! ! Error escape locations ! 800 CONTINUE WRITE (NDSE,1000) IERR CALL EXTCDE ( 10 ) 810 CONTINUE WRITE (NDSE,1010) IO CALL EXTCDE ( 20 ) 820 CONTINUE WRITE (NDSE,1020) IO CALL EXTCDE ( 30 ) 830 CONTINUE WRITE (NDSE,1030) IO CALL EXTCDE ( 40 ) ! ! Formats ! 940 FORMAT (1X,I8,3I3.2,2X,4E12.4) 950 FORMAT (1X,A13,I9.8,I7.6,2(2F8.2,I4), & 1X,A4,F8.4,1X,A10,2I2,1X,A11,I4) 951 FORMAT (1X,2F10.5,2I8) ! 999 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB :'/ & ' PLEASE UPDATE FIELDS !!! '/) ! 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & ' ERROR IN OPENING OUTPUT FILE'/ & ' IOSTAT =',I5/) ! 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & ' ERROR CREATING NEW GRIB2 FIELD'/ & ' IOSTAT =',I5/) ! 1020 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & ' ERROR ADDING GRIB2 FIELD'/ & ' IOSTAT =',I5/) ! 1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & ' ERROR ENDING GRIB2 MESSAGE'/ & ' IOSTAT =',I5/) ! !/ !/ End of W3EXGB ----------------------------------------------------- / !/ END SUBROUTINE W3EXGB !/ !/ End of W3GRIB ----------------------------------------------------- / !/ END PROGRAM W3GRIB