#include "w3macros.h" !/ ------------------------------------------------------------------- / PROGRAM W3GRIB !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | !/ | H. L. Tolman | !/ | A. Chawla | !/ | J.-H. Alves | !/ | FORTRAN 90 | !/ | Last update : 26-Jul-2018 | !/ +-----------------------------------+ !/ !/ 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) !/ 26-Jul-2018 : Adding polar stereographic grid ( version 6.05 ) !/ (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 !/S USE W3SERVMD, ONLY : STRACE 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 !/NOGRB INTEGER :: KPDS(1), KGDS(1) !/NCEP1 INTEGER :: KPDS(25), KGDS(22) ! GRIB2 specific variables !/NCEP2 INTEGER :: KPDS(200), KGDS(200), IDRS(200) !/NCEP2 INTEGER :: LISTSEC0(3), LISTSEC1(13),IGDS(5) !/NCEP2 INTEGER :: IDEFLIST, IDEFNUM, KPDSNUM, NUMCOORD !/NCEP2 INTEGER :: IBMP, LCGRIB, LENGRIB, IDRSNUM !/NCEP2 REAL :: COORDLIST, XN !/NCEP2 CHARACTER(LEN=1), ALLOCATABLE :: CGRIB(:) !/NCEP2 INTEGER :: LATAN1, LONV, SCNMOD, LATIN1, & !/NCEP2 LATIN2, LATSP, LONSP !/NCEP2 REAL :: DSX, DSY !/NCEP2 REAL :: YN, X0N, Y0N !/S INTEGER, SAVE :: IENT = 0 REAL :: DTREQ, DTEST, RFTIME LOGICAL :: FLREQ(NOGRP,NGRPP), FLGRIB(NOGRP,NGRPP) CHARACTER :: COMSTR*1, IDTIME*23, IDDDAY*11 !/ !/ ------------------------------------------------------------------- / !/ !/NCO/! CALL W3TAGB('WAVEGRIB',1998,0007,0050,'NP21 ') ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 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 ! !/NCO/! !/NCO/! Redo according to NCO !/NCO/! !/NCO NDSI = 11 !/NCO NDSO = 6 !/NCO NDSE = NDSO !/NCO NDST = NDSO !/NCO NDSM = 12 !/NCO NDSOG = 13 !/NCO NDSDAT = 51 !/NCO NDSTRC = NDSO ! WRITE (NDSO,900) ! CALL ITRACE ( NDSTRC, NTRACE ) !/S CALL STRACE (IENT, 'W3GRIB') ! 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 ! !/NOGRB WRITE (NDSE,902) !/NCEP1 CALL BAOPEN (NDSDAT,'gribfile',IERR) !/NCEP2 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 ! or PolarStereo ! IF ( GTYPE .EQ. CLGTYPE ) THEN !/NCEP2! Allowing code to work with Lambert conformal grids !/NCEP2 IF ( GDTN .NE. 30 .AND. GDTN .NE. 20 ) THEN WRITE(NDSE,*)'PROGRAM W3GRIB: CURVILINEAR GRID SUPPORT '// & 'FOR GRIB OUTPUT IS NOT YET IMPLEMENTED. NOW STOPPING' CALL EXTCDE ( 1 ) !/NCEP2 ENDIF END IF ! ! ! Coded up to now only for Lamber conformal grids (GDTN=30) or ! PolarStereo (GDTN=20). For regular grids use GDTN=0 ! !/NCEP2 IF ( GDTN .EQ. 30 ) THEN !/NCEP2! This is a Lambert conformal grid, read projection parameters !/NCEP2 CALL NEXTLN ( COMSTR , NDSI , NDSE ) !/NCEP2 READ (NDSI,*,END=801,ERR=802) LATAN1, LONV, DSX, DSY, & !/NCEP2 SCNMOD, LATIN1, LATIN2, LATSP, LONSP !/NCEP2 ELSEIF ( GDTN .EQ. 20 ) THEN !/NCEP2 CALL NEXTLN ( COMSTR , NDSI , NDSE ) !/NCEP2 READ (NDSI,*,END=801,ERR=802) LATAN1, LONV, DSX, DSY, & !/NCEP2 SCNMOD !/NCEP2 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 ! !/NCEP2! !/NCEP2 IF ( GDTN .EQ. 0 ) THEN !/NCEP2! ! 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 !/NCEP2! !/NCEP2 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 ! !/NCEP1 KPDS( 1) = CID !/NCEP1 KPDS( 2) = PID !/NCEP1 KPDS( 3) = GID !/NCEP1 KPDS( 4) = GDS !/NCEP1 KPDS( 6) = 1 !/NCEP1 KPDS( 7) = 1 !/NCEP1 KPDS(13) = 1 !/NCEP1 KPDS(18) = 1 !/NCEP1 KPDS(22) = 2 ! ! ... 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 ! !/NCEP1 KGDS( 2) = NX !/NCEP1 KGDS( 3) = NY !/NCEP1 KGDS( 4) = NINT(1000.*(Y0+(REAL(NY-1)*SY))) !/NCEP1 KGDS( 5) = NINT(1000.*X0) !/NCEP1 KGDS( 6) = 128 !/NCEP1 KGDS( 7) = NINT(1000.*Y0) !/NCEP1 KGDS( 8) = NINT(1000.*(X0+REAL(NX-1)*SX)) !/NCEP1 KGDS( 9) = NINT(1000.*SX) !/NCEP1 KGDS(10) = NINT(1000.*SY) !/NCEP1 KGDS(20) = 255 ! ! ... Set GRIB2 packing arrays ! !/NCEP2 LCGRIB = 4*NX*NY !/NCEP2 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) !/NCEP2 LISTSEC0 = 0 !/NCEP2 LISTSEC0(1) = 10 !/NCEP2 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) ! !/NCEP2 LISTSEC1 = 0 !/NCEP2 LISTSEC1(1) = CID !/NCEP2 LISTSEC1(3) = 2 !/NCEP2 LISTSEC1(4) = 1 !/NCEP2 LISTSEC1(5) = 1 !/NCEP2 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) ! !/NCEP2 IGDS = 0 ! Defined in code !/NCEP2 IGDS(2) = NX*NY !/NCEP2 IDEFNUM = 0 !/NCEP2 IDEFLIST = 0 !/NCEP2 IGDS(5)=GDTN !/NCEP2 IF ( GDTN .EQ. 30 .AND. GTYPE .EQ. CLGTYPE ) THEN !/NCEP2 IDEFNUM = 1 !/NCEP2 WRITE (NDSO,1011) 'LAMBERTCONF' !/NCEP2 ELSEIF ( GDTN .EQ. 20 .AND. GTYPE .EQ. CLGTYPE ) THEN !/NCEP2 WRITE (NDSO,1011) 'POLARSTEREO' !/NCEP2 ELSEIF ( GDTN .EQ. 0 ) THEN !/NCEP2 WRITE (NDSO,1011) 'LLRECTILINEAR' !/NCEP2 ELSE !/NCEP2 WRITE(NDSE,*)'PROGRAM WAVEGRIB2: SUPPORT FOR CHOSEN '// & !/NCEP2 'GRIB2 GRID DEFINITION TEMPLATE NOT YET IMPLEMENTED' !/NCEP2 CALL EXTCDE ( 2 ) !/NCEP2 ENDIF ! ! ... Set GRIB2 KGDS elements ! ! General parameters for all grids ! ( 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 !/NCEP2 KGDS( 1) = 6 !/NCEP2 KGDS( 8) = NX !/NCEP2 KGDS( 9) = NY ! !/NCEP2 IF ( GDTN .EQ. 30 ) THEN ! ! Lambert Conformal grid ! (10) Latitude of first grid point ! (11) Longitude of first grid point ! (12) Resolution and component flags ! (13) Latitude where DX and DY are specified ! (14) Longitude of orientation ! (15) Increment of longitude ! (16) Increment of latitude ! (17) Projection center flag ! (18) Scanning mode ! (19) First latitude of secant cone ! (20) Second latitude of secant cone ! (21) Latitude of southern pole ! (22) Longitude of southern pole ! !/NCEP2 X0 = MOD(XGRD(1,1) + 360.,360.) !/NCEP2 XN = MOD(XGRD(NY,NX) + 360., 360.) !/NCEP2 X0N = MOD(XGRD(NY,1) + 360., 360.) !/NCEP2 KGDS(11)=KNINT(1000000.*X0) !/NCEP2 Y0 = YGRD(1,1) !/NCEP2 YN = YGRD(NY,NX) !/NCEP2 Y0N = YGRD(NY,1) !/NCEP2 KGDS(10)=KNINT(1000000.*Y0) !/NCEP2 KGDS(12)=0 !/NCEP2 KGDS(13)=DBLE(1000000.*LATAN1) !/NCEP2 KGDS(14)=DBLE(1000000.*LONV) !/NCEP2 KGDS(15)=KNINT(1000000*DSX) !/NCEP2 KGDS(16)=KNINT(1000000*DSY) !/NCEP2 KGDS(17)=0 !/NCEP2 KGDS(18)=SCNMOD !/NCEP2 KGDS(19)=DBLE(1000000.*LATIN1) !/NCEP2 KGDS(20)=DBLE(1000000.*LATIN2) !/NCEP2 KGDS(21)=DBLE(1000000.*LATSP) !/NCEP2 KGDS(22)=DBLE(1000000.*LONSP) ! !/NCEP2 ELSEIF (GDTN .EQ. 20 ) THEN ! ! PolarStereo grid ! (10) Latitude of first grid point ! (11) Longitude of first grid point ! (12) Res and component flags ! (13) Latitude where DX and DY are specified ! (14) Longitude of orientation ! (15) Increment of longitude ! (16) Increment of latitude ! (17) Projection center flag ! (18) Scanning mode ! !/NCEP2 X0 = MOD(XGRD(1,1) + 360.,360.) !/NCEP2 XN = MOD(XGRD(NY,NX) + 360., 360.) !/NCEP2 X0N = MOD(XGRD(NY,1) + 360., 360.) !/NCEP2 KGDS(11)=KNINT(1000000.*X0) !/NCEP2 Y0 = YGRD(1,1) !/NCEP2 YN = YGRD(NY,NX) !/NCEP2 Y0N = YGRD(NY,1) !/NCEP2 KGDS(10)=KNINT(1000000.*Y0) !/NCEP2 KGDS(12)=0 !/NCEP2 KGDS(13)=DBLE(1000000.*LATAN1) !/NCEP2 KGDS(14)=DBLE(1000000.*LONV) !/NCEP2 KGDS(15)=KNINT(1000000*DSX) !/NCEP2 KGDS(16)=KNINT(1000000*DSY) !/NCEP2 KGDS(17)=0 !/NCEP2 KGDS(18)=SCNMOD ! !/NCEP2 ELSEIF (GDTN .EQ. 0 ) THEN ! ! Lat Lon rectilinear grid ! (10) ! (11) ! (12) Latitude of first grid point ! (13) Longitude of first grid point ! (14) Res and component flags ! (15) Latitude of last grid point ! (16) Longitude of last grid point ! (17) Increment of longitude ! (18) Increment of latitude ! (19) Scanning mode ! !/NCEP2 KGDS(12) = KNINT(1000000.*(Y0+(REAL(NY-1)*SY))) !/NCEP2 X0 = MOD(X0 + 360.,360.) !/NCEP2 KGDS(13) = KNINT(1000000.*X0) !/NCEP2 KGDS(14) = 48 !/NCEP2 KGDS(15) = KNINT(1000000.*Y0) !/NCEP2 XN = MOD(X0+REAL(NX-1)*SX + 360., 360.) !/NCEP2 KGDS(16) = KNINT(1000000.*XN) !/NCEP2 KGDS(17) = KNINT(1000000.*SX) !/NCEP2 KGDS(18) = KNINT(1000000.*SY) !/NCEP2 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) ! !/NCEP2 KPDSNUM = 0 !/NCEP2 KPDS( 3) = 2 !/NCEP2 KPDS( 4) = 0 !/NCEP2 KPDS( 5) = PID !/NCEP2 KPDS( 8) = 1 !/NCEP2 KPDS(10) = 1 !/NCEP2 KPDS(12) = 1 !/NCEP2 KPDS(13) = 255 ! ! ... Set GRIB2 vertical layer information ! !/NCEP2 NUMCOORD = 0 !/NCEP2 COORDLIST = 0.0 ! ! ... Set GRIB2 bitmap information ! 0 Bitmap is provided ! !/NCEP2 IBMP = GDS ! ! ... Set GRIB2 Data Representation Template Number (Code Table 5.0) ! !/NCEP2 IDRSNUM = 40 !jpeg2000 *** SEGFAULTS in some linux ! clusters with Intel compiler *** !/NCEP2 !IDRSNUM = 0 !simple packing !/NCEP2 !IDRSNUM = 41 !png packing !/NCEP2 !IDRSNUM = 2 !Complex Packing (Grid Point Data) ! ! ... 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) ! !/NCEP2 IDRS = 0 !/NCEP2 IDRS(3) = 2 ! !/T WRITE (NDST,9050) KPDS !/T WRITE (NDST,9051) KGDS ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 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 !/NCEP1 KPDS( 8) = 1 + MOD(TIME(1)/10000-1,100) !/NCEP1 KPDS( 9) = MOD(TIME(1),10000) / 100 !/NCEP1 KPDS(10) = MOD(TIME(1),100) !/NCEP1 KPDS(11) = TIME(2) / 10000 !/NCEP1 KPDS(14) = 0 !/NCEP1 KPDS(21) = 1 + (TIME(1)/10000-1)/100 !/NCEP2 LISTSEC1( 6) = TIME(1)/10000 !/NCEP2 LISTSEC1( 7) = MOD(TIME(1),10000) / 100 !/NCEP2 LISTSEC1( 8) = MOD(TIME(1),100) !/NCEP2 LISTSEC1( 9) = TIME(2) / 10000 !/NCEP2 KPDS( 9) = 0 WRITE (NDSO,972) IDTIME ELSE !/NCEP1 KPDS( 8) = 1 + MOD(FTIME(1)/10000-1,100) !/NCEP1 KPDS( 9) = MOD(FTIME(1),10000) / 100 !/NCEP1 KPDS(10) = MOD(FTIME(1),100) !/NCEP1 KPDS(11) = FTIME(2) / 10000 !/NCEP1 KPDS(14) = NINT(RFTIME) !/NCEP1 KPDS(21) = 1 + (FTIME(1)/10000-1)/100 !/NCEP2 LISTSEC1( 6) = FTIME(1)/10000 !/NCEP2 LISTSEC1( 7) = MOD(FTIME(1),10000) / 100 !/NCEP2 LISTSEC1( 8) = MOD(FTIME(1),100) !/NCEP2 LISTSEC1( 9) = FTIME(2) / 10000 !/NCEP2 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) ! !/NCO/! CALL W3TAGE('WAVEGRIB') ! ! 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 '/) ! !/T 9050 FORMAT ( ' TEST W3GRIB : KPDS : ',13I4/ & !/T ' ',12I4) !/T 9051 FORMAT ( ' TEST W3GRIB : KGDS : ',8I6/ & !/T ' ',8I6/ & !/T ' ',6I6) ! 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/) ! 1010 FORMAT (/' *** WAVEWATCH-III ERROR IN W3GRIB : '/ & ' GRIB REQUIRES SPHERICAL GRID'/) !/NCEP2 1011 FORMAT (/' CHOSEN GRID TYPE: : ',A/) !/ !/ 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 !/RTD USE W3SERVMD, ONLY : W3THRTN, W3XYRTN !/ !/ ------------------------------------------------------------------- / !/ Parameter list !/ INTEGER, INTENT(IN) :: NX, NY, NSEA !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ INTEGER :: J, IXY, NDATA INTEGER :: IO !/S INTEGER, SAVE :: IENT = 0 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 !/ !/ ------------------------------------------------------------------- / !/ !/S CALL STRACE (IENT, 'W3EXGB') ! !/T WRITE (NDST,9000) ((FLREQ(IFI,IFJ),IFJ=1,NGRPP), IFI=1,NOGRP) !/T WRITE (NDST,9001) NDSDAT, KPDS, KGDS ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 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. ! !/T WRITE (NDST,9020) IDOUT(IFI,IFJ) ! ! 2.a Set output arrays and parameters ! ! Water depth ! IF ( IFI .EQ. 1 .AND. IFJ .EQ. 1 ) THEN FLONE = .TRUE. !/NCEP1 KPDS(5) = -1 !/NCEP2 KPDS(2) = 14 !/NCEP2 KPDS(1) = 4 CALL W3S2XY ( NSEA, NSEA, NX, NY, DW(1:NSEA) & , MAPSF, X1 ) ! ! Current ! ELSE IF ( IFI .EQ. 1 .AND. IFJ .EQ. 2 ) THEN FLTWO = .TRUE. !/NCEP1 KPDS(5) = -1 !/NCEP2 KPDS(2) = 1 !/NCEP2 KPDS(1) = 1 !/RTD ! Rotate x,y vector back to standard pole !/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, CX, CY, AnglD) 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. !/NCEP1 KPDS(5) = 032 !/NCEP2 KPDS(2) = 1 !/NCEP2 KPDS(1) = 2 !/NCEP2 LISTSEC0(1) = 0 !/RTD ! Rotate x,y vector back to standard pole !/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UA, UD, AnglD) 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. !/NCEP1 KPDS(5) = -1 !/NCEP2 KPDS(2) = 255 !/NCEP2 KPDS(1) = 3 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. !/NCEP1 KPDS(5) = -1 !/NCEP2 KPDS(2) = 1 !/NCEP2 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. !/NCEP1 KPDS(5) = 091 !/NCEP2 KPDS(2) = 0 !/NCEP2 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. !/NCEP1 KPDS(5) = 100 !/NCEP2 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. !/NCEP1 KPDS(5) = -1 !/NCEP2 KPDS(2) = 193 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. !/NCEP1 KPDS(5) = -1 !/NCEP2 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. !/NCEP1 KPDS(5) = 103 !/NCEP2 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. !/NCEP1 KPDS(5) = -1 !/NCEP2 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. !/NCEP1 KPDS(5) = 108 !/NCEP2 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. !/NCEP1 KPDS(5) = 101 !/NCEP2 KPDS(2) = 14 !/RTD ! Rotate direction back to standard pole !/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, THM, AnglD, .FALSE.) 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. !/NCEP1 KPDS(5) = -1 !/NCEP2 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. !/NCEP1 KPDS(5) = 107 !/NCEP2 KPDS(2) = 10 !/RTD ! Rotate direction back to standard pole !/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, THP0, AnglD, .FALSE.) 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. !/NCEP1 KPDS5A = 102 !/NCEP1 KPDS5B = 105 !/NCEP2 KPDS5A = 5 !/NCEP2 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. !/NCEP1 KPDS5A = 110 !/NCEP1 KPDS5B = 106 !/NCEP2 KPDS5A = 6 !/NCEP2 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. !/NCEP1 KPDS5A = -1 !/NCEP1 KPDS5B = -1 !/NCEP2 KPDS5A = 193 !/NCEP2 KPDS5B = 193 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. !/NCEP1 KPDS5A = 109 !/NCEP1 KPDS5B = 104 !/NCEP2 KPDS5A = 4 !/NCEP2 KPDS5B = 7 !/RTD DO I = 0,NOSWLL !/RTD ! Rotate direction back to standard pole !/RTD IF ( FLAGUNR ) CALL W3THRTN(NSEA, PDIR(:,I), AnglD, .FALSE.) !/RTD END DO 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. !/NCEP1 KPDS5A = -1 !/NCEP1 KPDS5B = -1 !/NCEP2 KPDS5A = 32 !/NCEP2 KPDS5B = 33 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. !/NCEP1 KPDS5A = -1 !/NCEP1 KPDS5B = -1 !/NCEP2 KPDS5A = 255 !/NCEP2 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. 16 ) THEN FLONE = .TRUE. !/NCEP1 KPDS(5) = -1 !/NCEP2 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. 17 ) THEN FLONE = .TRUE. !/NCEP1 KPDS(5) = -1 !/NCEP2 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. !/NCEP1 KPDS(5) = -1 !/NCEP2 KPDS(2) = 17 !/NCEP2 KPDS(1) = 1 !/RTD ! Rotate x,y vector back to standard pole !/RTD IF ( FLAGUNR ) CALL W3XYRTN(NSEA, UST, USTDIR, AnglD) 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. !/NCEP1 KPDS(5) = -1 !/NCEP2 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. !/NCEP1 KPDS(5) = -1 !/NCEP2 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. !/NCEP1 KPDS(5) = -1 !/NCEP2 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. !/NCEP1 KPDS(5) = -1 !/NCEP2 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 ! !/NCEP1 KPDS(5) = KPDS5A !/NCEP2 KPDS(2) = KPDS5A DO IXY=1, NX*NY BITMAP(IXY) = YY(IXY,0) .NE. UNDEF END DO !/NCEP1 CALL PUTGB (NDSDAT,NDATA,KPDS,KGDS,BITMAP,YY(:,0),IO) !/NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) !/NCEP2 IF (IO .NE. 0) GOTO 810 !/NCEP2 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & !/NCEP2 IDEFNUM, IO) !/NCEP2 IF (IO .NE. 0) GOTO 820 !/NCEP2 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & !/NCEP2 COORDLIST, NUMCOORD, IDRSNUM, IDRS, & !/NCEP2 200,YY(:,0), NDATA, IBMP, BITMAP, IO) !/NCEP2 IF (IO .NE. 0) GOTO 820 !/NCEP2 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) !/NCEP2 IF (IO .NE. 0) GOTO 830 !/NCEP2 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) ! !/NCEP1 KPDS(5) = KPDS5B !/NCEP1 KPDS(6) = 241 !/NCEP2 KPDS(2) = KPDS5B !/NCEP2 KPDS(10) = 241 DO I=1, NOSWLL !/NCEP1 KPDS(7) = I !/NCEP2 KPDS(12) = I DO IXY=1, NX*NY BITMAP(IXY) = YY(IXY,I) .NE. UNDEF END DO !/NCEP1 CALL PUTGB (NDSDAT,NDATA,KPDS,KGDS,BITMAP,YY(:,I),IO) !/NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) !/NCEP2 IF (IO .NE. 0) GOTO 810 !/NCEP2 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & !/NCEP2 IDEFNUM, IO) !/NCEP2 IF (IO .NE. 0) GOTO 820 !/NCEP2 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & !/NCEP2 COORDLIST, NUMCOORD, IDRSNUM, IDRS, & !/NCEP2 200,YY(:,I), NDATA, IBMP, BITMAP, IO) !/NCEP2 IF (IO .NE. 0) GOTO 820 !/NCEP2 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) !/NCEP2 IF (IO .NE. 0) GOTO 830 !/NCEP2 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) END DO !/NCEP1 KPDS(6) = 1 !/NCEP1 KPDS(7) = 1 !/NCEP2 KPDS(10) = 1 !/NCEP2 KPDS(12) = 1 ! ! 3.b Other data ! ELSE IF (FLONE) THEN ! DO IXY=1, NX*NY BITMAP(IXY) = X1(IXY) .NE. UNDEF END DO ! !/NCEP1 CALL PUTGB (NDSDAT,NDATA,KPDS,KGDS,BITMAP,X1,IO) !/NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) !/NCEP2 IF (IO .NE. 0) GOTO 810 !/NCEP2 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & !/NCEP2 IDEFNUM, IO) !/NCEP2 IF (IO .NE. 0) GOTO 820 !/NCEP2 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & !/NCEP2 COORDLIST, NUMCOORD, IDRSNUM, IDRS, & !/NCEP2 200,X1, NDATA, IBMP, BITMAP, IO) !/NCEP2 IF (IO .NE. 0) GOTO 820 !/NCEP2 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) !/NCEP2 IF (IO .NE. 0) GOTO 830 !/NCEP2 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) ! ELSE IF ( FLTWO ) THEN ! DO IXY=1, NX*NY BITMAP(IXY) = X1(IXY) .NE. UNDEF END DO !/NCEP1 CALL PUTGB (NDSDAT,NDATA,KPDS,KGDS,BITMAP,X1,IO) !/NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) !/NCEP2 IF (IO .NE. 0) GOTO 810 !/NCEP2 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & !/NCEP2 IDEFNUM, IO) !/NCEP2 IF (IO .NE. 0) GOTO 820 !/NCEP2 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & !/NCEP2 COORDLIST, NUMCOORD, IDRSNUM, IDRS, & !/NCEP2 200,X1, NDATA, IBMP, BITMAP, IO) !/NCEP2 IF (IO .NE. 0) GOTO 820 !/NCEP2 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) !/NCEP2 IF (IO .NE. 0) GOTO 830 !/NCEP2 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) !/NCEP1 KPDS(5) = 031 !/NCEP1 CALL PUTGB (NDSDAT,NDATA,KPDS,KGDS,BITMAP,X2,IO) !/NCEP2 KPDS(2) = 0 !/NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) !/NCEP2 IF (IO .NE. 0) GOTO 810 !/NCEP2 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & !/NCEP2 IDEFNUM, IO) !/NCEP2 IF (IO .NE. 0) GOTO 820 !/NCEP2 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & !/NCEP2 COORDLIST, NUMCOORD, IDRSNUM, IDRS, & !/NCEP2 200,X2, NDATA, IBMP, BITMAP, IO) !/NCEP2 IF (IO .NE. 0) GOTO 820 !/NCEP2 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) !/NCEP2 IF (IO .NE. 0) GOTO 830 !/NCEP2 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) !/NCEP1 KPDS(5) = 033 !/NCEP1 CALL PUTGB (NDSDAT,NDATA,KPDS,KGDS,BITMAP,XX,IO) !/NCEP2 KPDS(2) = 2 !/NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) !/NCEP2 IF (IO .NE. 0) GOTO 810 !/NCEP2 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & !/NCEP2 IDEFNUM, IO) !/NCEP2 IF (IO .NE. 0) GOTO 820 !/NCEP2 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & !/NCEP2 COORDLIST, NUMCOORD, IDRSNUM, IDRS, & !/NCEP2 200,XX, NDATA, IBMP, BITMAP, IO) !/NCEP2 IF (IO .NE. 0) GOTO 820 !/NCEP2 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) !/NCEP2 IF (IO .NE. 0) GOTO 830 !/NCEP2 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) !/NCEP1 KPDS(5) = 034 !/NCEP1 CALL PUTGB (NDSDAT,NDATA,KPDS,KGDS,BITMAP,XY,IO) !/NCEP2 KPDS(2) = 3 !/NCEP2 CALL GRIBCREATE (CGRIB,LCGRIB,LISTSEC0,LISTSEC1,IO) !/NCEP2 IF (IO .NE. 0) GOTO 810 !/NCEP2 CALL ADDGRID (CGRIB,LCGRIB,IGDS,KGDS,200,IDEFLIST, & !/NCEP2 IDEFNUM, IO) !/NCEP2 IF (IO .NE. 0) GOTO 820 !/NCEP2 CALL ADDFIELD (CGRIB,LCGRIB,KPDSNUM,KPDS,200, & !/NCEP2 COORDLIST, NUMCOORD, IDRSNUM, IDRS, & !/NCEP2 200,XY, NDATA, IBMP, BITMAP, IO) !/NCEP2 IF (IO .NE. 0) GOTO 820 !/NCEP2 CALL GRIBEND (CGRIB, LCGRIB, LENGRIB, IO) !/NCEP2 IF (IO .NE. 0) GOTO 830 !/NCEP2 CALL WRYTE (NDSDAT, LENGRIB, CGRIB) ! END IF !/NCEP2 LISTSEC0(1) = 10 !/NCEP2 KPDS(1) = 0 ! ! ... End of fields loop ! END IF END DO END DO ! RETURN ! ! Error escape locations ! !/NCEP2 810 CONTINUE !/NCEP2 WRITE (NDSE,1010) IO !/NCEP2 CALL EXTCDE ( 20 ) !/NCEP2 820 CONTINUE !/NCEP2 WRITE (NDSE,1020) IO !/NCEP2 CALL EXTCDE ( 30 ) !/NCEP2 830 CONTINUE !/NCEP2 WRITE (NDSE,1030) IO !/NCEP2 CALL EXTCDE ( 40 ) ! ! Formats ! 999 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB :'/ & ' PLEASE UPDATE FIELDS !!! '/) ! !/NCEP2 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & !/NCEP2 ' ERROR IN OPENING OUTPUT FILE'/ & !/NCEP2 ' IOSTAT =',I5/) ! !/NCEP2 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & !/NCEP2 ' ERROR CREATING NEW GRIB2 FIELD'/ & !/NCEP2 ' IOSTAT =',I5/) ! !/NCEP2 1020 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & !/NCEP2 ' ERROR ADDING GRIB2 FIELD'/ & !/NCEP2 ' IOSTAT =',I5/) ! !/NCEP2 1030 FORMAT (/' *** WAVEWATCH III ERROR IN W3EXGB : '/ & !/NCEP2 ' ERROR ENDING GRIB2 MESSAGE'/ & !/NCEP2 ' IOSTAT =',I5/) ! !/T 9000 FORMAT (' TEST W3EXGB : FLAGS :',40L2) !/T 9001 FORMAT (' TEST W3EXGB : NDSDAT :',I4/ & !/T ' KPDS :',13I4/ & !/T ' ',12I4/ & !/T ' KGDS :',8I6/ & !/T ' ',8I6/ & !/T ' ',6I6) ! !/T 9012 FORMAT (' TEST W3EXGB : BLOK PARS : ',3I4) !/T 9014 FORMAT (' BASE NAME : ',A) ! !/T 9020 FORMAT (' TEST W3EXGB : OUTPUT FIELD : ',A) !/ !/ End of W3EXGB ----------------------------------------------------- / !/ END SUBROUTINE W3EXGB !/ !/ End of W3GRIB ----------------------------------------------------- / !/ END PROGRAM W3GRIB