#include "w3macros.h" !/ ------------------------------------------------------------------- / PROGRAM W3TRCK !/ !/ +-----------------------------------+ !/ | WAVEWATCH III NOAA/NCEP | !/ | H. L. Tolman | !/ | FORTRAN 90 | !/ | Last update : 05-Mar-2014 | !/ +-----------------------------------+ !/ !/ 14-Jan-1999 : Final FORTRAN 77 ( version 1.18 ) !/ 21-Jan-2000 : Upgrade to FORTRAN 90 ( version 2.00 ) !/ 25-Jan-2001 : Flat grid version ( version 2.06 ) !/ 20-Aug-2003 : Sequential file version ( version 3.04 ) !/ 29-Jun-2006 : Adding file name preamble. ( version 3.09 ) !/ 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-Mar-2014 : Now calls W3SETG for pointer def. ( version 4.18 ) !/ !/ 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 : ! ! Convert direct access track output file to free-format ! readable sequential file. ! ! 2. Method : ! ! Info read from track_o.ww3, written to track.ww3. ! ! 3. Parameters : ! ! 4. Subroutines used : ! ! Name Type Module Description ! ---------------------------------------------------------------- ! W3NMOD Subr. W3GDATMD Set number of model. ! W3NOUT Subr. W3ODATMD Set number of model for output. ! ---------------------------------------------------------------- ! ! 5. Called by : ! ! None, stand-alone program. ! ! 6. Error messages : ! ! 7. Remarks : ! ! 8. Structure : ! ! See source code. ! ! 9. Switches : ! ! !/S Enable subroutine tracing. ! ! 10. Source code : ! !/ ------------------------------------------------------------------- / USE W3GDATMD, ONLY : W3NMOD, W3SETG, FLAGLL, XFR USE W3ODATMD, ONLY : W3NOUT, W3SETO, FNMPRE USE W3SERVMD, ONLY : ITRACE, NEXTLN, EXTCDE !/S USE W3SERVMD, ONLY : STRACE USE W3TIMEMD, ONLY : STME21 ! USE W3ODATMD, ONLY: NDSO, NDSE, NDST ! IMPLICIT NONE !/ !/ ------------------------------------------------------------------- / !/ Local parameters !/ CHARACTER*34, PARAMETER :: & IDTST = 'WAVEWATCH III TRACK OUTPUT SPECTRA' ! INTEGER :: NDSI, NDSINP, & NDSOUT, NDSTRC, NTRACE, NK, NTH, & NSPEC, IERR, MK, MTH, & NREC, ILOC, ISPEC, TIME(2), TTST(2), & ILAST, NZERO, IK, ITH, IWZERO, ICH, & IWDTH, J !/S INTEGER, SAVE :: IENT = 0 INTEGER :: LINELN = 81 REAL :: TH1, DTH, X, Y, DW, CX, CY, WX, WY, & UST, AS, VALUE REAL :: SCALE = 0.001 REAL :: FACTOR REAL, ALLOCATABLE :: SIG(:), DSIP(:), SPEC(:,:) CHARACTER :: COMSTR*1, IDSTR*34, TSTSTR*3, & STIME*23, STRING*81, EMPTY*81, & PART*9, ZEROS*9, TRCKID*32 ! DATA EMPTY(01:40) / ' ' / DATA EMPTY(41:81) / ' ' / !/ !/ ------------------------------------------------------------------- / !/ ! ! 1.a Initialize data structure ! CALL W3NMOD ( 1, 6, 6 ) CALL W3SETG ( 1, 6, 6 ) CALL W3NOUT ( 6, 6 ) CALL W3SETO ( 1, 6, 6 ) ! ! 1.b IO set-up. ! NDSI = 10 NDSINP = 11 NDSOUT = 51 ! NDSTRC = 6 NTRACE = 10 CALL ITRACE ( NDSTRC, NTRACE ) ! !/S CALL STRACE ( IENT, 'W3TRCK' ) ! WRITE (NDSO,900) ! J = LEN_TRIM(FNMPRE) OPEN (NDSI,FILE=FNMPRE(:J)//'ww3_trck.inp',STATUS='OLD', & ERR=805,IOSTAT=IERR) READ (NDSI,'(A)',END=806,ERR=807) COMSTR IF (COMSTR.EQ.' ') COMSTR = '$' WRITE (NDSO,901) COMSTR ! CALL NEXTLN ( COMSTR , NDSI , NDSE ) READ (NDSI,*,END=806,ERR=807) NK, NTH NSPEC = NK * NTH WRITE (NDSO,902) NK, NTH ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 2. Open and test input data file ! WRITE (NDSO,920) ! OPEN (NDSINP,FILE=FNMPRE(:J)//'track_o.ww3',FORM='UNFORMATTED', & STATUS='OLD',ERR=800,IOSTAT=IERR) READ (NDSINP,ERR=801,IOSTAT=IERR) IDSTR, FLAGLL, MK, MTH, XFR ! IF ( FLAGLL ) THEN FACTOR = 1. ELSE FACTOR = 1.E-3 END IF ! IF ( IDSTR .NE. IDTST ) GOTO 810 IF ( NK.NE.MK .OR. NTH.NE.MTH ) GOTO 811 ALLOCATE ( SIG(MK), DSIP(MK), SPEC(MK,MTH) ) ! READ (NDSINP,ERR=801,IOSTAT=IERR) TH1, DTH, SIG, DSIP ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 3. Open output file and prepare ! WRITE (NDSO,930) ! OPEN (NDSOUT,FILE=FNMPRE(:J)//'track.ww3', & FORM='FORMATTED',ERR=802,IOSTAT=IERR) ! WRITE (NDSOUT,980,ERR=803,IOSTAT=IERR) IDSTR WRITE (NDSOUT,981,ERR=803,IOSTAT=IERR) MK, MTH, TH1, DTH WRITE (NDSOUT,982,ERR=803,IOSTAT=IERR) SIG WRITE (NDSOUT,983,ERR=803,IOSTAT=IERR) DSIP ! !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! 4. Process data ! ILOC = 0 ISPEC = 0 READ (NDSINP,END=444, ERR=801,IOSTAT=IERR) TTST BACKSPACE (NDSINP) WRITE (NDSO,940) ! 400 CONTINUE ! ! 4.a Read/write basic data ! READ (NDSINP,END=444, ERR=801,IOSTAT=IERR) TIME, X, Y, TSTSTR, & TRCKID IF ( FLAGLL ) THEN WRITE (NDSOUT,984,ERR=803,IOSTAT=IERR) & TIME, FACTOR*X, FACTOR*Y, TSTSTR, TRCKID ELSE WRITE (NDSOUT,974,ERR=803,IOSTAT=IERR) & TIME, FACTOR*X, FACTOR*Y, TSTSTR, TRCKID END IF ! IF ( TIME(1).EQ.TTST(1) .AND. TIME(2).EQ.TTST(2) ) THEN ILOC = ILOC + 1 IF ( TSTSTR .EQ. 'SEA' ) ISPEC = ISPEC + 1 ENDIF IF ( TIME(1).NE.TTST(1) .OR. TIME(2).NE.TTST(2) ) THEN CALL STME21 ( TTST , STIME ) WRITE (NDSO,941) STIME, ILOC, ISPEC ILOC = 1 ISPEC = 0 IF ( TSTSTR .EQ. 'SEA' ) ISPEC = ISPEC + 1 TTST(1) = TIME(1) TTST(2) = TIME(2) ENDIF ! ! 4.b Check if sea point ! IF ( TSTSTR .NE. 'SEA' ) GOTO 400 ! ! 4.c Read all data ! READ (NDSINP,ERR=801,IOSTAT=IERR) DW, CX, CY, WX, WY, UST, AS, & SPEC IF ( UST .LT. 0. ) UST = -1.0 ! ! 4.d Write the basic stuff ! WRITE (NDSOUT,985,ERR=803,IOSTAT=IERR) & DW, CX, CY, WX, WY, UST, AS, SCALE ! ! 4.e Start of integer packing ! STRING = EMPTY ILAST = 0 NZERO = 0 ! ! 4.e.1 Loop over spectrum ! DO IK=1, NK DO ITH=1, NTH VALUE = MAX ( 0.1 , 1.1*SPEC(IK,ITH)/SCALE ) IWDTH = 2 + MAX( 0 , INT( ALOG10(VALUE) ) ) ! ! 4.e.2 Put value in string and test overflow ! IF ( IWDTH .GT. 9 ) THEN IWDTH = 9 PART = ' 99999999' ELSE WRITE (PART,987) NINT(SPEC(IK,ITH)/SCALE) IF ( PART(11-IWDTH:11-IWDTH) .EQ. ' ' ) & IWDTH = IWDTH - 1 ENDIF ! ! 4.e.3 It's a zero, wait with writing ! IF ( PART(8:9) .EQ. ' 0' ) THEN NZERO = NZERO + 1 ELSE ! ! 4.e.4 It's not a zero, write unwritten zeros ! IF ( NZERO .NE. 0 ) THEN IF ( NZERO .EQ. 1 ) THEN ZEROS = ' 0' IWZERO = 2 ELSE WRITE (ZEROS,'(I7,A2)') NZERO, '*0' IWZERO = 4 DO ICH = 10 - IWZERO IF ( ZEROS(ICH:ICH) .NE. ' ' ) THEN IWZERO = IWZERO + 1 ELSE EXIT ENDIF END DO ENDIF IF ( ILAST+IWZERO .GT. LINELN ) THEN WRITE (NDSOUT,986,ERR=803,IOSTAT=IERR) & STRING(2:ILAST) STRING = EMPTY ILAST = 0 ENDIF STRING(ILAST+1:ILAST+IWZERO) = & ZEROS(10-IWZERO:9) ILAST = ILAST + IWZERO NZERO = 0 ENDIF ! ! 4.e.5 It's not a zero, put in string ! IF ( ILAST+IWDTH .GT. LINELN ) THEN WRITE (NDSOUT,986,ERR=803,IOSTAT=IERR) & STRING(2:ILAST) STRING = EMPTY ILAST = 0 ENDIF ! STRING(ILAST+1:ILAST+IWDTH) = PART(10-IWDTH:9) ILAST = ILAST + IWDTH ! ENDIF ! END DO END DO ! ! ..... End of loop over spectrum (4.e.1) ! ! 4.e.6 Write trailing zeros ! IF ( NZERO .NE. 0 ) THEN IF ( NZERO .EQ. 1 ) THEN ZEROS = ' 0' IWZERO = 2 ELSE WRITE (ZEROS,'(I7,A2)') NZERO, '*0' IWZERO = 4 DO ICH = 10 - IWZERO IF ( ZEROS(ICH:ICH) .NE. ' ' ) THEN IWZERO = IWZERO + 1 ELSE EXIT ENDIF END DO ENDIF IF ( ILAST+IWZERO .GT. LINELN ) THEN WRITE (NDSOUT,986,ERR=803,IOSTAT=IERR) & STRING(2:ILAST) STRING = EMPTY ILAST = 0 ENDIF STRING(ILAST+1:ILAST+IWZERO) = ZEROS(10-IWZERO:9) ILAST = ILAST + IWZERO NZERO = 0 ENDIF ! ! 4.e.7 Write last line ! IF ( ILAST .NE. 0 ) THEN WRITE (NDSOUT,986,ERR=803,IOSTAT=IERR) STRING(2:ILAST) ENDIF ! ! ... Loop back to top ! GOTO 400 ! ! 4.f All data done, write last batch info ! 444 CONTINUE ! CALL STME21 ( TTST , STIME ) WRITE (NDSO,941) STIME, ILOC, ISPEC ! GOTO 888 ! ! Escape locations read errors : ! 800 CONTINUE WRITE (NDSE,1000) IERR CALL EXTCDE ( 1 ) ! 801 CONTINUE WRITE (NDSE,1001) IERR CALL EXTCDE ( 2 ) ! 802 CONTINUE WRITE (NDSE,1002) IERR CALL EXTCDE ( 3 ) ! 803 CONTINUE WRITE (NDSE,1003) IERR CALL EXTCDE ( 4 ) ! 805 CONTINUE WRITE (NDSE,1004) IERR CALL EXTCDE ( 5 ) ! 806 CONTINUE WRITE (NDSE,1005) IERR CALL EXTCDE ( 6 ) ! 807 CONTINUE WRITE (NDSE,1006) IERR CALL EXTCDE ( 7 ) ! 810 CONTINUE WRITE (NDSE,1010) IDSTR, IDTST CALL EXTCDE ( 5 ) ! 811 CONTINUE WRITE (NDSE,1011) MK, MTH, NK, NTH CALL EXTCDE ( 6 ) ! 888 CONTINUE ! WRITE (NDSO,999) ! ! Formats ! 900 FORMAT (/15X,' *** WAVEWATCH III Track output post.*** '/ & 15X,'==============================================='/) 901 FORMAT ( ' Comment character is ''',A,''''/) 902 FORMAT ( ' Spectral grid size is ',I3,' by ',I3// & ' Opening files : '/ & ' -----------------------------------------------') 920 FORMAT ( ' Input file ...') 930 FORMAT ( ' Output file ...') 940 FORMAT (/' Processing data : '/ & ' -----------------------------------------------') 941 FORMAT ( ' ',A,' :',I6,' points and',I6,' spectra.') ! 980 FORMAT (A) 981 FORMAT (2I6,2E13.5) 982 FORMAT (7E11.4) 983 FORMAT (7E11.4) 984 FORMAT (I8.8,I7.6,2F9.3,2X,A3,2X,A32) 974 FORMAT (I8.8,I7.6,2(F9.2,'E3'),2X,A3,2X,A32) 985 FORMAT (F8.1,2F6.2,2F8.2,f9.5,f7.2,E12.5) 986 FORMAT (A) 987 FORMAT (I9) ! 999 FORMAT (/' End of program '/ & ' ========================================='/ & ' WAVEWATCH III Track output '/) ! 1000 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & ' ERROR IN OPENING INPUT DATA FILE'/ & ' IOSTAT =',I5/) ! 1001 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & ' ERROR IN READING FROM INPUT DATA FILE'/ & ' IOSTAT =',I5/) ! 1002 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & ' ERROR IN OPENING OUTPUT DATA FILE'/ & ' IOSTAT =',I5/) ! 1003 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & ' ERROR IN WRITING TO OUTPUT FILE'/ & ' IOSTAT =',I5/) ! 1004 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & ' ERROR IN OPENING INPUT FILE'/ & ' IOSTAT =',I5/) ! 1005 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & ' ERROR IN READING FROM INPUT FILE'/ & ' IOSTAT =',I5/) ! 1006 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & ' ERROR IN OPENING OUTPUT FILE'/ & ' IOSTAT =',I5/) ! 1010 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & ' UNEXPECTED ID STRING IN INPUT : ',A/ & ' SHOULD BE : ',A/) ! 1011 FORMAT (/' *** WAVEWATCH III ERROR IN W3TRCK : '/ & ' UNEXPECTED SPECTRAL DIMENSIONS : ',2I4/ & ' SHOULD BE : ',2I4/) !/ !/ End of W3TRCK ----------------------------------------------------- / !/ END PROGRAM W3TRCK