w3bullmd.F90

Go to the documentation of this file.

 
 
#include "w3macros.h"
!/ ------------------------------------------------------------------- /
MODULE w3bullmd
  !/
  !/                  +-----------------------------------+
  !/                  | WAVEWATCH-III           NOAA/NCEP |
  !/                  |           J. H. Alves             |
  !/                  |           H. L. Tolman            |
  !/                  |                        FORTRAN 90 |
  !/                  | Last update :         26-Dec-2012 |
  !/                  +-----------------------------------+
  !/
  !/    01-APR-2010 : Origination.                        ( version 3.14 )
  !/    25-Jun-2011 : Temporary change of HSMIN           ( version 4.05 )
  !/    15-Aug-2011 : Changing HSMIN to BHSMIN bugfix     ( version 4.05 )
  !/    26-Dec-2012 : Modified obsolete declarations.     ( version 4.11 )
  !/
  !/ ------------------------------------------------------------------- /
  USE w3gdatmd, ONLY: gname, nk, nth, nspec, flagll
  USE w3odatmd, ONLY: nopts, ptloc, ptnme, dimp
  USE constants, ONLY: pi, tpi
  USE w3wdatmd, ONLY: time
  USE w3timemd, ONLY: dsec21
  PUBLIC
  INTEGER, PARAMETER   :: nptab = 6, nfld = 50, npmax = 80
  !
  REAL, PARAMETER      :: bhsmin = 0.15, bhsdrop = 0.05
  REAL                 :: hst(nptab,2), tpt(nptab,2),     &
       dmt(nptab,2)
  CHARACTER(LEN=129)   :: ascbline
  CHARACTER(LEN=664)   :: csvbline
#ifdef W3_NCO
  CHARACTER(LEN=67)    :: cascbline
#endif
  LOGICAL              :: iyy(npmax)
  !/
  !/ Conventional declarations
  !/
  !/
  !/ Private parameter statements (ID strings)
  !/
  !/
CONTAINS
  !/ ------------------------------------------------------------------- /
  SUBROUTINE w3bull                                                &
       ( npart, xpart, dimxp, uabs, ud, ipnt, iout, timev )
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH-III           NOAA/NCEP |
    !/                  |           J. H. Alves             |
    !/                  |           H. L. Tolman            |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :         11-Mar-2013 !
    !/                  +-----------------------------------+
    !/
    !/    01-Apr-2010 : Origination.                        ( version 3.14 )
    !/    26-Dec-2012 : Modified obsolete declarations.     ( version 4.11 )
    !/    15-Aug-2011 : Adjustments to version 4.05         ( version 4.05 )
    !/    11-Mar-2013 : Minor cleanup                       ( version 4.09 )
    !/
    !  1. Purpose :
    !
    !     Read a WAVEWATCH-III version 1.17 point output data file and
    !     produces a table of mean parameters for all individual wave
    !     systems.
    !
    !  2. Method :
    !
    !     Partitioning is made using the built-in module w3partmd. Partitions
    !     are ranked and organized into coherent sequences that are then
    !     written as tables to output files. Input options for generating
    !     tables are defined in ww3_outp.inp. This module sorts the table
    !     data, output to file is controlled by WW3_OUTP.
    !
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !       DHSMAX  Real   Max. change in Hs for system to be considered
    !                      related to previous time.
    !       DTPMAX  Real   Id. Tp.
    !       DDMMAX  Real   Id. Dm.
    !       DDWMAX  Real   Maximum differences in wind and wave direction
    !                      for marking of system as under the influence
    !                      of the local wind,
    !       AGEMIN  Real   Id. wave age.
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Sur.  W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !     WW3_OUTP
    !
    !  6. Error messages :
    !
    !     Error control made in WW3_OUTP.
    !
    !  7. Remarks :
    !
    !     Current version does not allow generating tables for multiple
    !     points.
    !
    !  8. Structure :
    !
    !  9. Switches :
    !
    !     !/S    Enable subroutine tracing.
    !     !/T    Enable test output
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
    !     USE CONSTANTS
#ifdef W3_S
    USE w3servmd, ONLY: strace
#endif
    !
    IMPLICIT NONE
    !
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    !/
    !
    ! -------------------------------------------------------------------- /
    ! 1.  Initializations
    !
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    REAL                    :: DHSMAX, DTPMAX,        &
         DDMMAX, DDWMAX, AGEMIN
    parameter( dhsmax =   1.50 )
    parameter( dtpmax =   1.50 )
    parameter( ddmmax =  15.   )
    parameter( ddwmax =  30.   )
    parameter( agemin =   0.8  )
    INTEGER, INTENT(IN)     :: NPART, DIMXP, IOUT
    INTEGER, INTENT(INOUT)  :: TIMEV(2)
    REAL, INTENT(IN)        :: UABS,    &
         UD, XPART(DIMP,0:DIMXP)
    INTEGER                 :: IPG1,IPI(NPMAX), ILEN(NPMAX), IP,     &
         IPNOW, IFLD, INOTAB, IPNT, ITAB,      &
         DOUTP, FCSTI, NZERO
    REAL                    :: AFR, AGE, DDMMAXR, DELDM, DELDMR,     &
         DELDW, DELHS, DELTP, DHSMAXR,  &
         DTPMAXR, HMAX, HSTOT, TP, UDIR, FACT
    REAL                    :: HSP(NPMAX), TPP(NPMAX), &
         DMP(NPMAX), WNP(NPMAX), HSD(NPMAX),   &
         TPD(NPMAX), WDD(NPMAX)
    LOGICAL                 :: FLAG(NPMAX)
    CHARACTER(LEN=129)      :: BLANK, TAIL !, ASCBLINE
#ifdef W3_NCO
    CHARACTER(LEN=67)       :: CBLANK, CTAIL !, CASCBLINE
#endif
    CHARACTER(LEN=15)       :: PART
#ifdef W3_NCO
    CHARACTER(LEN=9)        :: CPART
#endif
    CHARACTER(LEN=664)      :: BLANK2 !,CSVBLINE
    CHARACTER               :: STIME*8,FORM*20,FORM1*2
    CHARACTER(LEN=16)       :: PART2
    !/
    !/ ------------------------------------------------------------------- /
    !
#ifdef W3_S
    CALL strace (ient, 'XXXXXX')
#endif
    !
    ! 1.a Constants etc.
    !
    ! Set FACT to proper scaling according to spherical or cartesian
    IF ( flagll ) THEN
      fact = 1.
    ELSE
      fact = 1.e-3
    ENDIF
    !
    ! Convert wind direction to azimuthal reference
    udir   = mod( ud+180., 360. )
    !
    tail(  1: 40) = '+-------+-----------+-----------------+-'
    tail( 41: 80) = '----------------+-----------------+-----'
    tail( 81:120) = '------------+-----------------+---------'
    tail(120:129) = '---------+'
    blank(  1: 40) = '| nn nn |      nn   |                 | '
    blank( 41: 80) = '                |                 |     '
    blank( 81:120) = '            |                 |         '
    blank(120:129) = '         |'
    ascbline       = blank
#ifdef W3_NCO
    ctail( 1:40) = '----------------------------------------'
    ctail(41:67) = '---------------------------'
    cblank( 1:40) = '                                        '
    cblank(41:67) = '                           '
    cascbline       = cblank
#endif
    !
    blank2(  1: 40)='    ,    ,  ,  ,  ,     ,   ,     ,     '
    blank2( 41: 88)=',     ,     ,   ,     ,     ,   ,     ,     ,   '
    blank2( 89:136)=',     ,     ,   ,     ,     ,   ,     ,     ,   '
    blank2(137:184)=',     ,     ,   ,     ,     ,   ,     ,     ,   '
    blank2(185:232)=',     ,     ,   ,     ,     ,   ,     ,     ,   '
    blank2(233:280)=',     ,     ,   ,     ,     ,   ,     ,     ,   '
    blank2(281:328)=',     ,     ,   ,     ,     ,   ,     ,     ,   '
    blank2(329:376)=',     ,     ,   ,     ,     ,   ,     ,     ,   '
    blank2(377:424)=',     ,     ,   ,     ,     ,   ,     ,     ,   '
    blank2(425:472)=',     ,     ,   ,     ,     ,   ,     ,     ,   '
    blank2(473:520)=',     ,     ,   ,     ,     ,   ,     ,     ,   '
    blank2(521:568)=',     ,     ,   ,     ,     ,   ,     ,     ,   '
    blank2(569:616)=',     ,     ,   ,     ,     ,   ,     ,     ,   '
    blank2(617:664)=',     ,     ,   ,     ,     ,   ,     ,     ,   '
    !
    csvbline      = blank2
    !
    ipg1 = 0
    IF (iout .EQ. 1) THEN
      DO ip=1, nptab
        hst(ip,1) = -99.9
        tpt(ip,1) = -99.9
        dmt(ip,1) = -99.9
      ENDDO
      DO ip=1, npmax
        iyy(ip) = .false.
        ipi(ip)=1
        ilen(ip)=0
      ENDDO
    ENDIF
    !
    ! 3.  Get overall wave height ---------------------------------------- *
    !
    hstot  = xpart(1,0)
    tp     = xpart(2,0)
    DO ip=1, npart
      hsp(ip) = xpart(1,ip)
      tpp(ip) = xpart(2,ip)
      wnp(ip) = tpi / xpart(3,ip)
      dmp(ip) = mod( xpart(4,ip) + 180., 360.)
    ENDDO
 
    nzero = 0
    nzero = count( hsp <= bhsmin .AND. hsp /= 0.  )
    !
    ! 4.  Process all partial fields ------------------------------------- *
    !
    DO ip=npart+1, npmax
      hsp(ip) =    0.00
      tpp(ip) = -999.99
      dmp(ip) = -999.99
    ENDDO
 
    DO ip=1, nptab
      hst(ip,2) = hst(ip,1)
      tpt(ip,2) = tpt(ip,1)
      dmt(ip,2) = dmt(ip,1)
      hst(ip,1) = -1.
      tpt(ip,1) = -1.
      dmt(ip,1) = -1.
    ENDDO
    !
    ! 5.  Generate output table ------------------------------------------ *
    ! 5.a Time and overall wave height to string
    !
    ascbline = blank
    csvbline = blank2
#ifdef W3_NCO
    cascbline = cblank
#endif
    !
    ! Fill the variable forecast time with hrs relative to reference time
    IF ( timev(1) .LE. 0 ) timev = time
    fcsti = dsec21(timev, time) / 3600
    WRITE(csvbline(1:4),'(I4)')fcsti
    !
    DO ifld=1,nptab
      iyy(ifld)=.false.
    ENDDO
    !
    ! ... write the time labels for current table line
    WRITE (csvbline(6:9),'(I4)') int(time(1)/10000)
    WRITE (csvbline(11:12),'(I2)')                                  &
         int(time(1)/100)-100*int(time(1)/10000)
    WRITE (csvbline(14:15),'(I2)') mod(time(1),100)
    WRITE (csvbline(17:18),'(I2)') time(2)/10000
    WRITE (csvbline(20:24),'(F5.2)') uabs
    WRITE (csvbline(26:28),'(I3)') int(udir)
    IF ( hstot .GT. 0. ) WRITE (csvbline(30:34),'(F5.2)') hstot
    IF ( hstot .GT. 0. ) WRITE (csvbline(36:40),'(F5.2)') tp
    !
    WRITE (ascbline(3:4),'(I2)') mod(time(1),100)
    WRITE (ascbline(6:7),'(I2)') time(2)/10000
    !
    IF ( hstot .GT. 0. ) WRITE (ascbline(10:14),'(F5.2)') hstot
    WRITE (ascbline(16:17),'(I2)') npart - nzero
    !
#ifdef W3_NCO
    WRITE (cascbline(1:2),'(I2.2)') mod(time(1),100)
    WRITE (cascbline(3:4),'(I2.2)') time(2)/10000
    IF ( hstot .GT. 0. ) WRITE (cascbline(6:7),'(I2)') nint(hstot/0.3048)
#endif
    !
    IF ( npart.EQ.0 .OR. hstot.LT.0.1 ) GOTO 699
    !
    ! 5.b Switch off peak with too low wave height
    !
    DO ip=1, npart
      flag(ip) = hsp(ip) .GT. bhsmin
    ENDDO
    !
    ! 5.c Find next highest wave height
    !
    inotab   = 0
    !
601 CONTINUE
    !
    hmax   = 0.
    ipnow  = 0
    DO ip=1, npart
      IF ( hsp(ip).GT.hmax .AND. flag(ip) ) THEN
        ipnow  = ip
        hmax   = hsp(ip)
      ENDIF
    ENDDO
    !
    ! 5.d No more peaks, skip to output
    !
    IF ( ipnow .EQ. 0 ) GOTO 699
    !
    ! 5.e Find matching field
    !
    itab   = 0
    !
    DO ip=1, nptab
      IF ( tpt(ip,2) .GT. 0. ) THEN
        !
        delhs  = abs( hst(ip,2) - hsp(ipnow) )
        deltp  = abs( tpt(ip,2) - tpp(ipnow) )
        deldm  = abs( dmt(ip,2) - dmp(ipnow) )
        IF ( deldm .GT. 180. ) deldm = 360. - deldm
        IF ( delhs.LT.dhsmax .AND. &
             deltp.LT.dtpmax .AND. &
             deldm.LT.ddmmax ) itab = ip
        !
      ENDIF
    ENDDO
    !
    ! 5.f No matching field, find empty fields
    !
    IF ( itab .EQ. 0 ) THEN
      DO ip=nptab, 1, -1
        IF ( tpt(ip,1).LT.0. .AND. tpt(ip,2).LT.0. )    &
             itab = ip
      ENDDO
    ENDIF
    !
    ! 5.g Slot in table found, write
    !
    ! Remove clear windseas
    !
    IF ( itab .NE. 0 ) THEN
      !
      WRITE (part,'(1X,F5.2,F5.1,I4)')                             &
           hsp(ipnow), tpp(ipnow), nint(dmp(ipnow))
#ifdef W3_NCO
      WRITE (cpart,'(I2,1X,I2.2,1X,I3.3)')                         &
           nint(hsp(ipnow)/0.3048),                              &
           nint(tpp(ipnow)),                                     &
           nint(mod(dmp(ipnow)+180.,360.))
#endif
      deldw  = mod( abs( udir - dmp(ipnow) ) , 360. )
      IF ( deldw .GT. 180. ) deldw = 360. - deldw
      afr    = 2.*pi/tpp(ipnow)
      age    = uabs * wnp(ipnow) / afr
      IF ( deldw.LT.ddwmax .AND. age.GT.agemin ) part(1:1) = '*'
      !
      ascbline(5+itab*18:19+itab*18) = part
#ifdef W3_NCO
      cascbline(itab*10-1:itab*10+7) = cpart
#endif
      !
      DO ifld=1,nptab
        IF(itab.EQ.ifld)THEN
          iyy(ifld)=.true.
          hsd(ifld)=hsp(ipnow)
          tpd(ifld)=tpp(ipnow)
          wdd(ifld)=nint(dmp(ipnow))
        ENDIF
      ENDDO
      !
      hst(itab,1) = hsp(ipnow)
      tpt(itab,1) = tpp(ipnow)
      dmt(itab,1) = dmp(ipnow)
 
      !
      ! 5.h No slot in table found, write
      !
    ELSE
      !
      inotab   = inotab + 1
      WRITE (ascbline(19:19),'(I1)') inotab
      !
    ENDIF
    !
    flag(ipnow) = .false.
    GOTO 601
    !
    ! 5.i End of processing, write line in table
    !
699 CONTINUE
    !
    DO ifld=1,nptab
      IF(iyy(ifld))THEN
        ilen(ifld)=ilen(ifld)+1
        IF (ilen(ifld).EQ.1)THEN
          ipi(ifld)=ipg1+1
          ipg1=ipg1+1
        ENDIF
        WRITE (part2,'(",",F5.2,",",F5.2,",",I3)')                   &
             hsd(ifld), tpd(ifld), nint(wdd(ifld))
        csvbline(25+ipi(ifld)*16:40+ipi(ifld)*16) = part2
      ELSE
        ilen(ifld)=0
      ENDIF
    ENDDO
    !
    RETURN
    !/
    !/ End of W3BULL ----------------------------------------------------- /
    !/
  END SUBROUTINE w3bull
  !/
  !/ End of module W3BULLMD -------------------------------------------- /
  !/
END MODULE w3bullmd