ww3_trck.F90

Go to the documentation of this file.

 
!
#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
#ifdef W3_S
  USE w3servmd, ONLY : strace
#endif
  USE w3timemd, ONLY : stme21
  !
  USE w3odatmd, ONLY: ndso, ndse, ndst
  use constants, only: file_endian
  !
  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
#ifdef W3_S
  INTEGER, SAVE           :: ient   = 0
#endif
  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 )
  !
#ifdef W3_S
  CALL strace ( ient, 'W3TRCK' )
#endif
  !
  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', convert=file_endian, &
       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