w3profsmd_pdlib.F90

Go to the documentation of this file.

#include "w3macros.h"
!/
!/ ------------------------------------------------------------------- /
MODULE pdlib_w3profsmd
  !/                  +-----------------------------------+
  !/                  | WAVEWATCH III           NOAA/NCEP |
  !/                  |                                   |
  !/                  | Aron Roland (BGS IT&E GmbH)       |
  !/                  | Mathieu Dutour-Sikiric (IRB)      |
  !/                  |                                   |
  !/                  |                        FORTRAN 95 |
  !/                  | Last update :         1-June-2018 |
  !/                  +-----------------------------------+
  !/
  !/    01-June-2016 : Origination                        ( version 6.04 )
  !/
  !  1. Purpose : PDLIB version of UGTYPE including fully implicit
  !               discretization. This works is based on the thesis
  !               of Roland, 2008 and represents the continues
  !               development of the solution of the WAE on unstructured
  !               grids. Following the quest since one decade we
  !               continuesly improve the aplicability and robustness of
  !               the source code and the methods. The development and
  !               implementation of the involved schemes was funded over
  !               the past decade by IFREMER, SHOM, USACE, NCEP/NOAA,
  !               BGS IT&E GmbH, Zanke & Partner and Roland & Partner.
  !               The PDLIB (Parallel Decomposition Library) library,
  !               which is used here is courtesy to BGS IT&E GmbH and
  !               has it's own license, which is the same as WW3. As of
  !               the origin of the methods, ideas and source code. This
  !               code was 1st developed in the WWM-III (Roland, 2008) and
  !               the ported to WW3. This is true for all source code
  !               related to UGTYPE.
  !
  !
  !  2. Method :  We apply here the framework of Residual Distributions
  !               schemes for hyperbolic problems for nonlinear propagation
  !               laws based on the work of Richiuotto et al. 2005.
  !               We supply the N-scheme, PSI-scheme and Lax-FCT-scheme
  !               as explicit methods ranging from 1st order time space
  !               to most optimal PSI method up to 2nd order Lax-FCT-scheme.
  !               For the implicit implementation we used up to now only
  !               the N-Scheme. Higher order schemes are up to now rather
  !               a research feature than for practical application. The
  !               reason is given in Cavalleri et al. 2018, we do not
  !               resolve enough physics in order to be able to run
  !               2nd or even higher order schemes.
  !               Use the numerical schemes with the needed care and
  !               do proper convergence analysis on the time step and
  !               grid size as well as solver threshold depedency.
  !               Think about the time and spatial scales of your
  !               u r intending to resolve! Multiscale modelling needs
  !               much work on the side of the modeler and much more
  !               time for the grid generation and the validation of the
  !               final model
  !
  !  3. Parameters :
  !
  !     Parameter list
  !     ----------------------------------------------------------------
  !     ----------------------------------------------------------------
  !
  !  4. Subroutines used :
  !
  !      Name      Type  Module   Description
  !     ----------------------------------------------------------------
  !      STRACE    Subr. W3SERVMD Subroutine tracing.
  !     ----------------------------------------------------------------
  !
  !  5. Called by :
  !
  !      Name      Type  Module   Description
  !     ----------------------------------------------------------------
  !     ----------------------------------------------------------------
  !
  !  6. Error messages :
  !  7. Remarks
  !  8. Structure :
  !  9. Switches :
  !
  !     !/S  Enable subroutine tracing.
  !
  ! 10. Source code :
  !
  !/ ------------------------------------------------------------------- /
  !
  use w3servmd, only : print_memcheck
#ifdef W3_S
  USE w3servmd, only: strace
#endif
  !/
  !/ ------------------------------------------------------------------- /
  !/ Parameter list
  !/
  !/ ------------------------------------------------------------------- /
  !/ Local PARAMETERs
  !/
#ifdef W3_S
  INTEGER, SAVE           :: ient = 0
#endif
  !/
  !/ ------------------------------------------------------------------- /
  !/
  !/ ------------------------------------------------------------------- /
  !/
  ! module default
  implicit none
 
  PUBLIC
  !/
  !/ Public variables
  !/
  LOGICAL               :: mapsta_hack = .false.
  REAL, ALLOCATABLE     :: aspar_jac(:,:), aspar_diag_sources(:,:), aspar_diag_all(:,:), b_jac(:,:)
  REAL, ALLOCATABLE     :: cad_the(:,:), cas_sig(:,:)
  REAL, ALLOCATABLE     :: cwnb_sig_m2(:,:)
  REAL, ALLOCATABLE     :: u_jac(:,:)
  REAL, ALLOCATABLE     :: cofrm4(:)
  real*8, ALLOCATABLE   :: flall1(:,:,:), kelem1(:,:,:)
  real*8, ALLOCATABLE   :: flall2(:,:,:), kelem2(:,:,:)
  real*8, ALLOCATABLE   :: flall3(:,:,:), kelem3(:,:,:)
  real*8, ALLOCATABLE   :: nm(:,:,:), dtsi(:)
  INTEGER, ALLOCATABLE  :: iter(:)
  INTEGER, ALLOCATABLE  :: is0_pdlib(:)
  INTEGER               :: freqshiftmethod = 2
  LOGICAL               :: fsgeoadvect
  LOGICAL, SAVE         :: linit_output = .true.
  REAL, SAVE            :: rtime = 0.d0
  INTEGER               :: pos_trick(3,2)
 
#ifdef W3_DEBUGSRC
  INTEGER  :: testnode = 1
#endif
  integer  :: memunit
  !
  !/ ------------------------------------------------------------------- /
  !
CONTAINS
  !
  !/ ------------------------------------------------------------------- /
  !
  !/ ------------------------------------------------------------------- /
  SUBROUTINE pdlib_init(IMOD)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Init pdlib part
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE w3gdatmd, only: flcx, flcy
    USE constants, only : grav, tpi
    USE w3gdatmd, only: xgrd, ygrd, nx, nsea, ntri, trigp, nspec, nseal
    USE w3gdatmd, only: mapsta, mapfs, grids, nth, sig, nk
    USE w3gdatmd, only: iobp_loc, iobpd_loc, iobpa_loc, iobdp_loc
    USE w3gdatmd, only: ccon, countcon, index_cell, ie_cell
    USE w3gdatmd, only: iobp, iobpa, iobpd, iobdp, si
 
    USE w3adatmd, only: mpi_comm_wcmp, mpi_comm_wave
    USE w3odatmd, only: iaproc, naproc, ntproc
    USE yowdatapool, only: istatus
    USE yowpdlibmain, only: initfromgriddim
    USE yownodepool, only: npa, np, iplg
    USE w3parall, only : pdlib_nseal, pdlib_nsealm
    USE w3parall, only : jx_to_jsea, isea_to_jsea
    USE yowfunction, only : computelistnp_listnpa_listiplg, pdlib_abort
    USE w3gdatmd, only: fstotalimp, fstotalexp, fsnimp, fsn, fspsi, fsfct
    USE w3gdatmd, only: fsrefraction, fsfreqshift, fssource
 
    !/
    include "mpif.h"
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local PARAMETERs
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
    !!      INCLUDE "mpif.h"
    INTEGER :: istat
    INTEGER :: I, J, IBND_MAP, ISEA, IP, IX, JSEA, nb
    INTEGER :: IP_glob
    INTEGER :: myrank, ierr, iproc
    INTEGER, ALLOCATABLE :: NSEAL_arr(:)
    INTEGER :: IERR_MPI
    INTEGER :: IScal(1)
    INTEGER, INTENT(in) :: IMOD
    INTEGER :: IK, ISP
    INTEGER IK0, ISP0, ITH
    REAL :: eSIG, eFR
    REAL, PARAMETER :: COEF4 = 5.0e-7
#ifdef W3_S
    CALL strace (ient, 'PDLIB_INIT')
#endif
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'PDLIB_INIT, IMOD (no print)'
    WRITE(740+iaproc,*) 'NAPROC=', naproc
    WRITE(740+iaproc,*) 'NTPROC=', ntproc
    FLUSH(740+iaproc)
#endif
 
    pdlib_nseal = 0
 
    IF (iaproc .le. naproc) THEN
 
      CALL mpi_comm_rank(mpi_comm_wcmp, myrank, ierr)
      !
#ifdef W3_DEBUGSOLVER
      WRITE(740+iaproc,*) 'PDLIB_INIT, IAPROC=', iaproc
      WRITE(740+iaproc,*) 'PDLIB_INIT, NAPROC=', naproc
      WRITE(740+iaproc,*) 'PDLIB_INIT, myrank=', myrank
      FLUSH(740+iaproc)
#endif
      !
      IF (fstotalexp) THEN
        CALL initfromgriddim(nx,ntri,trigp,nth,mpi_comm_wcmp)
      ELSE
        CALL initfromgriddim(nx,ntri,trigp,nspec,mpi_comm_wcmp)
      ENDIF
      !
#ifdef W3_DEBUGSOLVER
      WRITE(740+iaproc,*) 'After initFromGridDim'
      FLUSH(740+iaproc)
#endif
      !
      !
      ! Now the computation of NSEAL
      !
      !
      DO ip = 1, npa
        ix = iplg(ip)
        isea = mapfs(1,ix)
        IF (isea .gt. 0) pdlib_nseal = pdlib_nseal + 1
      END DO
#ifdef W3_DEBUGSOLVER
      WRITE(740+iaproc,*) 'npa is augmented domain over NX'
      WRITE(740+iaproc,*) 'PDLIB_NSEAL is basicall npa but only over the wet points'
      WRITE(740+iaproc,*) 'NSEAL is set to PDLIB_NSEAL'
      WRITE(740+iaproc,*) 'PDLIB_NSEAL=', pdlib_nseal
      WRITE(740+iaproc,*) 'NSEAL =', nseal, 'NP    =', np, 'NPA   =', npa
      FLUSH(740+iaproc)
#endif
      ALLOCATE(jx_to_jsea(npa), isea_to_jsea(nsea), stat=istat)
#ifdef W3_DEBUGSOLVER
      WRITE(740+iaproc,*) 'ISEA_TO_JSEA ALLOCATEd'
      FLUSH(740+iaproc)
#endif
      if(istat /= 0) CALL pdlib_abort(3)
      jsea         = 0
      jx_to_jsea   = 0
      isea_to_jsea = 0
      DO ip = 1, npa
        ix = iplg(ip)
        isea = mapfs(1,ix)
        IF (isea .gt. 0) THEN
          jsea=jsea+1
          jx_to_jsea(ip)=jsea
          isea_to_jsea(isea)=jsea
        END IF
      END DO
      !
#ifdef W3_DEBUGSOLVER
      WRITE(740+iaproc,*) 'After JX_TO_JSEA, ISEA_TO_JSEA and friend computation'
      FLUSH(740+iaproc)
#endif
      !
      ! Map a point in (1:PDLIB_NSEAL) to a point in (1:NSEA)
      !
      nb=0
      DO ix=1,nx
        IF (mapfs(1,ix) .gt. 0) nb = nb + 1
      END DO
 
      IF (nb .ne. nsea) THEN
        WRITE(*,*) 'Logical error in computation of NSEA / nb'
        WRITE(*,*) 'nb=', nb, ' NSEA=', nsea
        stop
      END IF
#ifdef W3_DEBUGSOLVER
      WRITE(740+iaproc,*) 'nb / NSEA consistency check'
      FLUSH(740+iaproc)
#endif
    END IF
    fsgeoadvect = .false.
    IF ((flcx .eqv. .true.).and.(flcy .eqv. .true.)) THEN
      fsgeoadvect =.true.
    END IF
    !
    ! Compute NSEALM
    !
    IF (iaproc .le. naproc) THEN
      IF (iaproc .eq. 1) THEN
        ALLOCATE(nseal_arr(naproc))
        nseal_arr(1)=pdlib_nseal
        DO iproc=2,naproc
          CALL mpi_recv(iscal,1,mpi_int, iproc-1, 23, mpi_comm_wave, istatus, ierr_mpi)
          nseal_arr(iproc)=iscal(1)
        END DO
        pdlib_nsealm=maxval(nseal_arr)
        DEALLOCATE(nseal_arr)
      ELSE
        iscal(1)=pdlib_nseal
        CALL mpi_send(iscal,1,mpi_int, 0, 23, mpi_comm_wave, ierr_mpi)
      END IF
    END IF
    !
    IF (iaproc .eq. 1) THEN
      iscal(1)=pdlib_nsealm
      DO iproc = 2 , ntproc
        CALL mpi_send(iscal,1,mpi_int, iproc-1, 24, mpi_comm_wave, ierr_mpi)
      END DO
    ELSE
      CALL mpi_recv(iscal,1,mpi_int, 0, 24, mpi_comm_wave, istatus, ierr_mpi)
      pdlib_nsealm=iscal(1)
    END IF
 
#ifdef W3_DEBUGINIT
    WRITE(740+iaproc,*) 'ALLOCATEd(ISEA_TO_JSEA)=', allocated(isea_to_jsea)
    WRITE(740+iaproc,*) 'PDLIB_NSEALM=', pdlib_nsealm
    FLUSH(740+iaproc)
#endif
    !
    CALL computelistnp_listnpa_listiplg
    ALLOCATE(cofrm4(nk))
    DO ik=1,nk
      esig=sig(ik)
      efr=esig/tpi
      cofrm4(ik)=coef4*grav/(efr**4)
    END DO
    ALLOCATE(is0_pdlib(nspec))
    DO isp=1, nspec
      is0_pdlib(isp) = isp - 1
    END DO
    DO isp=1, nspec, nth
      is0_pdlib(isp) = is0_pdlib(isp) + nth
    END DO
 
    DO jsea=1, pdlib_nseal
      ip      = jsea
      ip_glob = iplg(ip)
      isea    = mapfs(1,ip_glob)
      IF (isea .ne. ip_glob) THEN
        WRITE(*,*) jsea, pdlib_nseal, ip, ip_glob, isea
        WRITE(*,*) .ne.'ISEA  IP_glob'
        CALL pdlib_abort(20)
      ENDIF
    ENDDO
    !
    !
    !/
    !/ End of PDLIB_INIT ------------------------------------------- /
    !/
  END SUBROUTINE pdlib_init
  !/ ------------------------------------------------------------------- /
  SUBROUTINE pdlib_mapsta_init(IMOD)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Init mapsta part for pdlib
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE w3gdatmd, only : index_map, nbnd_map, nsea, nseal, mapsta, grids, nx, nth
    USE w3gdatmd, only : mapsta_loc, nbnd_map, index_map
    USE w3odatmd, only : iaproc, naproc
    USE yownodepool, only: iplg, npa
    USE yowfunction, only: pdlib_abort
    USE w3odatmd, only: iaproc
    !/
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local PARAMETERs
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
    INTEGER :: IBND_MAP, ISEA, JSEA, IX, IP, IP_glob
    INTEGER, INTENT(in) :: IMOD
    INTEGER :: Status(NX), istat
    REAL :: rtmp(nseal)
#ifdef W3_S
    CALL strace (ient, 'PDLIB_MAPSTA_INIT')
#endif
#ifdef W3_DEBUGINIT
    WRITE(*,*) 'Passing by PDLIB_MAPSTA_INIT IAPROC=', iaproc
#endif
    IF (iaproc .gt. naproc) THEN
      RETURN
    END IF
 
    ALLOCATE(grids(imod)%MAPSTA_LOC(npa), stat=istat)
    if(istat /= 0) CALL pdlib_abort(5)
    mapsta_loc => grids(imod)%MAPSTA_LOC
    nbnd_map => grids(imod)%NBND_MAP
    status = 0
    DO ip=1,npa
      ip_glob=iplg(ip)
      status(ip_glob)=ip
      mapsta_loc(ip)=mapsta(1,ip_glob)
    END DO
    nbnd_map = 0
    DO ix=1,nx
      IF ((mapsta(1,ix) .lt. 1).and.(status(ix).gt.0)) THEN
        nbnd_map = nbnd_map + 1
      END IF
    END DO
 
    ALLOCATE(grids(imod)%INDEX_MAP(nbnd_map), stat=istat)
    if(istat /= 0) CALL pdlib_abort(6)
    index_map => grids(imod)%INDEX_MAP
    ibnd_map = 0
    DO ix = 1, nx
      IF ((mapsta(1,ix) .lt. 1).and.(status(ix).gt.0)) THEN
        ibnd_map = ibnd_map + 1
        index_map(ibnd_map) = status(ix)
      END IF
    END DO
    !/
    !/ End of W3SPR4 ----------------------------------------------------- /
    !/
  END SUBROUTINE pdlib_mapsta_init
  !/ ------------------------------------------------------------------- /
  SUBROUTINE pdlib_iobp_init(IMOD)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Init mapsta part for pdlib
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE w3gdatmd, only : index_map, nbnd_map, nsea, nseal, grids, nx, nth
    USE w3gdatmd, only : iobp, iobdp, iobpa, iobpd, nbnd_map, index_map
    USE w3gdatmd, only : iobp_loc, iobpd_loc, iobdp_loc, iobpa_loc
    USE w3odatmd, only : iaproc, naproc
    USE yownodepool, only: iplg, npa
    USE yowfunction, only: pdlib_abort
    USE w3odatmd, only: iaproc
    !/
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local PARAMETERs
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
    INTEGER             :: IBND_MAP, ISEA, JSEA, IX, IP, IP_glob
    INTEGER, INTENT(in) :: IMOD
    INTEGER             :: Status(NX), istat
    REAL                :: rtmp(nseal)
#ifdef W3_S
    CALL strace (ient, 'PDLIB_MAPSTA_INIT')
#endif
#ifdef W3_DEBUGINIT
    WRITE(*,*) 'Passing by PDLIB_MAPSTA_INIT IAPROC=', iaproc
#endif
    IF (iaproc .gt. naproc) THEN
      RETURN
    END IF
 
    ALLOCATE(grids(imod)%IOBP_LOC(npa), stat=istat)
    if(istat /= 0) CALL pdlib_abort(7)
    ALLOCATE(grids(imod)%IOBPD_LOC(nth,npa), stat=istat)
    if(istat /= 0) CALL pdlib_abort(8)
    ALLOCATE(grids(imod)%IOBDP_LOC(npa), stat=istat)
    if(istat /= 0) CALL pdlib_abort(9)
    ALLOCATE(grids(imod)%IOBPA_LOC(npa), stat=istat)
    if(istat /= 0) CALL pdlib_abort(9)
 
    iobp_loc  => grids(imod)%IOBP_LOC
    iobpa_loc => grids(imod)%IOBPA_LOC
    iobpd_loc => grids(imod)%IOBPD_LOC
    iobdp_loc => grids(imod)%IOBDP_LOC
 
    DO ip = 1, npa
      ip_glob         = iplg(ip)
      iobp_loc(ip)    = iobp(ip_glob)
      iobpd_loc(:,ip) = iobpd(:,ip_glob)
    END DO
 
    iobdp_loc = 0
    iobp => null()
    iobpd => null()
    DEALLOCATE(grids(imod)%IOBP,grids(imod)%IOBPD)
    CALL set_iobpa_pdlib
    !/
    !/ End of W3SPR4 ----------------------------------------------------- /
    !/
  END SUBROUTINE pdlib_iobp_init
  !/ ------------------------------------------------------------------- /
  SUBROUTINE pdlib_w3xypug ( ISP, FACX, FACY, DTG, VGX, VGY, LCALC )
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :         10-Jan-2011 |
    !/                  +-----------------------------------+
    !/
    !/    10-Jan-2008 : Origination.                        ( version 3.13 )
    !/    10-Jan-2011 : Addition of implicit scheme         ( version 3.14.4 )
    !/    06-Feb-2014 : PDLIB parallelization
    !/
    !  1. Purpose : Explicit advection schemes driver
    !
    !     Propagation in physical space for a given spectral component.
    !     Gives the choice of scheme on unstructured grid
    !     Use the geographical parall algorithms for further speed.
    !
    !  2. Method :
    !
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !     Local variables.
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !  5. Called by :
    !
    !       W3WAVE   Wave model routine.
    !
    !  6. Error messages :
    !
    !       None.
    !
    !  7. Remarks :
    !              make the interface between the WAVEWATCH and the WWM code.
    !
    !  8. Structure :
    !
    !
    !  9. Switches :
    !
    !       !/S     Enable subroutine tracing.
    !
    !
    ! 10. Source code :
    !/ ------------------------------------------------------------------- /
    !/
    !
    USE constants
    !
    USE w3timemd, only: dsec21
    !
    USE w3gdatmd, only: nx, ny, mapfs, clats,        &
         flcx, flcy, nk, nth, dth, xfr,              &
         ecos, esin, sig,  pfmove,                   &
         iobp, iobpd,                                &
         fsn, fspsi, fsfct, fsnimp,                  &
         gtype, ungtype, nbnd_map, index_map
    USE yownodepool, only: pdlib_ien, pdlib_tria
    USE w3gdatmd, only: iobp_loc, iobpd_loc, iobpa_loc, iobdp_loc
    USE yownodepool, only: iplg, npa
    USE w3wdatmd, only: time, va
    USE w3odatmd, only: tbpi0, tbpin, flbpi
    USE w3adatmd, only: cg, cx, cy, itime, dw
    USE w3idatmd, only: flcur, fllev
    USE w3gdatmd, only: nseal
    USE w3odatmd, only: iaproc
    USE w3dispmd, only : wavnu_local
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    INTEGER, INTENT(IN)     :: ISP
    REAL, INTENT(IN)        :: FACX, FACY, DTG, VGX, VGY
    LOGICAL, INTENT(IN)     :: LCALC
    LOGICAL                 :: SCHEME
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local PARAMETERs
    !/
    INTEGER                 :: ITH, IK, ISEA
    INTEGER                 :: I, J, IE, IBND_MAP
    INTEGER                 :: IP_glob
    REAL                    :: CCOS, CSIN, CCURX, CCURY, WN1, CG1
    REAL                    :: C(npa,2)
    REAL                    :: RD1, RD2
    !/
    !/ Automatic work arrays
    !/
    REAL                    :: VLCFLX(npa), VLCFLY(npa)
    REAL                    :: AC(npa)
    REAL                    :: AC_MAP(NBND_MAP)
    INTEGER                 :: JSEA, IP
    !/ ------------------------------------------------------------------- /
    !
    ! 1.  Preparations --------------------------------------------------- *
    ! 1.a Set constants
    !
#ifdef W3_S
    CALL strace (ient, 'W3XYPUG')
#endif
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'Begin of PDLIB_W3XYPUG'
    FLUSH(740+iaproc)
#endif
    ith    = 1 + mod(isp-1,nth)
    ik     = 1 + (isp-1)/nth
    ccos   = facx * ecos(ith)
    csin   = facy * esin(ith)
    ccurx  = facx
    ccury  = facy
    !
    ! 1.b Initialize arrays
    !
    vlcflx = 0.
    vlcfly = 0.
    ac     = 0.
    !
    ! 2.  Calculate velocities ---------------- *
    !
    DO jsea = 1, nseal
      ip      = jsea
      ip_glob = iplg(ip)
      isea    = mapfs(1,ip_glob)
#ifdef NOCGTABLE
      CALL wavnu_local(sig(ik),dw(isea),wn1,cg1)
      ac(ip)  = va(isp,jsea) / cg1 * clats(isea)
      vlcflx(ip) = ccos * cg1 / clats(isea)
      vlcfly(ip) = csin * cg1
#else
      ac(ip)  = va(isp,jsea) / cg(ik,isea) * clats(isea)
      vlcflx(ip) = ccos * cg(ik,isea) / clats(isea)
      vlcfly(ip) = csin * cg(ik,isea)
#endif
#ifdef W3_MGP
      vlcflx(ip) = vlcflx(ip) - ccurx*vgx/clats(isea)
      vlcfly(ip) = vlcfly(ip) - ccury*vgy
#endif
    END DO
 
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'ISP=', isp, ' ITH=', ith, ' IK=', ik
    WRITE(740+iaproc,*) '1: maxval(VLCFLX)=', maxval(vlcflx)
    WRITE(740+iaproc,*) '1: maxval(VLCFLY)=', maxval(vlcfly)
    WRITE(740+iaproc,*) 'FLCUR=', flcur
    FLUSH(740+iaproc)
#endif
    IF ( flcur ) THEN
      DO jsea=1, nseal
        ip      = jsea
        ip_glob = iplg(ip)
        isea    = mapfs(1,ip_glob)
        !
        ! Currents are not included on coastal boundaries (COUNTSEACON(IXY) .NE. PDLIB_CCON(IXY))
        !
        IF (iobp_loc(ip) .GT. 0) THEN
          vlcflx(ip) = vlcflx(ip) + ccurx*cx(isea)/clats(isea)
          vlcfly(ip) = vlcfly(ip) + ccury*cy(isea)
        END IF
      END DO
    END IF
 
    c(:,1) = vlcflx(:) * iobdp_loc
    c(:,2) = vlcfly(:) * iobdp_loc
    !
    ! 4. Prepares boundary update
    !
    IF ( flbpi ) THEN
      rd1    = dsec21( tbpi0, time )
      rd2    = dsec21( tbpi0, tbpin )
    ELSE
      rd1=1.
      rd2=0.
    END IF
    !
    ! Saving data for MAPSTA business
    !
    IF (mapsta_hack) THEN
      DO ibnd_map=1,nbnd_map
        ip=index_map(ibnd_map)
        ac_map(ibnd_map) = ac(ip)
      END DO
    END IF
    !
    ! 4. propagate using the selected scheme
    !
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'maxval(C)=', maxval(c)
    FLUSH(740+iaproc)
#endif
    IF (fsn) THEN
      CALL pdlib_w3xypfsn2(isp, c, lcalc, rd1, rd2, dtg, ac)
    ELSE IF (fspsi) THEN
      CALL pdlib_w3xypfspsi2(isp, c, lcalc, rd1, rd2, dtg, ac)
    ELSE IF (fsfct) THEN
      CALL pdlib_w3xypfsfct2(isp, c, lcalc, rd1, rd2, dtg, ac)
    ELSE IF (fsnimp) THEN
      stop 'For PDLIB and FSNIMP, no function has been programmed yet'
    ENDIF
    !
    IF (mapsta_hack) THEN
      DO ibnd_map=1,nbnd_map
        ip=index_map(ibnd_map)
        ac(ip) = ac_map(ibnd_map)
      END DO
    END IF
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'After solutioning'
    FLUSH(740+iaproc)
#endif
 
    ! 6.  Store results in VQ in proper format --------------------------- *
    !
    DO jsea=1, nseal
      ip      = jsea
      ip_glob = iplg(ip)
      isea=mapfs(1,ip_glob)
      va(isp,jsea) = max( 0. , cg(ik,isea)/clats(isea)*ac(ip) )
    END DO
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'Leaving PDLIB_W3XYPUG'
    FLUSH(740+iaproc)
#endif
    !/
    !/ End of W3SPR4 ----------------------------------------------------- /
    !/
  END SUBROUTINE pdlib_w3xypug
  !/ ------------------------------------------------------------------- /
  SUBROUTINE pdlib_w3xypfsn2(ISP, C, LCALC, RD10, RD20, DT, AC)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Explicit N-Scheme
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE w3gdatmd, only: nk, nth, nx,  ien, clats, mapsf
    USE w3gdatmd, only: iobpd_loc, iobp_loc, iobdp_loc, iobpa_loc, fsbccfl
    USE w3wdatmd, only: time
    USE w3adatmd, only: cg, iter, dw , cflxymax, nsealm
    USE w3odatmd, only: ndse, ndst, flbpi, nbi, tbpin, isbpi, bbpi0, bbpin
    USE w3timemd, only: dsec21
    USE w3adatmd, only: mpi_comm_wcmp
    USE w3gdatmd, only: nseal, dmin, nsea
#ifdef W3_REF1
    USE w3gdatmd, only: refpars
#endif
    USE yownodepool,    only: pdlib_si, pdlib_ien, pdlib_tria, ipgl, iplg, npa, np
    use yowelementpool, only: ne, ine
    use yowdatapool, only: rtype
    use yowexchangemodule, only : pdlib_exchange1dreal
    USE w3odatmd, only : iaproc
    USE mpi, only : mpi_min
    USE w3parall, only : init_get_jsea_isproc
    USE w3parall, only : onesixth, zero, thr
    USE yowrankmodule, only : ipgl_npa
 
    INTEGER, INTENT(IN)    :: ISP        ! Actual Frequency/Wavenumber,
                                         ! actual Wave Direction
    REAL,    INTENT(IN)    :: DT         ! Time intervall for which the
                                         ! advection should be computed
                                         ! for the given velocity field
    REAL,    INTENT(IN)    :: C(npa,2)   ! Velocity field in it's
                                         ! X- and Y- Components,
    REAL,    INTENT(INOUT) :: AC(npa)    ! Wave Action before and
                                         ! after advection
    REAL,    INTENT(IN)    :: RD10, RD20 ! Time interpolation
                                         ! coefficients for boundary
                                         ! conditions
    LOGICAL, INTENT(IN)    :: LCALC      ! Switch for the calculation of
                                         ! the max. Global Time step
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
#ifdef W3_REF1
    INTEGER(KIND=1)    :: IOBPDR(NX)
#endif
    INTEGER :: IP, IE, POS, IT, I1, I2, I3, I, J, ITH, IK
    INTEGER :: IBI, NI(3)
    INTEGER :: JX
    !
    ! local REAL
    !
    REAL    :: RD1, RD2
    !:
    ! local double
    !
    REAL  :: UTILDE
    REAL  :: SUMTHETA
    REAL  :: FT, CFLXY
    REAL  :: FL11, FL12, FL21, FL22, FL31, FL32
    REAL  :: FL111, FL112, FL211, FL212, FL311, FL312
    REAL  :: DTSI(npa), U(npa)
    REAL  :: DTMAX_GL, DTMAX, DTMAXEXP, REST
    REAL  :: LAMBDA(2), KTMP(3)
    REAL  :: KELEM(3,NE), FLALL(3,NE)
    REAL  :: KKSUM(npa), ST(npa)
    REAL  :: NM(NE)
    INTEGER :: ISPROC, JSEA, IP_glob, ierr, IX
    REAL  :: eSumAC, sumAC, sumBPI0, sumBPIN, sumCG, sumCLATS
    LOGICAL :: testWrite
    REAL  :: FIN(1), FOUT(1)
#ifdef W3_S
    CALL strace (ient, 'W3XYPFSN')
#endif
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'PDLIB_W3XYPFSN2, step 1'
    FLUSH(740+iaproc)
    CALL scal_integral_print_r4(ac, "AC in input")
#endif
 
    ith    = 1 + mod(isp-1,nth)
    ik     = 1 + (isp-1)/nth
    dtmax  = dble(10.e10)
 
    !
#ifdef W3_REF1
    iobpdr(:)=(1-iobp_loc(:))*(1-iobpd_loc(ith,:))
#endif
 
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'NX=', nx
    WRITE(740+iaproc,*) 'PDLIB_W3XYPFSN2, step 2'
    FLUSH(740+iaproc)
#endif
    !
    !2       Propagation
    !2.a     Calculate K-Values and contour based quantities ...
    !
    DO ie = 1, ne
      i1 = ine(1,ie)
      i2 = ine(2,ie)
      i3 = ine(3,ie)
      lambda(1) = onesixth *(c(i1,1)+c(i2,1)+c(i3,1)) ! Linearized advection speed in X and Y direction
      lambda(2) = onesixth *(c(i1,2)+c(i2,2)+c(i3,2))
      kelem(1,ie) = lambda(1) * pdlib_ien(1,ie) + lambda(2) * pdlib_ien(2,ie) ! K-Values - so called Flux Jacobians
      kelem(2,ie) = lambda(1) * pdlib_ien(3,ie) + lambda(2) * pdlib_ien(4,ie)
      kelem(3,ie) = lambda(1) * pdlib_ien(5,ie) + lambda(2) * pdlib_ien(6,ie)
      ktmp        = kelem(:,ie) ! Copy
      nm(ie)      = - 1.d0/min(-thr,sum(min(zero,ktmp))) ! N-Values
      kelem(:,ie) = max(zero,ktmp)
      fl11  = c(i2,1) * pdlib_ien(1,ie) + c(i2,2) * pdlib_ien(2,ie) ! Weights for Simpson Integration
      fl12  = c(i3,1) * pdlib_ien(1,ie) + c(i3,2) * pdlib_ien(2,ie)
      fl21  = c(i3,1) * pdlib_ien(3,ie) + c(i3,2) * pdlib_ien(4,ie)
      fl22  = c(i1,1) * pdlib_ien(3,ie) + c(i1,2) * pdlib_ien(4,ie)
      fl31  = c(i1,1) * pdlib_ien(5,ie) + c(i1,2) * pdlib_ien(6,ie)
      fl32  = c(i2,1) * pdlib_ien(5,ie) + c(i2,2) * pdlib_ien(6,ie)
      fl111 = 2.d0*fl11+fl12
      fl112 = 2.d0*fl12+fl11
      fl211 = 2.d0*fl21+fl22
      fl212 = 2.d0*fl22+fl21
      fl311 = 2.d0*fl31+fl32
      fl312 = 2.d0*fl32+fl31
      flall(1,ie) = (fl311 + fl212) * onesixth + kelem(1,ie)
      flall(2,ie) = (fl111 + fl312) * onesixth + kelem(2,ie)
      flall(3,ie) = (fl211 + fl112) * onesixth + kelem(3,ie)
    END DO
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'PDLIB_W3XYPFSN2, step 3'
    FLUSH(740+iaproc)
#endif
    IF (lcalc) THEN
      kksum = zero
      DO ie = 1, ne
        ni = ine(:,ie)
        kksum(ni) = kksum(ni) + kelem(:,ie)
      END DO
      dtmaxexp = 1.e10
      DO ip = 1, np
        ip_glob      = iplg(ip)
        IF (iobp_loc(ip) .EQ. 1 .OR. fsbccfl) THEN
          dtmaxexp     = pdlib_si(ip)/max(dble(10.e-10),kksum(ip)*iobdp_loc(ip))
          dtmax        = min( dtmax, dtmaxexp)
        ENDIF
        cflxymax(ip) = max(cflxymax(ip),dble(dt)/dtmaxexp)
      END DO
      fin(1)=dtmax
      CALL mpi_allreduce(fin,fout,1,rtype,mpi_min,mpi_comm_wcmp,ierr)
      dtmax_gl=fout(1)
      cflxy = dble(dt)/dtmax_gl
      rest  = abs(mod(cflxy,1.0d0))
      IF (rest .LT. thr) THEN
        iter(ik,ith) = abs(nint(cflxy))
      ELSE IF (rest .GT. thr .AND. rest .LT. 0.5d0) THEN
        iter(ik,ith) = abs(nint(cflxy)) + 1
      ELSE
        iter(ik,ith) = abs(nint(cflxy))
      END IF
    END IF ! LCALC
 
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'PDLIB_W3XYPFSN2, step 4'
    FLUSH(740+iaproc)
#endif
    DO ip = 1, npa
      dtsi(ip) = dble(dt)/dble(iter(ik,ith))/pdlib_si(ip) ! Some precalculations for the time integration.
    END DO
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'PDLIB_W3XYPFSN2, step 4.1'
    FLUSH(740+iaproc)
    CALL scal_integral_print_r4(pdlib_si, "PDLIB_SI in input")
    WRITE(740+iaproc,*) 'PDLIB_W3XYPFSN2, step 4.2'
    FLUSH(740+iaproc)
    CALL scal_integral_print_r4(dtsi, "DTSI in input")
    WRITE(740+iaproc,*) 'PDLIB_W3XYPFSN2, step 5'
    WRITE(740+iaproc,*) 'IK=', ik, ' ITH=', ith
    WRITE(740+iaproc,*) 'ITER=', iter(ik,ith)
    FLUSH(740+iaproc)
#endif
 
 
    DO it = 1, iter(ik,ith)
#ifdef W3_DEBUGSOLVER
      WRITE(740+iaproc,*) 'IK=', ik, ' ITH=', ith
      WRITE(740+iaproc,*) 'IT=', it, ' ITER=', iter(ik,ith)
      FLUSH(740+iaproc)
      IF (testwrite) THEN
        WRITE(740+iaproc,*) 'IT=', it
        FLUSH(740+iaproc)
      END IF
#endif
      u = dble(ac)
      st = zero
      DO ie = 1, ne
        ni     = ine(:,ie)
        utilde = nm(ie) * (dot_product(flall(:,ie),u(ni)))
        st(ni) = st(ni) + kelem(:,ie) * (u(ni) - utilde) ! the 2nd term are the theta values of each node ...
      END DO ! IE
#ifdef W3_DEBUGSOLVER
      IF (testwrite) THEN
        CALL scal_integral_print_r4(st, "ST in loop")
      END IF
#endif
      !
      ! IOBPD=0  : waves coming from land
      ! IOBPD=1 : waves coming from the coast
      !
      DO ip = 1, npa
        u(ip) = max(zero,u(ip)-dtsi(ip)*st(ip)*(1-iobpa_loc(ip)))*dble(iobpd_loc(ith,ip))*iobdp_loc(ip)
#ifdef W3_REF1
        IF (refpars(3).LT.0.5.AND.iobpd_loc(ith,ip).EQ.0.AND.iobpa_loc(ip).EQ.0) u(ip) = ac(ip) ! restores reflected boundary values
#endif
      END DO
#ifdef W3_DEBUGSOLVER
      IF (testwrite) THEN
        CALL scal_integral_print_r4(u, "U in loop")
      END IF
#endif
      ac = real(u)
 
#ifdef W3_DEBUGSOLVER
      IF (testwrite) THEN
        CALL scal_integral_print_r4(ac, "AC in loop")
      END IF
#endif
      !
      ! 5 Update boundaries ... would be better to omit any if clause in this loop ...
      !   a possibility would be to use NBI = 0 when FLBPI is FALSE and loop on IBI whatever the value of NBI
      !
      IF ( flbpi ) THEN
        rd1=rd10 - dt * real(iter(ik,ith)-it)/real(iter(ik,ith))
        rd2=rd20
        IF ( rd2 .GT. 0.001 ) THEN
          rd2    = min(1.,max(0.,rd1/rd2))
          rd1    = 1. - rd2
        ELSE
          rd1    = 0.
          rd2    = 1.
        END IF
#ifdef W3_DEBUGSOLVER
        sumac=0
        sumbpi0=0
        sumbpin=0
        sumcg=0
        sumclats=0
#endif
        DO ibi = 1, nbi
          ip_glob = mapsf(isbpi(ibi),1)
          jx=ipgl_npa(ip_glob)
          IF (jx .gt. 0) THEN
            ac(jx) = ( rd1*bbpi0(isp,ibi) + rd2*bbpin(isp,ibi) )   &
                 / cg(ik,isbpi(ibi)) * clats(isbpi(ibi))
#ifdef W3_DEBUGSOLVER
            sumac=sumac + ac(jx)
            sumbpi0=sumbpi0 + bbpi0(isp,ibi)
            sumbpin=sumbpin + bbpin(isp,ibi)
            sumcg=sumcg + cg(ik,isbpi(ibi))
            sumclats=sumclats + clats(isbpi(ibi))
#endif
          END IF
        END DO
      END IF
 
#ifdef W3_DEBUGSOLVER
      WRITE(740+iaproc,*) 'NBI=', nbi
      WRITE(740+iaproc,*) 'RD1=', rd1, ' RD2=', rd2
      WRITE(740+iaproc,*) 'ISP=', isp, 'sumAC=', sumac
      WRITE(740+iaproc,*) 'ISP=', isp, 'sumBPI0=', sumbpi0
      WRITE(740+iaproc,*) 'ISP=', isp, 'sumBPIN=', sumbpin
      WRITE(740+iaproc,*) 'ISP=', isp, 'sumCG=', sumcg
      WRITE(740+iaproc,*) 'ISP=', isp, 'sumCLATS=', sumclats
      FLUSH(740+iaproc)
#endif
      CALL pdlib_exchange1dreal(ac)
 
#ifdef W3_DEBUGSOLVER
      IF (testwrite) THEN
        CALL scal_integral_print_r4(ac, "AC after FLBPI")
      END IF
#endif
    END DO
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'PDLIB_W3XYPFSN2, step 6'
    FLUSH(740+iaproc)
#endif
  END SUBROUTINE pdlib_w3xypfsn2
  !/ ------------------------------------------------------------------- /
  SUBROUTINE pdlib_w3xypfspsi2 ( ISP, C, LCALC, RD10, RD20, DT, AC)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Explicit PSI-Scheme
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
 
 
    USE w3gdatmd, only: nk, nth, nx,  ien, clats, mapsf
    USE w3gdatmd, only: iobpd_loc, iobp_loc, iobdp_loc, iobpa_loc, fsbccfl
    USE w3wdatmd, only: time
    USE w3adatmd, only: cg, iter, dw , cflxymax, nsealm
    USE w3odatmd, only: ndse, ndst, flbpi, nbi, tbpin, isbpi, bbpi0, bbpin
    USE w3timemd, only: dsec21
    USE w3adatmd, only: mpi_comm_wcmp
    USE w3gdatmd, only: nseal, dmin, nsea
#ifdef W3_REF1
    USE w3gdatmd, only: refpars
#endif
    USE yownodepool,    only: pdlib_si, pdlib_ien, pdlib_tria, ipgl, iplg, npa, np
    use yowelementpool, only: ne, ine
    use yowdatapool, only: rtype
    use yowexchangemodule, only : pdlib_exchange1dreal
    USE w3odatmd, only : iaproc
    USE mpi, only : mpi_min
    USE w3parall, only : init_get_jsea_isproc
    USE w3parall, only : onesixth, zero, thr
    USE yowrankmodule, only : ipgl_npa
    IMPLICIT NONE
    INTEGER, INTENT(IN)    :: ISP        ! Actual Frequency/Wavenumber,
                                         ! actual Wave Direction
    REAL,    INTENT(IN)    :: DT         ! Time intervall for which the
                                         ! advection should be computed
                                         ! for the given velocity field
    REAL,    INTENT(IN)    :: C(npa,2)   ! Velocity field in it's
                                         ! X- and Y- Components,
    REAL,    INTENT(INOUT) :: AC(npa)    ! Wave Action before and
                                         ! after advection
    REAL,    INTENT(IN)    :: RD10, RD20 ! Time interpolation
                                         ! coefficients for boundary
                                         ! conditions
    LOGICAL, INTENT(IN)    :: LCALC      ! Switch for the calculation of
                                         ! the max. Global Time step
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
#ifdef W3_REF1
    INTEGER(KIND=1)    :: IOBPDR(NX)
#endif
    INTEGER :: IP, IE, POS, IT, I1, I2, I3, I, J, ITH, IK
    INTEGER :: IBI, NI(3), JX
    INTEGER :: ISPROC, IP_glob, JSEA, ierr
    REAL    :: RD1, RD2
    REAL  :: UTILDE
    REAL  :: SUMTHETA
    REAL  :: FL1, FL2, FL3
    REAL  :: FT, CFLXY
    REAL  :: FL11, FL12, FL21, FL22, FL31, FL32
    REAL  :: FL111, FL112, FL211, FL212, FL311, FL312
    REAL  :: DTSI(npa), U(npa)
    REAL  :: DTMAX, DTMAX_GL, DTMAXEXP, REST
    REAL  :: LAMBDA(2), KTMP(3), TMP(3)
    REAL  :: THETA_L(3), BET1(3), BETAHAT(3)
    REAL  :: KELEM(3,NE), FLALL(3,NE)
    REAL  :: KKSUM(npa), ST(npa)
    REAL  :: NM(NE), FIN(1), FOUT(1)
#ifdef W3_S
    CALL strace (ient, 'W3XYPFSN')
#endif
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'PDLIB_W3XYPFSN2, step 1'
    FLUSH(740+iaproc)
    CALL scal_integral_print_r4(ac, "AC in input")
#endif
 
    ith    = 1 + mod(isp-1,nth)
    ik     = 1 + (isp-1)/nth
    dtmax  = dble(10.e10)
    !
#ifdef W3_REF1
    iobpdr(:)=(1-iobp_loc(:))*(1-iobpd_loc(ith,:))
#endif
 
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'NX=', nx
    WRITE(740+iaproc,*) 'PDLIB_W3XYPFSN2, step 2'
    FLUSH(740+iaproc)
#endif
    !
    !2       Propagation
    !2.a     Calculate K-Values and contour based quantities ...
    !
 
    DO ie = 1, ne
      i1 = ine(1,ie)
      i2 = ine(2,ie)
      i3 = ine(3,ie)
      lambda(1) = onesixth *(c(i1,1)+c(i2,1)+c(i3,1)) ! Linearized advection speed in X and Y direction
      lambda(2) = onesixth *(c(i1,2)+c(i2,2)+c(i3,2))
      kelem(1,ie) = lambda(1) * pdlib_ien(1,ie) + lambda(2) * pdlib_ien(2,ie) ! K-Values - so called Flux Jacobians
      kelem(2,ie) = lambda(1) * pdlib_ien(3,ie) + lambda(2) * pdlib_ien(4,ie)
      kelem(3,ie) = lambda(1) * pdlib_ien(5,ie) + lambda(2) * pdlib_ien(6,ie)
      ktmp        = kelem(:,ie) ! Copy
      nm(ie)      = - 1.d0/min(-thr,sum(min(zero,ktmp))) ! N-Values
      kelem(:,ie) = max(zero,ktmp)
      fl11  = c(i2,1) * pdlib_ien(1,ie) + c(i2,2) * pdlib_ien(2,ie) ! Weights for Simpson Integration
      fl12  = c(i3,1) * pdlib_ien(1,ie) + c(i3,2) * pdlib_ien(2,ie)
      fl21  = c(i3,1) * pdlib_ien(3,ie) + c(i3,2) * pdlib_ien(4,ie)
      fl22  = c(i1,1) * pdlib_ien(3,ie) + c(i1,2) * pdlib_ien(4,ie)
      fl31  = c(i1,1) * pdlib_ien(5,ie) + c(i1,2) * pdlib_ien(6,ie)
      fl32  = c(i2,1) * pdlib_ien(5,ie) + c(i2,2) * pdlib_ien(6,ie)
      fl111 = 2.d0*fl11+fl12
      fl112 = 2.d0*fl12+fl11
      fl211 = 2.d0*fl21+fl22
      fl212 = 2.d0*fl22+fl21
      fl311 = 2.d0*fl31+fl32
      fl312 = 2.d0*fl32+fl31
      flall(1,ie) = (fl311 + fl212)! * ONESIXTH + KELEM(1,IE)
      flall(2,ie) = (fl111 + fl312)! * ONESIXTH + KELEM(2,IE)
      flall(3,ie) = (fl211 + fl112)! * ONESIXTH + KELEM(3,IE)
    END DO
 
    IF (lcalc) THEN
      kksum = zero
      DO ie = 1, ne
        ni = ine(:,ie)
        kksum(ni) = kksum(ni) + kelem(:,ie)
      END DO
      dtmaxexp = 1.e10
      DO ip = 1, npa
        ip_glob      = iplg(ip)
        IF (iobp_loc(ip) .EQ. 1 .OR. fsbccfl) THEN
          dtmaxexp     = pdlib_si(ip)/max(dble(10.e-10),kksum(ip)*iobdp_loc(ip))
          dtmax        = min( dtmax, dtmaxexp)
        ENDIF
        cflxymax(ip) = max(cflxymax(ip),dble(dt)/dtmaxexp)
      END DO
      fin(1)=dtmax
      CALL mpi_allreduce(fin,fout,1,rtype,mpi_min,mpi_comm_wcmp,ierr)
      dtmax_gl=fout(1)
      cflxy = dble(dt)/dtmax_gl
      rest  = abs(mod(cflxy,1.0d0))
      IF (rest .LT. thr) THEN
        iter(ik,ith) = abs(nint(cflxy))
      ELSE IF (rest .GT. thr .AND. rest .LT. 0.5d0) THEN
        iter(ik,ith) = abs(nint(cflxy)) + 1
      ELSE
        iter(ik,ith) = abs(nint(cflxy))
      END IF
    END IF ! LCALC
 
    DO ip = 1, npa
      dtsi(ip) = dble(dt)/dble(iter(ik,ith))/pdlib_si(ip) ! Some precalculations for the time integration.
    END DO
 
    DO it = 1, iter(ik,ith)
 
      u  = dble(ac)
      st = zero
 
      DO ie = 1, ne
        ni   =  ine(:,ie)
        ft   = - onesixth*dot_product(u(ni),flall(:,ie))
        utilde = nm(ie) * ( dot_product(kelem(:,ie),u(ni)) - ft )
        theta_l(:) = kelem(:,ie) * (u(ni) - utilde)
        IF (abs(ft) .GT. 0.0d0) THEN
          bet1(:) = theta_l(:)/ft
          IF (any( bet1 .LT. 0.0d0) ) THEN
            betahat(1)    = bet1(1) + 0.5d0 * bet1(2)
            betahat(2)    = bet1(2) + 0.5d0 * bet1(3)
            betahat(3)    = bet1(3) + 0.5d0 * bet1(1)
            bet1(1)       = max(zero,min(betahat(1),1.d0-betahat(2),1.d0))
            bet1(2)       = max(zero,min(betahat(2),1.d0-betahat(3),1.d0))
            bet1(3)       = max(zero,min(betahat(3),1.d0-betahat(1),1.d0))
            theta_l(:) = ft * bet1
          END IF
        ELSE
          theta_l(:) = zero
        END IF
        st(ni) = st(ni) + theta_l ! the 2nd term are the theta values of each node ...
      END DO
 
#ifdef W3_DEBUGSOLVER
      IF (testwrite) THEN
        CALL scal_integral_print_r4(st, "ST in loop")
      END IF
#endif
      !
      DO ip = 1, npa
        u(ip) = max(zero,u(ip)-dtsi(ip)*st(ip)*(1-iobpa_loc(ip)))*iobpd_loc(ith,ip)*iobdp_loc(ip)
#ifdef W3_REF1
        IF (refpars(3).LT.0.5.AND.iobpd_loc(ith,ip).EQ.0.AND.iobpa_loc(ip).EQ.0) u(ip) = ac(ip) ! restores reflected boundary values
#endif
      END DO
      ac = real(u)
      !
      ! 5 Update boundaries ... this should be implemented differently ... it is better to omit any if clause in this loop ...
      !
      IF ( flbpi ) THEN
        rd1=rd10 - dt * real(iter(ik,ith)-it)/real(iter(ik,ith))
        rd2=rd20
        IF ( rd2 .GT. 0.001 ) THEN
          rd2    = min(1.,max(0.,rd1/rd2))
          rd1    = 1. - rd2
        ELSE
          rd1    = 0.
          rd2    = 1.
        END IF
        !
        ! NB: this treatment of the open boundary (time interpolation) is different from
        ! the constant boundary in the structured grids ... which restores the boundary
        ! to the initial value: IF ( MAPSTA(IXY).EQ.2 ) VQ(IXY) = AQ(IXY)
        ! Why this difference ?
        !
        DO ibi=1, nbi
          ip_glob    = mapsf(isbpi(ibi),1)
          jx=ipgl_npa(ip_glob)
          IF (jx .gt. 0) THEN
            ac(jx) = ( rd1*bbpi0(isp,ibi) + rd2*bbpin(isp,ibi) )   &
                 / cg(ik,isbpi(ibi)) * clats(isbpi(ibi))
#ifdef W3_DEBUGSOLVER
            sumac=sumac + ac(jx)
            sumbpi0=sumbpi0 + bbpi0(isp,ibi)
            sumbpin=sumbpin + bbpin(isp,ibi)
            sumcg=sumcg + cg(ik,isbpi(ibi))
            sumclats=sumclats + clats(isbpi(ibi))
#endif
          END IF
        ENDDO
      END IF
 
#ifdef W3_DEBUGSOLVER
      WRITE(740+iaproc,*) 'NBI=', nbi
      WRITE(740+iaproc,*) 'RD1=', rd1, ' RD2=', rd2
      WRITE(740+iaproc,*) 'ISP=', isp, 'sumAC=', sumac
      WRITE(740+iaproc,*) 'ISP=', isp, 'sumBPI0=', sumbpi0
      WRITE(740+iaproc,*) 'ISP=', isp, 'sumBPIN=', sumbpin
      WRITE(740+iaproc,*) 'ISP=', isp, 'sumCG=', sumcg
      WRITE(740+iaproc,*) 'ISP=', isp, 'sumCLATS=', sumclats
      FLUSH(740+iaproc)
#endif
      CALL pdlib_exchange1dreal(ac)
 
#ifdef W3_DEBUGSOLVER
      IF (testwrite) THEN
        CALL scal_integral_print_r4(ac, "AC after FLBPI")
      END IF
#endif
    END DO ! IT
 
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'PDLIB_W3XYPFSN2, step 6'
    FLUSH(740+iaproc)
#endif
 
  END SUBROUTINE pdlib_w3xypfspsi2
  !/ ------------------------------------------------------------------- /
  SUBROUTINE pdlib_w3xypfsfct2 ( ISP, C, LCALC, RD10, RD20, DT, AC)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Explicit PSI-Scheme
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
 
 
    USE w3gdatmd, only: nk, nth, nx,  ien, clats, mapsf
    USE w3gdatmd, only: iobpd_loc, iobp_loc, iobdp_loc, iobpa_loc, fsbccfl
    USE w3wdatmd, only: time
    USE w3adatmd, only: cg, iter, dw , cflxymax, nsealm
    USE w3odatmd, only: ndse, ndst, flbpi, nbi, tbpin, isbpi, bbpi0, bbpin
    USE w3timemd, only: dsec21
    USE w3adatmd, only: mpi_comm_wcmp
    USE w3gdatmd, only: nseal, dmin, nsea
#ifdef W3_REF1
    USE w3gdatmd, only: refpars
#endif
    USE yownodepool,    only: pdlib_si, pdlib_ien, pdlib_tria, pdlib_ccon, pdlib_ie_cell2, ipgl, iplg, npa, np
    use yowelementpool, only: ne, ine
    use yowdatapool, only: rtype
    use yowexchangemodule, only : pdlib_exchange1dreal
    USE w3odatmd, only : iaproc
    USE mpi, only : mpi_min
    USE w3parall, only : init_get_jsea_isproc
    USE w3parall, only : onesixth, zero, thr
    USE yowrankmodule, only : ipgl_npa
 
    IMPLICIT NONE
    INTEGER, INTENT(IN)    :: ISP        ! Actual Frequency/Wavenumber,
                                         ! actual Wave Direction
    REAL,    INTENT(IN)    :: DT         ! Time intervall for which the
                                         ! advection should be computed
                                         ! for the given velocity field
    REAL,    INTENT(IN)    :: C(npa,2)   ! Velocity field in it's
                                         ! X- and Y- Components,
    REAL,    INTENT(INOUT) :: AC(npa)    ! Wave Action before and
                                         ! after advection
    REAL,    INTENT(IN)    :: RD10, RD20 ! Time interpolation
                                         ! coefficients for boundary
                                         ! conditions
    LOGICAL, INTENT(IN)    :: LCALC      ! Switch for the calculation of
                                         ! the max. Global Time step
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
#ifdef W3_REF1
    INTEGER(KIND=1)    :: IOBPDR(NX)
#endif
    INTEGER :: IP, IE, POS, IT, I1, I2, I3, I, J, ITH, IK
    INTEGER :: IBI, NI(3)
    INTEGER :: JX
    !
    ! local REAL
    !
    REAL    :: RD1, RD2
    !:
    ! local double
    !
    REAL  :: SUMTHETA, CFLXY
    real*8  :: ft, utilde
    real*8  :: fl11, fl12, fl21, fl22, fl31, fl32
    real*8  :: fl111, fl112, fl211, fl212, fl311, fl312
    REAL  :: DTSI(npa), U(npa), UL(npa)
    REAL  :: DTMAX_GL, DTMAX, DTMAXEXP, REST
    real*8  :: lambda(2), ktmp(3)
    real*8  :: kelem(3,ne), flall(3,ne)
    real*8  :: kksum(npa), st(npa)
    real*8  :: nm(ne), bet1(3), betahat(3), tmp(3), tmp1
    INTEGER :: ISPROC, JSEA, IP_glob, ierr, IX
    REAL  :: eSumAC, sumAC, sumBPI0, sumBPIN, sumCG, sumCLATS
    LOGICAL :: testWrite
    REAL  :: FIN(1), FOUT(1)
    REAL  :: UIP(NE), UIPIP(NPA), UIMIP(NPA), U3(3)
    real*8 :: theta_h(3), theta_ace(3,ne), theta_l(3,ne)
    real*8 :: pm(npa), pp(npa), uim(ne), wii(2,npa)
    REAL   :: USTARI(2,NPA)
 
#ifdef W3_S
    CALL strace (ient, 'W3XYPFSN')
#endif
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'PDLIB_W3XYPFSN2, step 1'
    FLUSH(740+iaproc)
    CALL scal_integral_print_r4(ac, "AC in input")
#endif
 
    ith    = 1 + mod(isp-1,nth)
    ik     = 1 + (isp-1)/nth
    dtmax  = dble(10.e10)
    !
#ifdef W3_REF1
    iobpdr(:)=(1-iobp_loc(:))*(1-iobpd_loc(ith,:))
#endif
 
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'NX=', nx
    WRITE(740+iaproc,*) 'PDLIB_W3XYPFSN2, step 2'
    FLUSH(740+iaproc)
#endif
    !
    !2       Propagation
    !2.a     Calculate K-Values and contour based quantities ...
    !
 
    DO ie = 1, ne
      i1 = ine(1,ie)
      i2 = ine(2,ie)
      i3 = ine(3,ie)
      lambda(1) = onesixth *(c(i1,1)+c(i2,1)+c(i3,1)) ! Linearized advection speed in X and Y direction
      lambda(2) = onesixth *(c(i1,2)+c(i2,2)+c(i3,2))
      kelem(1,ie) = lambda(1) * pdlib_ien(1,ie) + lambda(2) * pdlib_ien(2,ie) ! K-Values - so called Flux Jacobians
      kelem(2,ie) = lambda(1) * pdlib_ien(3,ie) + lambda(2) * pdlib_ien(4,ie)
      kelem(3,ie) = lambda(1) * pdlib_ien(5,ie) + lambda(2) * pdlib_ien(6,ie)
      ktmp        = kelem(:,ie) ! Copy
      nm(ie)      = - 1.d0/min(-thr,sum(min(zero,ktmp))) ! N-Values
      kelem(:,ie) = max(zero,ktmp)
      fl11  = c(i2,1) * pdlib_ien(1,ie) + c(i2,2) * pdlib_ien(2,ie) ! Weights for Simpson Integration
      fl12  = c(i3,1) * pdlib_ien(1,ie) + c(i3,2) * pdlib_ien(2,ie)
      fl21  = c(i3,1) * pdlib_ien(3,ie) + c(i3,2) * pdlib_ien(4,ie)
      fl22  = c(i1,1) * pdlib_ien(3,ie) + c(i1,2) * pdlib_ien(4,ie)
      fl31  = c(i1,1) * pdlib_ien(5,ie) + c(i1,2) * pdlib_ien(6,ie)
      fl32  = c(i2,1) * pdlib_ien(5,ie) + c(i2,2) * pdlib_ien(6,ie)
      fl111 = 2.d0*fl11+fl12
      fl112 = 2.d0*fl12+fl11
      fl211 = 2.d0*fl21+fl22
      fl212 = 2.d0*fl22+fl21
      fl311 = 2.d0*fl31+fl32
      fl312 = 2.d0*fl32+fl31
      flall(1,ie) = (fl311 + fl212)! * ONESIXTH + KELEM(1,IE)
      flall(2,ie) = (fl111 + fl312)! * ONESIXTH + KELEM(2,IE)
      flall(3,ie) = (fl211 + fl112)! * ONESIXTH + KELEM(3,IE)
    END DO
 
    IF (lcalc) THEN
      kksum = zero
      DO ie = 1, ne
        ni = ine(:,ie)
        kksum(ni) = kksum(ni) + kelem(:,ie)
      END DO
      dtmaxexp = 1.e10
      DO ip = 1, np
        ip_glob      = iplg(ip)
        IF (iobp_loc(ip) .EQ. 1 .OR. fsbccfl) THEN
          dtmaxexp     = pdlib_si(ip)/max(dble(10.e-10),kksum(ip)*iobdp_loc(ip))
          dtmax        = min( dtmax, dtmaxexp)
        ENDIF
        cflxymax(ip) = max(cflxymax(ip),dble(dt)/dtmaxexp)
      END DO
      fin(1)=dtmax
      CALL mpi_allreduce(fin,fout,1,rtype,mpi_min,mpi_comm_wcmp,ierr)
      dtmax_gl=fout(1)
      cflxy = dble(dt)/dtmax_gl
      rest  = abs(mod(cflxy,1.0d0))
      IF (rest .LT. thr) THEN
        iter(ik,ith) = abs(nint(cflxy))
      ELSE IF (rest .GT. thr .AND. rest .LT. 0.5d0) THEN
        iter(ik,ith) = abs(nint(cflxy)) + 1
      ELSE
        iter(ik,ith) = abs(nint(cflxy))
      END IF
    END IF ! LCALC
 
    DO ip = 1, npa
      dtsi(ip) = dble(dt)/dble(iter(ik,ith))/pdlib_si(ip) ! Some precalculations for the time integration.
    END DO
 
    DO it = 1, iter(ik,ith)
 
      u  = dble(ac)
      st = zero
      pm = zero
      pp = zero
      DO ie = 1, ne
        ni   =  ine(:,ie)
        ft   = - onesixth*dot_product(u(ni),flall(:,ie))
        utilde = nm(ie) * ( dot_product(kelem(:,ie),u(ni)) - ft )
        theta_l(:,ie) = kelem(:,ie) * (u(ni) - utilde)
        IF (abs(ft) .GT. 0.0d0) THEN
          bet1(:) = theta_l(:,ie)/ft
          IF (any( bet1 .LT. 0.0d0) ) THEN
            betahat(1)    = bet1(1) + 0.5d0 * bet1(2)
            betahat(2)    = bet1(2) + 0.5d0 * bet1(3)
            betahat(3)    = bet1(3) + 0.5d0 * bet1(1)
            bet1(1)       = max(zero,min(betahat(1),1.d0-betahat(2),1.d0))
            bet1(2)       = max(zero,min(betahat(2),1.d0-betahat(3),1.d0))
            bet1(3)       = max(zero,min(betahat(3),1.d0-betahat(1),1.d0))
            theta_l(:,ie) = ft * bet1
          END IF
        END IF
        st(ni) = st(ni) + theta_l(:,ie) ! the 2nd term are the theta values of each node ...
        theta_h         = (1./3.+dt/(2.*pdlib_tria(ie)) * kelem(:,ie) ) * ft ! LAX
        !        THETA_H = (1./3.+2./3.*KELEM(:,IE)/SUM(MAX(ZERO,KELEM(:,IE))))*FT  ! CENTRAL ... can be tested as well a bit more dispersive then LAX
        theta_ace(:,ie) = theta_h-theta_l(:,ie)
        pp(ni) =  pp(ni) + max(zero, -theta_ace(:,ie)) * dtsi(ni)
        pm(ni) =  pm(ni) + min(zero, -theta_ace(:,ie)) * dtsi(ni)
      END DO
 
#ifdef W3_DEBUGSOLVER
      IF (testwrite) THEN
        CALL scal_integral_print_r4(st, "ST in loop")
      END IF
#endif
 
      DO ip = 1, npa
        ul(ip) = max(zero,u(ip)-dtsi(ip)*st(ip)*(1-iobpa_loc(ip)))*dble(iobpd_loc(ith,ip))*iobdp_loc(ip)
      END DO
 
#ifdef MPI_PARALL_GRID
      CALL pdlib_exchange1dreal(ul)
#endif
 
      ustari(1,:) = max(ul,u)
      ustari(2,:) = min(ul,u)
 
      uip = 0.
      uim = 0.
      DO ie = 1, ne
        ni = ine(:,ie)
        uip(ni) = max(uip(ni), maxval( ustari(1,ni) ))
        uim(ni) = min(uim(ni), minval( ustari(2,ni) ))
      END DO
 
      wii(1,:) = min(1.0d0,(uip-ul)/max( thr,pp))
      wii(2,:) = min(1.0d0,(uim-ul)/min(-thr,pm))
 
      st = zero
      DO ie = 1, ne
        i1 = ine(1,ie)
        i2 = ine(2,ie)
        i3 = ine(3,ie)
        IF (theta_ace(1,ie) .LT. zero) THEN
          tmp(1) = wii(1,i1)
        ELSE
          tmp(1) = wii(2,i1)
        END IF
        IF (theta_ace(2,ie) .LT. zero) THEN
          tmp(2) = wii(1,i2)
        ELSE
          tmp(2) = wii(2,i2)
        END IF
        IF (theta_ace(3,ie) .LT. zero) THEN
          tmp(3) = wii(1,i3)
        ELSE
          tmp(3) = wii(2,i3)
        END IF
        tmp1 = minval(tmp)
        st(i1) = st(i1) + theta_ace(1,ie) * tmp1! * (ONE - BL) + BL * THETA_L(1,IE)
        st(i2) = st(i2) + theta_ace(2,ie) * tmp1! * (ONE - BL) + BL * THETA_L(2,IE)
        st(i3) = st(i3) + theta_ace(3,ie) * tmp1! * (ONE - BL) + BL * THETA_L(3,IE)
      END DO
 
      DO ip = 1, npa
        u(ip) = max(zero,ul(ip)-dtsi(ip)*st(ip)*(1-iobpa_loc(ip)))*dble(iobpd_loc(ith,ip))*iobdp_loc(ip)
#ifdef W3_REF1
        IF (refpars(3).LT.0.5.AND.iobpd_loc(ith,ip).EQ.0.AND.iobpa_loc(ip).EQ.0) u(ip) = ac(ip) ! restores reflected boundary values
#endif
      END DO
 
      ac = real(u)
 
#ifdef W3_DEBUGSOLVER
      IF (testwrite) THEN
        CALL scal_integral_print_r4(ac, "AC in loop")
      END IF
#endif
      !
      ! 5 Update boundaries ... would be better to omit any if clause in this loop ...
      !   a possibility would be to use NBI = 0 when FLBPI is FALSE and loop on IBI whatever the value of NBI
      !
      IF ( flbpi ) THEN
        rd1=rd10 - dt * real(iter(ik,ith)-it)/real(iter(ik,ith))
        rd2=rd20
        IF ( rd2 .GT. 0.001 ) THEN
          rd2    = min(1.,max(0.,rd1/rd2))
          rd1    = 1. - rd2
        ELSE
          rd1    = 0.
          rd2    = 1.
        END IF
#ifdef W3_DEBUGSOLVER
        sumac=0
        sumbpi0=0
        sumbpin=0
        sumcg=0
        sumclats=0
#endif
        DO ibi = 1, nbi
          ip_glob = mapsf(isbpi(ibi),1)
          jx=ipgl_npa(ip_glob)
          IF (jx .gt. 0) THEN
            ac(jx) = ( rd1*bbpi0(isp,ibi) + rd2*bbpin(isp,ibi) )   &
                 / cg(ik,isbpi(ibi)) * clats(isbpi(ibi))
#ifdef W3_DEBUGSOLVER
            sumac=sumac + ac(jx)
            sumbpi0=sumbpi0 + bbpi0(isp,ibi)
            sumbpin=sumbpin + bbpin(isp,ibi)
            sumcg=sumcg + cg(ik,isbpi(ibi))
            sumclats=sumclats + clats(isbpi(ibi))
#endif
          END IF
        END DO
      END IF
 
#ifdef W3_DEBUGSOLVER
      WRITE(740+iaproc,*) 'NBI=', nbi
      WRITE(740+iaproc,*) 'RD1=', rd1, ' RD2=', rd2
      WRITE(740+iaproc,*) 'ISP=', isp, 'sumAC=', sumac
      WRITE(740+iaproc,*) 'ISP=', isp, 'sumBPI0=', sumbpi0
      WRITE(740+iaproc,*) 'ISP=', isp, 'sumBPIN=', sumbpin
      WRITE(740+iaproc,*) 'ISP=', isp, 'sumCG=', sumcg
      WRITE(740+iaproc,*) 'ISP=', isp, 'sumCLATS=', sumclats
      FLUSH(740+iaproc)
#endif
      CALL pdlib_exchange1dreal(ac)
 
#ifdef W3_DEBUGSOLVER
      IF (testwrite) THEN
        CALL scal_integral_print_r4(ac, "AC after FLBPI")
      END IF
#endif
    END DO ! IT
 
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'PDLIB_W3XYPFSN2, step 6'
    FLUSH(740+iaproc)
#endif
 
  END SUBROUTINE pdlib_w3xypfsfct2
  !/ ------------------------------------------------------------------- /
 
  SUBROUTINE test_mpi_status(string)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Check mpi status
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
 
    USE w3adatmd, only : mpi_comm_wcmp
    USE w3gdatmd, only : gtype, ungtype
    USE w3odatmd, only : iaproc, naproc, ntproc
    use yowdatapool, only: rtype, istatus
 
    include "mpif.h"
    CHARACTER(*), INTENT(in) :: string
    REAL VcollExp(1)
    REAL rVect(1)
    INTEGER iProc, ierr
    WRITE(740+iaproc,*) 'TEST_MPI_STATUS, at string=', string
    FLUSH(740+iaproc)
    IF (iaproc .gt. naproc) THEN
      RETURN
    END IF
    WRITE(740+iaproc,*) 'After status settings'
    FLUSH(740+iaproc)
    !
    ! Now find global arrays
    !
    IF (iaproc .eq. 1) THEN
      DO iproc=2,naproc
        CALL mpi_recv(rvect,1,mpi_real, iproc-1, 37, mpi_comm_wcmp, istatus, ierr)
      END DO
    ELSE
      CALL mpi_send(vcollexp,1,mpi_real, 0, 37, mpi_comm_wcmp, ierr)
    END IF
    WRITE(740+iaproc,*) 'Leaving the TEST_MPI_STATUS'
    FLUSH(740+iaproc)
  END SUBROUTINE test_mpi_status
  !/ ------------------------------------------------------------------- /
 
  SUBROUTINE scal_integral_print_general(V, string, maxidx, CheckUncovered, PrintFullValue)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Source code for parallel debugging
    !  2. Method : maxidx = npa or np for arrays that have been synchronized or not
    !              CheckUncovered is because some the triangulation may not cover all nodes
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
    !
    USE w3gdatmd, only : nk, nth, fte
    USE w3gdatmd, only : nspec, nx, ny, nseal, mapfs
    USE w3adatmd, only : mpi_comm_wcmp
    USE w3gdatmd, only : gtype, ungtype
    USE w3odatmd, only : iaproc, naproc, ntproc
    use yowdatapool, only: rtype, istatus
    USE yownodepool, only: npa, iplg
    USE w3parall, only: init_get_isea
 
    include "mpif.h"
    !
    real*8, INTENT(in) :: v(nseal)
    CHARACTER(*), INTENT(in) :: string
    INTEGER, INTENT(IN) :: maxidx
    LOGICAL, INTENT(in) :: CheckUncovered
    LOGICAL, INTENT(in) :: PrintFullValue
    !
    real*8, allocatable :: vcoll(:)
    INTEGER, allocatable :: Status(:)
    real*8, allocatable :: listval(:)
    INTEGER, allocatable :: ListIdx(:)
    INTEGER singV(2)
    REAL CoherencyError, eVal1, eVal2, eErr
    INTEGER NSEAL_dist, maxidx_dist
    INTEGER JSEA, ISEA, iProc, I, IX, ierr, ISP, IP, IP_glob
    INTEGER nbIncorr, idx
    INTEGER ITH, IK
 
    IF (iaproc .gt. naproc) THEN
      RETURN
    END IF
    IF (gtype .ne. ungtype) THEN
      RETURN
    END IF
    !
    ! Now find global arrays
    !
    IF (iaproc .eq. 1) THEN
      coherencyerror=0
      allocate(vcoll(nx), status(nx))
      vcoll=0
      status=0
      DO jsea=1,maxidx
        ip      = jsea
        ip_glob = iplg(ip)
        isea=mapfs(1,ip_glob)
        vcoll(ip_glob)=v(jsea)
        status(ip_glob)=1
      END DO
      DO iproc=2,naproc
        CALL mpi_recv(singv,2,mpi_integer, iproc-1, 360, mpi_comm_wcmp, istatus, ierr)
        nseal_dist = singv(1)
        maxidx_dist = singv(2)
        allocate(listval(nseal_dist), listidx(nseal_dist))
        CALL mpi_recv(listval, nseal_dist, mpi_real8,   iproc-1, 370, mpi_comm_wcmp, istatus, ierr)
        CALL mpi_recv(listidx, nseal_dist, mpi_integer, iproc-1, 430, mpi_comm_wcmp, istatus, ierr)
        DO idx=1,maxidx_dist
          ip_glob = listidx(idx)
          eval1 = vcoll(ip_glob)
          eval2 = listval(idx)
          vcoll(ip_glob) = eval2
          IF (status(ip_glob) .eq. 1) THEN
            eerr=abs(eval1 - eval2)
            coherencyerror = coherencyerror + eerr
          END IF
          status(ip_glob) = 1
        END DO
        deallocate(listval, listidx)
      END DO
      WRITE(740+iaproc,'(a,f14.7,f14.7,a,a)') 'sum,coh=', sum(vcoll), coherencyerror, ' ', trim(string)
      nbincorr=0
      DO ix=1,nx
        isea=mapfs(1,ix)
        IF (isea .gt. 0) THEN
          IF (status(ix) .eq. 0) THEN
            nbincorr=nbincorr+1
          END IF
        END IF
      END DO
      IF (checkuncovered) THEN
        IF (nbincorr .gt. 0) THEN
          WRITE(*,*) '    nbIncorr=', nbincorr
          WRITE(*,*) '          NX=', nx
          WRITE(*,*) '       NSEAL=', nseal
          WRITE(*,*) '         npa=', npa
          stop
        END IF
      END IF
      IF (printfullvalue) THEN
        WRITE(740+iaproc,*) 'Value of V at nodes'
        DO ix=1,nx
          WRITE(740+iaproc,*) 'IX=', ix, ' V=', vcoll(ix)
        END DO
      END IF
      FLUSH(740+iaproc)
      deallocate(vcoll, status)
    ELSE
      singv(1) = nseal
      singv(2) = maxidx
      CALL mpi_send(singv,2,mpi_integer, 0, 360, mpi_comm_wcmp, ierr)
      allocate(listval(nseal), listidx(nseal))
      DO jsea=1,nseal
        ip      = jsea
        ip_glob = iplg(ip)
        isea=mapfs(1,ip_glob)
        listval(jsea) = v(jsea)
        listidx(jsea) = ip_glob
      END DO
      CALL mpi_send(listval, nseal, mpi_real8,   0, 370, mpi_comm_wcmp, ierr)
      CALL mpi_send(listidx, nseal, mpi_integer, 0, 430, mpi_comm_wcmp, ierr)
      deallocate(listval, listidx)
    END IF
  END SUBROUTINE scal_integral_print_general
  !/ ------------------------------------------------------------------- /
  SUBROUTINE scal_integral_print_r8(V, string)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Source code for parallel debugging
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
 
    USE w3gdatmd, only : nseal
 
    real*8, INTENT(in) :: v(nseal)
    CHARACTER(*), INTENT(in) :: string
    real*8 :: v8(nseal)
    LOGICAL :: CheckUncovered = .false.
    LOGICAL :: PrintFullValue = .false.
    v8 = v
    CALL scal_integral_print_general(v8, string, nseal, checkuncovered, printfullvalue)
  END SUBROUTINE scal_integral_print_r8
  !/ ------------------------------------------------------------------- /
  SUBROUTINE scal_integral_print_r4(V, string)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Source code for parallel debugging
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
 
    USE w3gdatmd, only : nseal
 
    REAL, INTENT(in) :: V(NSEAL)
    CHARACTER(*), INTENT(in) :: string
    LOGICAL :: CheckUncovered = .false.
    LOGICAL :: PrintFullValue = .false.
    real*8 v8(nseal)
    v8 = dble(v)
    CALL scal_integral_print_general(v8, string, nseal, checkuncovered, printfullvalue)
  END SUBROUTINE scal_integral_print_r4
  !/ ------------------------------------------------------------------- /
  SUBROUTINE all_vaold_integral_print(string, choice)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Source code for parallel debugging
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
 
    USE w3gdatmd, only : nseal
    USE w3wdatmd, only : vaold
    USE w3odatmd, only : iaproc
    USE w3gdatmd, only : nspec
    USE yownodepool, only: np, npa
 
    CHARACTER(*), INTENT(in) :: string
    INTEGER, INTENT(in) :: choice
    REAL :: FIELD(NSPEC,NSEAL)
    INTEGER ISPEC, JSEA, maxidx
    LOGICAL :: PrintMinISP = .false.
    LOGICAL :: LocalizeMaximum = .false.
    DO jsea=1,nseal
      DO ispec=1,nspec
        field(ispec,jsea) = vaold(ispec,jsea)
      END DO
    END DO
    IF (choice .eq. 1) THEN
      maxidx = npa
    ELSE
      maxidx = np
    END IF
    !      CALL ALL_FIELD_INTEGRAL_PRINT_GENERAL(FIELD, string)
    CALL check_array_integral_nx_r8_maxfunct(field, string, maxidx, printminisp, localizemaximum)
  END SUBROUTINE all_vaold_integral_print
  !/ ------------------------------------------------------------------- /
  SUBROUTINE all_va_integral_print(IMOD, string, choice)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Source code for parallel debugging
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
 
    USE w3gdatmd, only : nseal, nsea, nx, ny
    USE w3wdatmd, only : va
    USE w3odatmd, only : iaproc, naproc
    USE w3gdatmd, only : nspec, grids, gtype, ungtype
    USE yownodepool, only: npa, np, iplg
 
    INTEGER, INTENT(in) :: IMOD
    CHARACTER(*), INTENT(in) :: string
    INTEGER, INTENT(in) :: choice
    REAL :: FIELD(NSPEC,NSEAL)
    INTEGER ISPEC, JSEA, IP_glob, maxidx
    LOGICAL :: PrintMinISP = .false.
    LOGICAL :: LocalizeMaximum = .false.
    INTEGER :: TEST_IP = 46
    INTEGER :: TEST_ISP = 370
    IF (grids(imod)%GTYPE .ne. ungtype) THEN
      RETURN
    END IF
    IF (iaproc .gt. naproc) THEN
      RETURN
    END IF
    WRITE(740+iaproc,*) 'Entering ALL_INTEGRAL_PRINT, NSEAL=', nseal
    FLUSH(740+iaproc)
    IF (nseal .ne. npa) THEN
      print *, 'NSEAL=', nseal, " npa=", npa
      stop
    END IF
    DO jsea=1,nseal
      ip_glob=iplg(jsea)
      DO ispec=1,nspec
        field(ispec,jsea) = va(ispec,jsea)
        IF ((ip_glob .eq. test_ip).and.(ispec .eq. test_isp)) THEN
          WRITE(740+iaproc,*) 'ASS TEST_IP=', test_ip, ' TEST_ISP=', test_isp, ' val=', va(ispec,jsea)
        END IF
      END DO
    END DO
    WRITE(740+iaproc,*) 'Before call to ALL_FIELD_INTEGRAL'
    WRITE(740+iaproc,*) 'NSPEC=', nspec, ' NX=', nx
    FLUSH(740+iaproc)
    IF (choice .eq. 1) THEN
      maxidx = npa
    ELSE
      maxidx = np
    END IF
    CALL check_array_integral_nx_r8_maxfunct(field, string, maxidx, printminisp, localizemaximum)
    WRITE(740+iaproc,*) 'After call to ALL_FIELD_INTEGRAL'
    FLUSH(740+iaproc)
  END SUBROUTINE all_va_integral_print
  !/ ------------------------------------------------------------------- /
  SUBROUTINE all_field_integral_print(FIELD, string)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Source code for parallel debugging
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
 
    USE w3gdatmd, only : nseal
    USE w3wdatmd, only : va
    USE w3odatmd, only : iaproc
    USE w3gdatmd, only : nspec
 
    INTEGER maxidx
    REAL, INTENT(in) :: FIELD(NSPEC,NSEAL)
    CHARACTER(*), INTENT(in) :: string
    LOGICAL :: PrintMinISP = .false.
    LOGICAL :: LocalizeMaximum = .false.
    maxidx = nseal
    CALL check_array_integral_nx_r8_maxfunct(field, string, maxidx, printminisp, localizemaximum)
  END SUBROUTINE all_field_integral_print
  !/ ------------------------------------------------------------------- /
  !/ ------- Coherency info for TheARR(NSPEC,npa) ---------------------- /
  !/ ----------- maxidx is np or npa ----------------------------------- /
  !/ ------------------------------------------------------------------- /
  SUBROUTINE check_array_integral_nx_r8_maxfunct(TheARR, string, maxidx, PrintMinISP, LocalizeMaximum)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Source code for parallel debugging
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
 
    USE w3gdatmd, only : nk, nth
    USE w3gdatmd, only : nspec, nx, ny, nseal, mapfs
    USE w3adatmd, only : mpi_comm_wcmp
    USE w3gdatmd, only : gtype, ungtype
    USE w3odatmd, only : iaproc, naproc, ntproc
    use yowdatapool, only: rtype, istatus
    USE yownodepool, only: npa, iplg
    USE w3parall, only: init_get_isea
 
    include "mpif.h"
    CHARACTER(*), INTENT(in) :: string
    INTEGER, INTENT(in) :: maxidx
    REAL, INTENT(in) :: TheARR(NSPEC, npa)
    LOGICAL, INTENT(in) :: PrintMinISP, LocalizeMaximum
    !
    REAL Vcoll(NSPEC,NX), VcollExp(NSPEC*NX), rVect(NSPEC*NX)
    REAL CoherencyError_Max, CoherencyError_Sum
    REAL eVal1, eVal2, eErr
    INTEGER LocateMax_I, LocateMax_ISP
    INTEGER rStatus(NX), Status(NX)
    INTEGER JSEA, ISEA, iProc, I, IX, ierr, ISP, IP, IP_glob
    REAL :: mval, eVal, eSum
    REAL :: TheMax, TheSum, TheNb, TheAvg
    REAL :: eFact, Threshold
    LOGICAL :: IsFirst
    INTEGER nbIncorr, n_control
    INTEGER ITH, IK
    INTEGER :: TEST_IP = 46
    INTEGER :: TEST_ISP = 370
    IF (iaproc .gt. naproc) THEN
      RETURN
    END IF
    IF (gtype .ne. ungtype) THEN
      RETURN
    END IF
    WRITE(740+iaproc,*) 'CHECK_ARRAY_INTEGRAL NSEAL=', nseal, ' npa=', npa, ' maxidx=', maxidx
    vcollexp=0
    status=0
    DO ip=1,maxidx
      ip_glob=iplg(ip)
      DO isp=1,nspec
        vcollexp(isp+nspec*(ip_glob-1)) = thearr(isp,ip)
        IF ((ip_glob .eq. test_ip).and.(isp .eq. test_isp)) THEN
          WRITE(740+iaproc,*) 'TEST_IP=', test_ip, ' TEST_ISP=', test_isp, ' val=', thearr(isp,ip)
        END IF
      END DO
      status(ip_glob)=1
    END DO
    !
    ! Now find global arrays
    !
    coherencyerror_max = 0
    coherencyerror_sum = 0
    locatemax_i = -1
    locatemax_isp = -1
 
    n_control = 0
    IF (iaproc .eq. 1) THEN
      DO iproc=2,naproc
        CALL mpi_recv(rvect  ,nspec*nx,mpi_real   , iproc-1, 37, mpi_comm_wcmp, istatus, ierr)
        CALL mpi_recv(rstatus,nx      ,mpi_integer, iproc-1, 43, mpi_comm_wcmp, istatus, ierr)
        DO i=1,nx
          IF (rstatus(i) .eq. 1) THEN
            DO isp=1,nspec
              eval1 = vcollexp(isp+nspec*(i-1))
              eval2 = rvect(isp+nspec*(i-1))
              IF (status(i) .eq. 1) THEN
                eerr=abs(eval1 - eval2)
                coherencyerror_sum = coherencyerror_sum + eerr
                IF (eerr .gt. coherencyerror_max) THEN
                  coherencyerror_max = eerr
                  locatemax_i = i
                  locatemax_isp = isp
                END IF
                IF (isp .eq. 1) THEN
                  n_control = n_control + 1
                END IF
              ELSE
                vcollexp(isp+nspec*(i-1))=eval2
              END IF
            END DO
            status(i)=1
          END IF
        END DO
      END DO
    ELSE
      CALL mpi_send(vcollexp,nspec*nx,mpi_real   , 0, 37, mpi_comm_wcmp, ierr)
      CALL mpi_send(status  ,nx      ,mpi_integer, 0, 43, mpi_comm_wcmp, ierr)
    END IF
    IF (iaproc .eq. 1) THEN
      DO i=1,nx
        DO isp=1,nspec
          vcoll(isp,i)=vcollexp(isp + nspec*(i-1))
        END DO
      END DO
      nbincorr=0
      DO ix=1,nx
        isea=mapfs(1,ix)
        IF (isea .gt. 0) THEN
          IF (status(ix) .eq. 0) THEN
            nbincorr=nbincorr+1
          END IF
        END IF
      END DO
      IF (nbincorr .gt. 0) THEN
        WRITE(*,*) '    nbIncorr=', nbincorr
        WRITE(*,*) '          NX=', nx
        WRITE(*,*) '         npa=', npa
        stop
      END IF
      WRITE(740+iaproc,*) 'CHECK_ARRAY_INTEGRAL n_control=', n_control
      WRITE(740+iaproc,*) 'ARRAY_NX sum,coh=', sum(vcoll), coherencyerror_sum, trim(string)
      WRITE(740+iaproc,*) 'ARRAY_NX max,loc=', coherencyerror_max,locatemax_i,locatemax_isp, trim(string)
      IF (printminisp) THEN
        DO isp=1,nspec
          isfirst=.true.
          esum=0
          DO ip=1,maxidx
            eval=abs(vcoll(isp, ip))
            esum=esum + eval
            IF (isfirst.eqv. .true.) then
              mval=eval
            ELSE
              IF (eval .lt. mval) THEN
                mval=eval
              ENDIF
            ENDIF
            isfirst=.false.
          END DO
          WRITE(740+iaproc,*) 'ISP=', isp, ' mval/sum=', mval, esum
        END DO
        FLUSH(740+iaproc)
      END IF
      IF (localizemaximum) THEN
        themax=0
        thenb=0
        thesum=0
        DO ip=1,maxidx
          DO isp=1,nspec
            eval = abs(vcoll(isp, ip))
            thesum = thesum + eval
            thenb = thenb + 1
            IF (eval .gt. themax) THEN
              themax=eval
            END IF
          END DO
        END DO
        theavg = thesum / thenb
        WRITE(740+iaproc,*) 'TheAvg/TheMax=', theavg, themax
        efact=0.5
        threshold=efact * themax
        DO ip=1,maxidx
          DO isp=1,nspec
            eval = abs(vcoll(isp, ip))
            IF (eval .gt. threshold) THEN
              WRITE(740+iaproc,*) 'ISP/IP/val=', isp, ip, eval
            END IF
          END DO
        END DO
        FLUSH(740+iaproc)
      END IF
    END IF
  END SUBROUTINE check_array_integral_nx_r8_maxfunct
  !/ ------------------------------------------------------------------- /
  !*    maxidx should be "np" or "npa"                                  *
  SUBROUTINE check_array_integral_nx_r8(TheARR, string, maxidx)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Source code for parallel debugging
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
 
    USE w3gdatmd, only : nspec
    USE yownodepool, only: npa
    CHARACTER(*), INTENT(in) :: string
    INTEGER, INTENT(in) :: maxidx
    REAL, INTENT(in) :: TheARR(NSPEC, npa)
    real*8 :: thearr_red(npa)
    !      LOGICAL :: FULL_NSPEC = .FALSE.
    !      LOGICAL :: PrintMinISP = .FALSE.
    !      LOGICAL :: LocalizeMaximum = .FALSE.
    !      LOGICAL :: CheckUncovered = .FALSE.
    !      LOGICAL :: PrintFullValue = .FALSE.
    LOGICAL :: FULL_NSPEC = .true.
    LOGICAL :: PrintMinISP = .true.
    LOGICAL :: LocalizeMaximum = .true.
    LOGICAL :: CheckUncovered = .true.
    LOGICAL :: PrintFullValue = .true.
    integer :: ip
 
    IF (full_nspec) THEN
      CALL check_array_integral_nx_r8_maxfunct(thearr, string, maxidx, printminisp, localizemaximum)
    ELSE
      DO ip=1,npa
        thearr_red(ip) = sum(abs(thearr(:,ip)))
      END DO
      CALL scal_integral_print_general(thearr_red, string, maxidx, checkuncovered, printfullvalue)
    END IF
  END SUBROUTINE check_array_integral_nx_r8
  !/ ------------------------------------------------------------------- /
  !/ ------------------------------------------------------------------- /
  SUBROUTINE pdlib_w3xypug_block_implicit(IMOD, FACX, FACY, DTG, VGX, VGY, LCALC )
    !/ ------------------------------------------------------------------- /
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Block Explicit N-Scheme
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE w3odatmd, only: iaproc
    USE w3gdatmd, only: b_jgs_use_jacobi
 
    LOGICAL, INTENT(IN) :: LCALC
    INTEGER, INTENT(IN) :: IMOD
    REAL, INTENT(IN)        :: FACX, FACY, DTG, VGX, VGY
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'B_JGS_USE_JACOBI=', b_jgs_use_jacobi
    FLUSH(740+iaproc)
#endif
    IF (b_jgs_use_jacobi) THEN
      CALL pdlib_jacobi_gauss_seidel_block(imod, facx, facy, dtg, vgx, vgy, lcalc)
      RETURN
    END IF
    WRITE(*,*) 'Error: You need to use with JGS_USE_JACOBI'
    stop 'Correct your implicit solver options'
    !/
    !/ End of W3XYPFSN --------------------------------------------------- /
    !/
  END SUBROUTINE pdlib_w3xypug_block_implicit
  !/ ------------------------------------------------------------------- /
  SUBROUTINE pdlib_w3xypug_block_explicit(IMOD, FACX, FACY, DTG, VGX, VGY, LCALC)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Driver for block explicit routine
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE w3odatmd, only: iaproc
    USE w3gdatmd, only: b_jgs_use_jacobi
 
    LOGICAL, INTENT(IN) :: LCALC
    INTEGER, INTENT(IN) :: IMOD
    REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY
 
    CALL pdlib_explicit_block(imod, facx, facy, dtg, vgx, vgy, lcalc)
    !/
    !/ End of W3XYPFSN ----------------------------------------------------- /
    !/
  END SUBROUTINE pdlib_w3xypug_block_explicit
  !/ --------------------------------------------------------------------- /
  SUBROUTINE print_wn_statistic(string)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Source code for parallel debugging
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
 
    USE w3odatmd, only : iaproc
    USE w3gdatmd, only: nk
    USE w3adatmd, only: wn
    USE w3gdatmd, only: nseal
    USE yownodepool, only: np
 
    CHARACTER(*), INTENT(in) :: string
    REAL TotalSumDMM, eDMM, sumDMM
    INTEGER IP, IK, ISEA
    WRITE(740+iaproc,*) 'PRINT_WN_STATISTIC'
    totalsumdmm=0
    DO isea=1,nseal
      sumdmm=0
      DO ik=0, nk
        edmm = wn(ik+1,isea) - wn(ik,isea)
        sumdmm=sumdmm + abs(edmm)
      END DO
      IF (isea .eq. 1) THEN
        WRITE(740+iaproc,*) 'ISEA=', isea
        WRITE(740+iaproc,*) 'sumDMM=', sumdmm
      END IF
      totalsumdmm = totalsumdmm + sumdmm
    END DO
    WRITE(740+iaproc,*) 'string=', string
    WRITE(740+iaproc,*) 'TotalSumDMM=', totalsumdmm
    FLUSH(740+iaproc)
    !/
    !/ End of W3XYPFSN --------------------------------------------------- /
    !/
  END SUBROUTINE print_wn_statistic
  !/ ------------------------------------------------------------------- /
  SUBROUTINE write_var_to_text_file(TheArr, eFile)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Source code for parallel debugging
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE w3gdatmd, only : nk, nth
    USE w3wdatmd, only : va
    USE w3gdatmd, only : nspec, nx, ny, nseal, mapfs
    USE w3adatmd, only : mpi_comm_wcmp
    USE w3gdatmd, only : gtype, ungtype
    USE w3odatmd, only : iaproc, naproc, ntproc
    use yowdatapool, only: rtype, istatus
    USE yownodepool, only: npa, iplg, np
    USE w3parall, only: init_get_isea
 
    include "mpif.h"
    CHARACTER(*), INTENT(in) :: eFile
    REAL, INTENT(in) :: TheARR(NSPEC, npa)
    !
    REAL Vcoll(NSPEC,NX), VcollExp(NSPEC*NX), rVect(NSPEC*NX)
    REAL CoherencyError, eVal1, eVal2, eErr
    INTEGER rStatus(NX), Status(NX)
    INTEGER JSEA, ISEA, iProc, I, IX, ierr, ISP, IP, IP_glob
    INTEGER nbIncorr
    INTEGER ITH, IK
    INTEGER fhndl
    REAL eSum
    IF (iaproc .gt. naproc) THEN
      RETURN
    END IF
    IF (gtype .ne. ungtype) THEN
      RETURN
    END IF
    vcollexp=0
    status=0
    DO ip=1,np
      ip_glob=iplg(ip)
      DO isp=1,nspec
        vcollexp(isp+nspec*(ip_glob-1))=thearr(isp,ip)
      END DO
      status(ip_glob)=1
    END DO
    !
    ! Now find global arrays
    !
    coherencyerror=0
    IF (iaproc .eq. 1) THEN
      DO iproc=2,naproc
        CALL mpi_recv(rvect  ,nspec*nx,mpi_double , iproc-1, 37, mpi_comm_wcmp, istatus, ierr)
        CALL mpi_recv(rstatus,nx      ,mpi_integer, iproc-1, 43, mpi_comm_wcmp, istatus, ierr)
        DO i=1,nx
          IF (rstatus(i) .eq. 1) THEN
            DO isp=1,nspec
              eval1=vcollexp(isp+nspec*(i-1))
              eval2=rvect(isp+nspec*(i-1))
              vcollexp(isp+nspec*(i-1))=rvect(isp+nspec*(i-1))
              IF (status(i) .eq. 1) THEN
                eerr=abs(eval1 - eval2)
                coherencyerror = coherencyerror + eerr
              ELSE
                vcollexp(isp+nspec*(i-1))=eval2
              END IF
            END DO
            status(i)=1
          END IF
        END DO
      END DO
    ELSE
      CALL mpi_send(vcollexp,nspec*nx,mpi_double , 0, 37, mpi_comm_wcmp, ierr)
      CALL mpi_send(status  ,nx      ,mpi_integer, 0, 43, mpi_comm_wcmp, ierr)
    END IF
    IF (iaproc .eq. 1) THEN
      DO i=1,nx
        DO isp=1,nspec
          vcoll(isp,i)=vcollexp(isp + nspec*(i-1))
        END DO
      END DO
      OPEN(fhndl, file=efile)
      DO ix=1,nx
        esum=sum(vcoll(:,ix))
        WRITE(fhndl,*) 'IX=', ix, 'eSum=', esum
      END DO
      CLOSE(fhndl)
    END IF
    !/
    !/ End of W3XYPFSN ----------------------------------------------------- /
    !/
  END SUBROUTINE write_var_to_text_file
  !/ ------------------------------------------------------------------- /
  SUBROUTINE printtotaloffcontrib(string)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Source code for parallel debugging
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE yownodepool,    only: pdlib_ccon, npa, pdlib_i_diag, pdlib_ja, pdlib_ia_p
    USE w3gdatmd, only: nspec
    USE w3odatmd, only : iaproc
 
    CHARACTER(*), INTENT(in) :: string
    INTEGER J, IP, JP, I, ISP
    REAL TheSum1, TheSum2
    j = 0
    thesum1=0
    DO ip = 1, npa
      DO i = 1, pdlib_ccon(ip)
        j = j + 1
        IF (j .ne. pdlib_i_diag(ip)) THEN
          DO isp=1,nspec
            thesum1=thesum1 + abs(aspar_jac(isp,j))
          END DO
        END IF
      END DO
    END DO
    !
    thesum2=0
    DO ip = 1, npa
      DO i = pdlib_ia_p(ip)+1, pdlib_ia_p(ip+1)
        jp=pdlib_ja(i)
        IF (jp .ne. ip) THEN
          DO isp=1,nspec
            thesum2=thesum2 + abs(aspar_jac(isp,i))
          END DO
        END IF
      END DO
    END DO
    WRITE(740+iaproc,'(a,f14.7,f14.7,a,a)') 'TheSum12=', thesum1, thesum2, ' ', string
    FLUSH(740+iaproc)
    !/
    !/ End of W3XYPFSN --------------------------------------------------- /
    !/
  END SUBROUTINE printtotaloffcontrib
  !/ ------------------------------------------------------------------- /
  SUBROUTINE compute_mean_param (A, CG, WN, EMEAN, FMEAN, WNMEAN, AMAX)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Compute mean prarameter
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE constants
    USE w3gdatmd, only: nk, nth, sig, dden, fte, ftf, ftwn
#ifdef W3_T
    USE w3odatmd, only: ndst
#endif
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    REAL, INTENT(IN)        :: A(NTH,NK), CG(NK), WN(NK)
    REAL, INTENT(OUT)       :: EMEAN, FMEAN, WNMEAN, AMAX
    INTEGER                 :: IK, ITH
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    REAL                    :: EB(NK), EBAND
#ifdef W3_S
    CALL strace (ient, 'W3SPR0')
#endif
    !
    emean  = 0.
    fmean  = 0.
    wnmean = 0.
    amax   = 0.
    !
    ! 1.  Integral over directions
    !
    DO ik=1, nk
      eb(ik) = 0.
      DO ith=1, nth
        eb(ik) = eb(ik) + a(ith,ik)
        amax   = max( amax , a(ith,ik) )
      END DO
    END DO
    !
    ! 2.  Integrate over directions
    !
    DO ik=1, nk
      eb(ik) = eb(ik) * dden(ik) / cg(ik)
      emean  = emean  + eb(ik)
      fmean  = fmean  + eb(ik) / sig(ik)
      wnmean = wnmean + eb(ik) / sqrt(wn(ik))
    END DO
    !
    ! 3.  Add tail beyond discrete spectrum
    !     ( DTH * SIG absorbed in FTxx )
    !
    eband  = eb(nk) / dden(nk)
    emean  = emean  + eband * fte
    fmean  = fmean  + eband * ftf
    wnmean = wnmean + eband * ftwn
    !
    ! 4.  Final processing
    !
    fmean  = tpiinv * emean / max( 1.e-7 , fmean )
    wnmean = ( emean / max( 1.e-7 , wnmean ) )**2
    !
#ifdef W3_T
    WRITE (ndst,9000) emean, fmean, wnmean
#endif
    !
    RETURN
    !
    ! Formats
    !
#ifdef W3_T
9000 FORMAT (' TEST W3SPR0 : E,F,WN MEAN ',3e10.3)
#endif
    !/
    !/ End of W3SPR0 ----------------------------------------------------- /
    !/
  END SUBROUTINE compute_mean_param
  !/ ------------------------------------------------------------------- /
  SUBROUTINE calcarray_jacobi(DTG,FACX,FACY,VGX,VGY)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Compute matrix coefficients for advection part
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE w3gdatmd, only: nk, nk2, nth, nspec, fachfa, dmin
    USE w3gdatmd, only: iobp_loc, iobpd_loc, iobpa_loc, iobdp_loc
    USE w3gdatmd, only: nseal, clats
    USE w3gdatmd, only: mapsta
    USE w3wdatmd, only: va
    USE w3adatmd, only: cg, dw, wn, cx, cy
    USE w3idatmd, only: flcur, fllev
    USE w3gdatmd, only: ecos, esin, mapfs
    USE w3parall, only : onesixth, zero, thr
    use yowelementpool, only: ne, ine
    USE yownodepool,    only: pdlib_ien, pdlib_tria,                  &
         pdlib_ccon, pdlib_pos_cell2, pdlib_ie_cell2, np, npa,          &
         pdlib_ia_p, pdlib_posi, pdlib_ia, pdlib_nnz, iplg,           &
         pdlib_i_diag, pdlib_ja
    USE w3odatmd, only : iaproc
    USE w3parall, only : zero
#ifdef W3_DB1
    USE w3sdb1md
    USE w3gdatmd, only: sdbsc
#endif
#ifdef W3_BT1
    USE w3sbt1md
#endif
#ifdef W3_BT4
    USE w3sbt4md
#endif
#ifdef W3_BT8
    USE w3sbt8md
#endif
#ifdef W3_BT9
    USE w3sbt9md
#endif
#ifdef W3_IC1
    USE w3sic1md
#endif
#ifdef W3_IC2
    USE w3sic2md
#endif
#ifdef W3_IC3
    USE w3sic3md
#endif
#ifdef W3_TR1
    USE w3str1md
#endif
    REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY
    INTEGER :: IP, ISP, ISEA, IP_glob
    INTEGER :: idx, IS
    INTEGER :: I, J, ITH, IK, J2
    INTEGER :: IE, POS, JSEA
    INTEGER :: I1, I2, I3, NI(3)
    INTEGER :: counter
#ifdef W3_REF1
    INTEGER :: eIOBPDR
#endif
    REAL :: DTK, TMP3
    REAL :: LAMBDA(2)
    REAL :: FL11, FL12
    REAL :: FL21, FL22
    REAL :: FL31, FL32
    REAL :: CRFS(3), CXY(3,2)
    REAL :: KP(3,NSPEC,NE)
    REAL :: KM(3), K(3)
    REAL :: K1, eSI, eVS, eVD
    REAL :: eVal1, eVal2, eVal3
    REAL :: DELTAL(3,NSPEC,NE)
    REAL :: NM(NSPEC,NE)
    REAL :: TRIA03, SIDT, CCOS, CSIN
    REAL :: SPEC(NSPEC), DEPTH
 
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'calcARRAY_JACOBI, begin'
    FLUSH(740+iaproc)
#endif
    memunit = 50000+iaproc
 
    i      = 0
    ie     = 0
    pos    = 0
    i1     = 0
    i2     = 0
    i3     = 0
    dtk    = 0
    tmp3   = 0
 
    call print_memcheck(memunit, 'memcheck_____:'//' WW3_JACOBI SECTION 0')
 
    DO ie = 1, ne
      i1 = ine(1,ie)
      i2 = ine(2,ie)
      i3 = ine(3,ie)
      ni = ine(:,ie)
      DO is = 1, nspec
        ith    = 1 + mod(is-1,nth)
        ik     = 1 + (is-1)/nth
        ccos   = facx * ecos(ith)
        csin   = facy * esin(ith)
        cxy(:,1) = ccos * cg(ik,ni) / clats(ni)
        cxy(:,2) = csin * cg(ik,ni)
        IF (flcur) THEN
          cxy(:,1) = cxy(:,1) + facx * cx(ni)/clats(ni)
          cxy(:,2) = cxy(:,2) + facy * cy(ni)
        ENDIF
#ifdef W3_MGP
        cxy(:,1) = cxy(:,1) - ccurx*vgx/clats(isea)
        cxy(:,2) = cxy(:,2) - ccury*vgy
#endif
        fl11 = cxy(2,1)*pdlib_ien(1,ie)+cxy(2,2)*pdlib_ien(2,ie)
        fl12 = cxy(3,1)*pdlib_ien(1,ie)+cxy(3,2)*pdlib_ien(2,ie)
        fl21 = cxy(3,1)*pdlib_ien(3,ie)+cxy(3,2)*pdlib_ien(4,ie)
        fl22 = cxy(1,1)*pdlib_ien(3,ie)+cxy(1,2)*pdlib_ien(4,ie)
        fl31 = cxy(1,1)*pdlib_ien(5,ie)+cxy(1,2)*pdlib_ien(6,ie)
        fl32 = cxy(2,1)*pdlib_ien(5,ie)+cxy(2,2)*pdlib_ien(6,ie)
        crfs(1) = - onesixth *  (2.0d0 *fl31 + fl32 + fl21 + 2.0d0 * fl22 )
        crfs(2) = - onesixth *  (2.0d0 *fl32 + 2.0d0 * fl11 + fl12 + fl31 )
        crfs(3) = - onesixth *  (2.0d0 *fl12 + 2.0d0 * fl21 + fl22 + fl11 )
        lambda(1) = onesixth * sum(cxy(:,1))
        lambda(2) = onesixth * sum(cxy(:,2))
        k(1)  = lambda(1) * pdlib_ien(1,ie) + lambda(2) * pdlib_ien(2,ie)
        k(2)  = lambda(1) * pdlib_ien(3,ie) + lambda(2) * pdlib_ien(4,ie)
        k(3)  = lambda(1) * pdlib_ien(5,ie) + lambda(2) * pdlib_ien(6,ie)
        kp(:,is,ie) = max(zero,k(:))
        deltal(:,is,ie) = crfs(:) - kp(:,is,ie)
        km(:) = min(zero,k(:))
        nm(is,ie) = 1.d0/min(-thr,sum(km))
      ENDDO
    END DO
 
    j = 0
    DO ip = 1, npa
      ip_glob=iplg(ip)
      DO i = 1, pdlib_ccon(ip)
        j = j + 1
        ie    =  pdlib_ie_cell2(i,ip)
        pos   =  pdlib_pos_cell2(i,ip)
        i1    =  pdlib_posi(1,j)
        i2    =  pdlib_posi(2,j)
        i3    =  pdlib_posi(3,j)
#ifdef W3_DEBUGSRC
        WRITE(740+iaproc,*) 'I1=', i1, ' PDLIB_I_DIAG=', pdlib_i_diag(ip)
#endif
        DO isp=1,nspec
          ith    = 1 + mod(isp-1,nth)
          ik     = 1 + (isp-1)/nth
          k1    =  kp(pos,isp,ie)
#ifdef W3_REF1
          eiobpdr=(1-iobp_loc(ip_glob))*(1-iobpd_loc(ith,ip_glob))
          IF (eiobpdr .eq. 1) THEN
            k1=zero
          END IF
#endif
          tria03        =  1./3. * pdlib_tria(ie)
          dtk           =  k1 * dtg * iobdp_loc(ip) * (1-iobpa_loc(ip)) * iobpd_loc(ith,ip)
          b_jac(isp,ip) =  b_jac(isp,ip) + tria03 * va(isp,ip) * iobdp_loc(ip) * (1-iobpa_loc(ip)) * iobpd_loc(ith,ip)
          tmp3          =  dtk * nm(isp,ie)
          IF (fsgeoadvect) THEN
            aspar_jac(isp,i1) = aspar_jac(isp,i1) + tria03 + dtk - tmp3*deltal(pos,isp,ie)
            aspar_jac(isp,i2) = aspar_jac(isp,i2)                - tmp3*deltal(pos_trick(pos,1),isp,ie)
            aspar_jac(isp,i3) = aspar_jac(isp,i3)                - tmp3*deltal(pos_trick(pos,2),isp,ie)
          ELSE
            aspar_jac(isp,i1) = aspar_jac(isp,i1) + tria03
          END IF
        END DO
      END DO
    END DO
    call print_memcheck(memunit, 'memcheck_____:'//' WW3_JACOBI SECTION 1')
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'sum(VA)=', sum(va)
    CALL printtotaloffcontrib("Offdiag after the geo advection")
#endif
    !/
    !/ End of W3XYPFSN ----------------------------------------------------- /
    !/
  END SUBROUTINE calcarray_jacobi
  !/ ------------------------------------------------------------------- /
  SUBROUTINE calcarray_jacobi_vec(DTG,FACX,FACY,VGX,VGY)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Compute matrix coefficients for advection part
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE w3gdatmd, only: nk, nk2, nth, nspec, fachfa, dmin
    USE w3gdatmd, only: iobp_loc, iobpd_loc, iobpa_loc, iobdp_loc
    USE w3gdatmd, only: nseal, clats
    USE w3gdatmd, only: mapsta, sig
    USE w3wdatmd, only: va
    USE w3adatmd, only: cg, dw, wn, cx, cy
    USE w3idatmd, only: flcur, fllev
    USE w3gdatmd, only: ecos, esin, mapfs
    USE w3parall, only : onesixth, zero, thr
    use yowelementpool, only: ne, ine
    USE yownodepool,    only: pdlib_ien, pdlib_tria,                  &
         pdlib_ie_cell2, pdlib_pos_cell2, pdlib_ccon, np, npa,          &
         pdlib_ia_p, pdlib_posi, pdlib_ia, pdlib_nnz, iplg,           &
         pdlib_i_diag, pdlib_ja, pdlib_tria03, pdlib_si
    USE w3odatmd, only : iaproc
    USE w3parall, only : zero
    USE w3dispmd, only : wavnu_local
#ifdef W3_DB1
    USE w3sdb1md
    USE w3gdatmd, only: sdbsc
#endif
#ifdef W3_BT1
    USE w3sbt1md
#endif
#ifdef W3_BT4
    USE w3sbt4md
#endif
#ifdef W3_BT8
    USE w3sbt8md
#endif
#ifdef W3_BT9
    USE w3sbt9md
#endif
#ifdef W3_IC1
    USE w3sic1md
#endif
#ifdef W3_IC2
    USE w3sic2md
#endif
#ifdef W3_IC3
    USE w3sic3md
#endif
#ifdef W3_TR1
    USE w3str1md
#endif
    REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY
    INTEGER :: IP, ISP, ISEA, IP_glob
    INTEGER :: idx, IS
    INTEGER :: I, J, ITH, IK, J2
    INTEGER :: IE, POS, JSEA
    INTEGER :: I1, I2, I3, NI(3)
    INTEGER :: counter, IB1, IB2, IBR
    REAL    :: DTK, TMP3
    REAL    :: LAMBDA(2), CXYY(2,3), CXY(2,NPA)
    REAL    :: FL11, FL12
    REAL    :: FL21, FL22
    REAL    :: FL31, FL32
    REAL    :: CRFS(3), K(3)
    REAL    :: KP(3,NE)
    REAL    :: KM(3), DELTAL(3,NE)
    REAL    :: K1, eSI, eVS, eVD
    REAL    :: eVal1, eVal2, eVal3
    REAL    :: CG1, WN1
    REAL    :: TRIA03, SIDT, CCOS, CSIN
    REAL    :: SPEC(NSPEC), DEPTH, CCOSA(NTH), CSINA(NTH)
    INTEGER :: IOBPTH1(NTH), IOBPTH2(NTH)
 
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'calcARRAY_JACOBI, begin'
    FLUSH(740+iaproc)
#endif
    memunit = 50000+iaproc
 
    i      = 0
    ie     = 0
    pos    = 0
    i1     = 0
    i2     = 0
    i3     = 0
    dtk    = 0
    tmp3   = 0
 
    ccosa = facx * ecos(1:nth)
    csina = facx * esin(1:nth)
    call print_memcheck(memunit, 'memcheck_____:'//' WW3_JACOBI SECTION 0')
 
    DO isp = 1, nspec
 
      ith    = 1 + mod(isp-1,nth)
      ik     = 1 + (isp-1)/nth
      ccos   = ccosa(ith)
      csin   = csina(ith)
 
      DO ip = 1, npa
 
        ip_glob = iplg(ip)
#ifdef NOCGTABLE
        CALL wavnu_local(sig(ik),dw(ip_glob),wn1,cg1)
#else
        cg1    = cg(ik,ip_glob)
#endif
        cxy(1,ip) = ccos * cg1/clats(ip_glob)
        cxy(2,ip) = csin * cg1
        IF (flcur) THEN
          cxy(1,ip) = cxy(1,ip) + facx * cx(ip_glob)/clats(ip_glob)*iobdp_loc(ip)
          cxy(2,ip) = cxy(2,ip) + facy * cy(ip_glob)*iobdp_loc(ip)
        ENDIF
#ifdef W3_MGP
        cxy(1,ip) = cxy(1,ip) - ccurx*vgx/clats(isea)
        cxy(2,ip) = cxy(2,ip) - ccury*vgy
#endif
      ENDDO
 
      DO ie = 1, ne
        ni = ine(:,ie)
        cxyy(1,:) = cxy(1,ni)
        cxyy(2,:) = cxy(2,ni)
        fl11 = cxyy(1,2)*pdlib_ien(1,ie)+cxyy(2,2)*pdlib_ien(2,ie)
        fl12 = cxyy(1,3)*pdlib_ien(1,ie)+cxyy(2,3)*pdlib_ien(2,ie)
        fl21 = cxyy(1,3)*pdlib_ien(3,ie)+cxyy(2,3)*pdlib_ien(4,ie)
        fl22 = cxyy(1,1)*pdlib_ien(3,ie)+cxyy(2,1)*pdlib_ien(4,ie)
        fl31 = cxyy(1,1)*pdlib_ien(5,ie)+cxyy(2,1)*pdlib_ien(6,ie)
        fl32 = cxyy(1,2)*pdlib_ien(5,ie)+cxyy(2,2)*pdlib_ien(6,ie)
        crfs(1) = - onesixth *  (2.0d0 *fl31 + fl32 + fl21 + 2.0d0 * fl22 )
        crfs(2) = - onesixth *  (2.0d0 *fl32 + 2.0d0 * fl11 + fl12 + fl31 )
        crfs(3) = - onesixth *  (2.0d0 *fl12 + 2.0d0 * fl21 + fl22 + fl11 )
        lambda(1) = onesixth * sum(cxyy(1,:))
        lambda(2) = onesixth * sum(cxyy(2,:))
        k(1)  = lambda(1) * pdlib_ien(1,ie) + lambda(2) * pdlib_ien(2,ie)
        k(2)  = lambda(1) * pdlib_ien(3,ie) + lambda(2) * pdlib_ien(4,ie)
        k(3)  = lambda(1) * pdlib_ien(5,ie) + lambda(2) * pdlib_ien(6,ie)
        kp(1:3,ie) = max(zero,k(1:3))
        deltal(1:3,ie) = (crfs(1:3) - kp(1:3,ie)) * 1.d0/min(-thr,sum(min(zero,k(1:3))))
      ENDDO
 
      j = 0
      DO ip = 1, np
        ib1 = (1-iobpa_loc(ip)) * iobpd_loc(ith,ip)
        ib2 = iobpd_loc(ith,ip)
#ifdef W3_REF1
        ibr = (1-iobp_loc(ip)) * (1-iobpd_loc(ith,ip)) * (1-iobpa_loc(ip))
#endif
        IF (iobdp_loc(ip) .eq. 1) THEN
          DO i = 1, pdlib_ccon(ip)
            j     =  j + 1
            ie    =  pdlib_ie_cell2(i,ip)
            pos   =  pdlib_pos_cell2(i,ip)
#ifdef W3_DEBUGSRC
            WRITE(740+iaproc,*) 'I1=', i1, ' PDLIB_I_DIAG=', pdlib_i_diag(ip)
#endif
 
#ifdef W3_REF1
            IF (ibr == 1) THEN
              dtk               = kp(pos,ie) * dtg
              b_jac(isp,ip)     = b_jac(isp,ip) + pdlib_tria03(ie) * va(isp,ip)
            ELSE
              dtk               = kp(pos,ie) * dtg * ib1
              b_jac(isp,ip)     = b_jac(isp,ip) + pdlib_tria03(ie) * va(isp,ip) * ib2
            ENDIF
#else
            dtk               = kp(pos,ie) * dtg * ib1
            b_jac(isp,ip)     = b_jac(isp,ip) + pdlib_tria03(ie) * va(isp,ip) * ib2
#endif
 
            i1  =  pdlib_posi(1,j)
            i2  =  pdlib_posi(2,j)
            i3  =  pdlib_posi(3,j)
            IF (fsgeoadvect) THEN
              aspar_jac(isp,i1) = aspar_jac(isp,i1) + pdlib_tria03(ie) + dtk - dtk * deltal(pos,ie)
              aspar_jac(isp,i2) = aspar_jac(isp,i2)                          - dtk * deltal(pos_trick(pos,1),ie)
              aspar_jac(isp,i3) = aspar_jac(isp,i3)                          - dtk * deltal(pos_trick(pos,2),ie)
            ELSE
              aspar_jac(isp,i1) = aspar_jac(isp,i1) + pdlib_tria03(ie)
            ENDIF
          END DO
        ELSE
          DO i = 1, pdlib_ccon(ip)
            j = j + 1
            i1                =  pdlib_posi(1,j)
            ie                =  pdlib_ie_cell2(i,ip)
            aspar_jac(isp,i1) = aspar_jac(isp,i1) + pdlib_tria03(ie)
          END DO
          b_jac(isp,ip) = 0.
        ENDIF
      END DO
    END DO ! ISP
 
    call print_memcheck(memunit, 'memcheck_____:'//' WW3_JACOBI SECTION 1')
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'sum(VA)=', sum(va)
    CALL printtotaloffcontrib("Offdiag after the geo advection")
#endif
    !/
    !/ End of W3XYPFSN ----------------------------------------------------- /
    !/
  END SUBROUTINE calcarray_jacobi_vec
  !/ ------------------------------------------------------------------- /
  SUBROUTINE calcarray_jacobi2(DTG,FACX,FACY,VGX,VGY)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Compute matrix coefficients for advection part
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
 
    USE w3gdatmd, only: nk, nk2, nth, nspec, fachfa, dmin
    USE w3gdatmd, only: iobp_loc, iobpd_loc, iobpa_loc, iobdp_loc
    USE w3gdatmd, only: nseal, clats
    USE w3gdatmd, only: mapsta
    USE w3wdatmd, only: va, vaold
    USE w3adatmd, only: cg, dw, wn, cx, cy
    USE w3idatmd, only: flcur, fllev
    USE w3gdatmd, only: ecos, esin, mapfs
    USE w3parall, only : onesixth, zero, thr, imem
    use yowelementpool, only: ne, ine
    USE yownodepool,    only: pdlib_ien, pdlib_tria,                  &
         pdlib_ccon, pdlib_pos_cell2, pdlib_ie_cell2, np, npa,        &
         pdlib_ia_p, pdlib_posi, pdlib_ia, pdlib_nnz, iplg,           &
         pdlib_i_diag, pdlib_ja
    USE w3odatmd, only : iaproc
#ifdef W3_DB1
    USE w3sdb1md
    USE w3gdatmd, only: sdbsc
#endif
#ifdef W3_BT1
    USE w3sbt1md
#endif
#ifdef W3_BT4
    USE w3sbt4md
#endif
#ifdef W3_BT8
    USE w3sbt8md
#endif
#ifdef W3_BT9
    USE w3sbt9md
#endif
#ifdef W3_IC1
    USE w3sic1md
#endif
#ifdef W3_IC2
    USE w3sic2md
#endif
#ifdef W3_IC3
    USE w3sic3md
#endif
#ifdef W3_TR1
    USE w3str1md
#endif
    REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY
    INTEGER :: IP, ISP, ISEA, IP_glob
    INTEGER :: idx, IS
    INTEGER :: I, J, ITH, IK, J2
    INTEGER :: IE, POS, JSEA
    INTEGER :: I1, I2, I3, NI(3), NI_GLOB(3), NI_ISEA(3)
    INTEGER :: counter
#ifdef W3_REF1
    INTEGER :: eIOBPDR
#endif
    INTEGER :: IP1, IP2, IPP1, IPP2
    REAL  :: DTK, TMP3
    REAL  :: LAMBDA(2)
    REAL  :: FL11, FL12
    REAL  :: FL21, FL22
    REAL  :: FL31, FL32
    REAL  :: CRFS(3), K(3)
    REAL  :: KP(3)
    REAL  :: KM(3), CXY(3,2)
    REAL  :: K1, eSI, eVS, eVD
    REAL  :: eVal1, eVal2, eVal3
    REAL  :: DELTAL(3)
    REAL  :: NM, TRIA03, SIDT
    REAL  :: IEN_LOCAL(6), CG2(NK,NTH)
    REAL  :: CCOS, CSIN
    REAL  :: SPEC(NSPEC), DEPTH
 
    memunit = 50000+iaproc
 
    call print_memcheck(memunit, 'memcheck_____:'//' WW3_JACOBI SECTION 0')
 
    j = 0
    DO ip = 1, npa
      ip_glob=iplg(ip)
      isea=mapfs(1,ip_glob)
      DO i = 1, pdlib_ccon(ip)
        j = j + 1
        ie    =  pdlib_ie_cell2(i,ip)
        ien_local = pdlib_ien(:,ie)
        pos   =  pdlib_pos_cell2(i,ip)
        i1    =  pdlib_posi(1,j)
        i2    =  pdlib_posi(2,j)
        i3    =  pdlib_posi(3,j)
        ip1   =  ine(pos_trick(pos,1),ie)
        ip2   =  ine(pos_trick(pos,2),ie)
        ipp1  =  pos_trick(pos,1)
        ipp2  =  pos_trick(pos,2)
        ni    = ine(:,ie)
        ni_glob = iplg(ni)
        ni_isea = mapfs(1,ni_glob)
        DO isp=1,nspec
          ith    = 1 + mod(isp-1,nth)
          ik     = 1 + (isp-1)/nth
          ccos   = facx * ecos(ith)
          csin   = facy * esin(ith)
          cxy(:,1) = ccos * cg(ik,ni_isea) / clats(ni_isea)
          cxy(:,2) = csin * cg(ik,ni_isea)
          IF (flcur) THEN
            cxy(:,1) = cxy(:,1) + facx * cx(ni_isea)/clats(ni_isea)
            cxy(:,2) = cxy(:,2) + facy * cy(ni_isea)
          ENDIF
#ifdef W3_MGP
          cxy(:,1) = cxy(:,1) - ccurx*vgx/clats(isea)
          cxy(:,2) = cxy(:,2) - ccury*vgy
#endif
          fl11 = cxy(2,1)*ien_local(1)+cxy(2,2)*ien_local(2)
          fl12 = cxy(3,1)*ien_local(1)+cxy(3,2)*ien_local(2)
          fl21 = cxy(3,1)*ien_local(3)+cxy(3,2)*ien_local(4)
          fl22 = cxy(1,1)*ien_local(3)+cxy(1,2)*ien_local(4)
          fl31 = cxy(1,1)*ien_local(5)+cxy(1,2)*ien_local(6)
          fl32 = cxy(2,1)*ien_local(5)+cxy(2,2)*ien_local(6)
          crfs(1) = - onesixth *  (2.0d0 *fl31 + fl32 + fl21 + 2.0d0 * fl22 )
          crfs(2) = - onesixth *  (2.0d0 *fl32 + 2.0d0 * fl11 + fl12 + fl31 )
          crfs(3) = - onesixth *  (2.0d0 *fl12 + 2.0d0 * fl21 + fl22 + fl11 )
          lambda(1) = onesixth * sum(cxy(:,1))
          lambda(2) = onesixth * sum(cxy(:,2))
          k(1)  = lambda(1) * ien_local(1) + lambda(2) * ien_local(2)
          k(2)  = lambda(1) * ien_local(3) + lambda(2) * ien_local(4)
          k(3)  = lambda(1) * ien_local(5) + lambda(2) * ien_local(6)
          kp(:) = max(zero,k(:))
          deltal(:) = crfs(:) - kp(:)
          km(:) = min(zero,k(:))
          nm = 1.d0/min(-thr,sum(km))
          k1 =  kp(pos)
#ifdef W3_REF1
          eiobpdr=(1-iobp_loc(ip))*(1-iobpd_loc(ith,ip))
          IF (eiobpdr .eq. 1) THEN
            k1=zero
          END IF
#endif
          tria03 = 1./3. * pdlib_tria(ie)
          dtk    =  k1 * dtg * iobdp_loc(ip) * iobpd_loc(ith,ip) * (1-iobpa_loc(ip))
          tmp3   =  dtk * nm
          IF (fsgeoadvect) THEN
            aspar_jac(isp,i1) = aspar_jac(isp,i1) + tria03 + dtk - tmp3*deltal(pos)
            aspar_jac(isp,i2) = aspar_jac(isp,i2)                - tmp3*deltal(ipp1)
            aspar_jac(isp,i3) = aspar_jac(isp,i3)                - tmp3*deltal(ipp2)
          ELSE
            aspar_jac(isp,i1) = aspar_jac(isp,i1) + tria03
          END IF
          b_jac(isp,ip) = b_jac(isp,ip) + tria03 * va(isp,ip) * iobdp_loc(ip) * iobpd_loc(ith,ip)
        END DO
      END DO
    END DO
    call print_memcheck(memunit, 'memcheck_____:'//' WW3_JACOBI SECTION 1')
    !/
    !/ End of W3XYPFSN ----------------------------------------------------- /
    !/
  END SUBROUTINE calcarray_jacobi2
  !/ ------------------------------------------------------------------- /
  SUBROUTINE calcarray_jacobi3(IP,J,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_OFF_DIAG_LOCAL,B_JAC_LOCAL)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Compute matrix coefficients for advection part
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE w3gdatmd, only: nk, nk2, nth, nspec, fachfa, dmin
    USE w3gdatmd, only: iobp_loc, iobpd_loc, iobpa_loc, iobdp_loc
    USE w3gdatmd, only: nseal, clats
    USE w3gdatmd, only: mapsta
    USE w3wdatmd, only: va, vaold
    USE w3adatmd, only: cg, dw, wn, cx, cy
    USE w3idatmd, only: flcur, fllev
    USE w3gdatmd, only: ecos, esin, mapfs
    USE w3parall, only : onesixth, zero, thr, onethird
    use yowelementpool, only: ne, ine
    USE yownodepool,    only: pdlib_ien, pdlib_tria,                  &
         pdlib_ccon, np, npa, pdlib_pos_cell2, pdlib_ie_cell2,        &
         pdlib_ia_p, pdlib_posi, pdlib_ia, pdlib_nnz, iplg,           &
         pdlib_i_diag, pdlib_ja
    USE w3gdatmd, only: iobp
    USE w3odatmd, only : iaproc
#ifdef W3_DB1
    USE w3sdb1md
    USE w3gdatmd, only: sdbsc
#endif
#ifdef W3_BT1
    USE w3sbt1md
#endif
#ifdef W3_BT4
    USE w3sbt4md
#endif
#ifdef W3_BT8
    USE w3sbt8md
#endif
#ifdef W3_BT9
    USE w3sbt9md
#endif
#ifdef W3_IC1
    USE w3sic1md
#endif
#ifdef W3_IC2
    USE w3sic2md
#endif
#ifdef W3_IC3
    USE w3sic3md
#endif
#ifdef W3_TR1
    USE w3str1md
#endif
    INTEGER, INTENT(IN) :: IP
    INTEGER, INTENT(INOUT) :: J
    REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY
    REAL, INTENT(out) :: ASPAR_DIAG_LOCAL(NSPEC), B_JAC_LOCAL(NSPEC), ASPAR_OFF_DIAG_LOCAL(NSPEC)
    INTEGER :: ISP, ISEA, IP_glob, IPP1, IPP2
    INTEGER :: idx, IS, IP1, IP2
    INTEGER :: I, ITH, IK, J2
    INTEGER :: IE, POS, JSEA
    INTEGER :: I1, I2, I3, NI(3), NI_GLOB(3), NI_ISEA(3)
    INTEGER :: counter
#ifdef W3_REF1
    INTEGER :: eIOBPDR
#endif
    REAL :: DTK, TMP3
    REAL :: LAMBDA(2)
    REAL :: FL11, FL12
    REAL :: FL21, FL22
    REAL :: FL31, FL32
    REAL :: CRFS(3), K(3)
    REAL :: KP(3)
    REAL :: KM(3), CXY(3,2)
    REAL :: K1, eSI, eVS, eVD
    REAL :: eVal1, eVal2, eVal3
    REAL :: ien_local(6)
    REAL :: DELTAL(3)
    REAL :: NM
    REAL :: TRIA03, SIDT, CCOS, CSIN
    REAL :: DEPTH
 
    aspar_diag_local     = 0.d0
    b_jac_local          = 0.d0
    aspar_off_diag_local = 0.d0
 
    ip_glob=iplg(ip)
    DO i = 1, pdlib_ccon(ip)
      j         = j + 1
      ie    =  pdlib_ie_cell2(i,ip)
      ien_local = pdlib_ien(:,ie)
      pos   =  pdlib_pos_cell2(i,ip)
      i1    =  pdlib_posi(1,j)
      i2    =  pdlib_posi(2,j)
      i3    =  pdlib_posi(3,j)
      ip1   =  ine(pos_trick(pos,1),ie)
      ip2   =  ine(pos_trick(pos,2),ie)
      ipp1  =  pos_trick(pos,1)
      ipp2  =  pos_trick(pos,2)
      ni    =  ine(:,ie)
      ni_glob = iplg(ni)
      ni_isea = mapfs(1,ni_glob)
 
      DO isp=1,nspec
        ith    = 1 + mod(isp-1,nth)
        ik     = 1 + (isp-1)/nth
        ccos   = facx * ecos(ith)
        csin   = facy * esin(ith)
        cxy(:,1) = ccos * cg(ik,ni_isea) / clats(ni_isea)
        cxy(:,2) = csin * cg(ik,ni_isea)
        IF (flcur) THEN
          cxy(:,1) = cxy(:,1) + facx * cx(ni_isea)/clats(ni_isea)
          cxy(:,2) = cxy(:,2) + facy * cy(ni_isea)
        ENDIF
 
#ifdef W3_MGP
        cxy(:,1) = cxy(:,1) - ccurx*vgx/clats(isea)
        cxy(:,2) = cxy(:,2) - ccury*vgy
#endif
        fl11 = cxy(2,1)*ien_local(1)+cxy(2,2)*ien_local(2)
        fl12 = cxy(3,1)*ien_local(1)+cxy(3,2)*ien_local(2)
        fl21 = cxy(3,1)*ien_local(3)+cxy(3,2)*ien_local(4)
        fl22 = cxy(1,1)*ien_local(3)+cxy(1,2)*ien_local(4)
        fl31 = cxy(1,1)*ien_local(5)+cxy(1,2)*ien_local(6)
        fl32 = cxy(2,1)*ien_local(5)+cxy(2,2)*ien_local(6)
        crfs(1) = - onesixth * (2.0d0 *fl31 + fl32 + fl21 + 2.0d0 * fl22 )
        crfs(2) = - onesixth * (2.0d0 *fl32 + 2.0d0 * fl11 + fl12 + fl31 )
        crfs(3) = - onesixth * (2.0d0 *fl12 + 2.0d0 * fl21 + fl22 + fl11 )
        lambda(1) = onesixth * sum(cxy(:,1))
        lambda(2) = onesixth * sum(cxy(:,2))
        k(1)  = lambda(1) * ien_local(1) + lambda(2) * ien_local(2)
        k(2)  = lambda(1) * ien_local(3) + lambda(2) * ien_local(4)
        k(3)  = lambda(1) * ien_local(5) + lambda(2) * ien_local(6)
        kp(:) = max(zero,k(:))
        deltal(:) = crfs(:) - kp(:)
        km(:) = min(zero,k(:))
        nm = 1.d0/min(-thr,sum(km))
#ifdef W3_REF1
        eiobpdr=(1-iobp_loc(ip))*(1-iobpd_loc(ith,ip))
        IF (eiobpdr .eq. 1) THEN
          k1=zero
        END IF
#endif
        tria03 = onethird * pdlib_tria(ie)
        dtk    =  kp(pos) * dble(dtg) * iobdp_loc(ip) * iobpd_loc(ith,ip) * (1-iobpa_loc(ip))
        tmp3   =  dtk * nm
        IF (fsgeoadvect) THEN
          aspar_diag_local(isp)     = aspar_diag_local(isp)    + tria03 + dtk   - tmp3*deltal(pos)
          aspar_off_diag_local(isp) = aspar_off_diag_local(isp)                 - tmp3*deltal(ipp1)*va(isp,ip1)
          aspar_off_diag_local(isp) = aspar_off_diag_local(isp)                 - tmp3*deltal(ipp2)*va(isp,ip2)
        ELSE
          aspar_diag_local(isp) = aspar_diag_local(isp) + tria03
        END IF
        b_jac_local(isp) = b_jac_local(isp) + tria03 * vaold(isp,ip) * iobdp_loc(ip) * iobpd_loc(ith,ip)
      END DO
    END DO
    !/
    !/ End of W3XYPFSN --------------------------------------------------- /
    !/
  END SUBROUTINE calcarray_jacobi3
  !/ ------------------------------------------------------------------- /
  SUBROUTINE calcarray_jacobi4(IP,DTG,FACX,FACY,VGX,VGY,ASPAR_DIAG_LOCAL,ASPAR_OFF_DIAG_LOCAL,B_JAC_LOCAL)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Compute matrix coefficients for advection part
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE w3gdatmd, only: nk, nk2, nth, nspec, fachfa, dmin
    USE w3gdatmd, only: iobp_loc, iobpd_loc, iobpa_loc, iobdp_loc
    USE w3gdatmd, only: nseal,clats
    USE w3gdatmd, only: mapsta, nk
    USE w3wdatmd, only: va, vaold
    USE w3adatmd, only: cg, dw, wn, cx, cy
    USE w3idatmd, only: flcur, fllev
    USE w3gdatmd, only: ecos, esin, mapfs
    USE w3parall, only : onesixth, zero, thr, onethird
    use yowelementpool, only: ne, ine
    USE yownodepool,    only: pdlib_ien, pdlib_tria,                  &
         pdlib_ie_cell2, pdlib_pos_cell2, pdlib_ccon, np, npa,          &
         pdlib_ia_p, pdlib_posi, pdlib_ia, pdlib_nnz, iplg,           &
         pdlib_i_diag, pdlib_ja
    USE w3odatmd, only : iaproc
#ifdef W3_DB1
    USE w3sdb1md
    USE w3gdatmd, only: sdbsc
#endif
#ifdef W3_BT1
    USE w3sbt1md
#endif
#ifdef W3_BT4
    USE w3sbt4md
#endif
#ifdef W3_BT8
    USE w3sbt8md
#endif
#ifdef W3_BT9
    USE w3sbt9md
#endif
#ifdef W3_IC1
    USE w3sic1md
#endif
#ifdef W3_IC2
    USE w3sic2md
#endif
#ifdef W3_IC3
    USE w3sic3md
#endif
#ifdef W3_TR1
    USE w3str1md
#endif
    INTEGER, INTENT(IN) :: IP
    REAL, INTENT(in) :: DTG, FACX, FACY, VGX, VGY
    REAL, INTENT(out) :: ASPAR_DIAG_LOCAL(NSPEC), B_JAC_LOCAL(NSPEC), ASPAR_OFF_DIAG_LOCAL(NSPEC)
    !
    INTEGER :: IP1, IP2
    INTEGER :: ITH, IK
    INTEGER :: IE, POS, JSEA
    INTEGER :: I, I1, I2, I3, NI(3), NI_GLOB(3), NI_ISEA(3)
    INTEGER :: ISP, IP_glob, IPP1, IPP2, IOBPTH1(NTH), IOBPTH2(NTH)
    INTEGER :: counter
#ifdef W3_REF1
    INTEGER :: eIOBPDR
#endif
    REAL  :: DTK, TMP3, D1, D2
    REAL  :: LAMBDA(2)
    REAL  :: CRFS(3), K(3)
    REAL  :: KP(3), UV_CUR(3,2)
    REAL  :: KM(3), CSX(3), CSY(3)
    REAL  :: K1, eSI, eVS, eVD
    REAL  :: eVal1, eVal2, eVal3
    REAL  :: ien_local(6)
    REAL  :: DELTAL(3), K_X(3,NK), K_Y(3,NK), K_U(3)
    REAL  :: CRFS_X(3,NK), CRFS_Y(3,NK), CRFS_U(3)
    REAL  :: NM, CGFAK(3,NK), CSINA(NTH), CCOSA(NTH)
    REAL  :: TRIA03, SIDT, CCOS, CSIN
    REAL  :: FL11_X, FL12_X, FL21_X, FL22_X, FL31_X, FL32_X
    REAL  :: FL11_Y, FL12_Y, FL21_Y, FL22_Y, FL31_Y, FL32_Y
    REAL  :: FL11_U, FL12_U, FL21_U, FL22_U, FL31_U, FL32_U
 
    ip_glob              = iplg(ip)
    aspar_diag_local     = zero
    b_jac_local          = zero
    aspar_off_diag_local = zero
 
    DO ith = 1, nth
      ccosa(ith) = facx * ecos(ith)
      csina(ith) = facx * esin(ith)
      iobpth1(ith) = iobdp_loc(ip) * (1-iobpa_loc(ip)) * iobpd_loc(ith,ip)
      iobpth2(ith) = iobdp_loc(ip) * iobpd_loc(ith,ip)
    ENDDO
 
    DO i = 1, pdlib_ccon(ip)
 
      ie        = pdlib_ie_cell2(i,ip)
      tria03    = onethird * pdlib_tria(ie)
      ien_local = pdlib_ien(1:6,ie)
      pos       = pdlib_pos_cell2(i,ip)
      ip1       = ine(pos_trick(pos,1),ie)
      ip2       = ine(pos_trick(pos,2),ie)
      ipp1      = pos_trick(pos,1)
      ipp2      = pos_trick(pos,2)
      ni        = ine(1:3,ie)
      ni_glob   = iplg(ni)
      ni_isea   = mapfs(1,ni_glob)
      crfs_u    = zero
 
      IF (flcur) THEN
 
        uv_cur(1:3,1) = facx * cx(ni_isea) / clats(ni_isea)
        uv_cur(1:3,2) = facy * cy(ni_isea)
 
        lambda(1) = onesixth*(uv_cur(1,1)+uv_cur(2,1)+uv_cur(3,1))
        lambda(2) = onesixth*(uv_cur(1,2)+uv_cur(2,2)+uv_cur(3,2))
 
        k_u(1)  = lambda(1) * ien_local(1) + lambda(2) * ien_local(2)
        k_u(2)  = lambda(1) * ien_local(3) + lambda(2) * ien_local(4)
        k_u(3)  = lambda(1) * ien_local(5) + lambda(2) * ien_local(6)
 
        fl11_u  = uv_cur(2,1)*ien_local(1)+uv_cur(2,2)*ien_local(2)
        fl12_u  = uv_cur(3,1)*ien_local(1)+uv_cur(3,2)*ien_local(2)
        fl21_u  = uv_cur(3,1)*ien_local(3)+uv_cur(3,2)*ien_local(4)
        fl22_u  = uv_cur(1,1)*ien_local(3)+uv_cur(1,2)*ien_local(4)
        fl31_u  = uv_cur(1,1)*ien_local(5)+uv_cur(1,2)*ien_local(6)
        fl32_u  = uv_cur(2,1)*ien_local(5)+uv_cur(2,2)*ien_local(6)
 
        crfs_u(1) = - onesixth*(2.d0 *fl31_u + fl32_u + fl21_u + 2.d0 * fl22_u)
        crfs_u(2) = - onesixth*(2.d0 *fl32_u + 2.d0 * fl11_u + fl12_u + fl31_u)
        crfs_u(3) = - onesixth*(2.d0 *fl12_u + 2.d0 * fl21_u + fl22_u + fl11_u)
 
      ENDIF
 
      DO ik = 1, nk
        csx = cg(ik,ni_isea) / clats(ni_isea)
        csy = cg(ik,ni_isea)
        lambda(1) = onesixth * (csx(1) + csx(2) + csx(3))
        lambda(2) = onesixth * (csy(1) + csy(2) + csy(3))
        k_x(1,ik) = lambda(1) * ien_local(1)
        k_x(2,ik) = lambda(1) * ien_local(3)
        k_x(3,ik) = lambda(1) * ien_local(5)
        k_y(1,ik) = lambda(2) * ien_local(2)
        k_y(2,ik) = lambda(2) * ien_local(4)
        k_y(3,ik) = lambda(2) * ien_local(6)
        fl11_x = csx(2) * ien_local(1)
        fl12_x = csx(3) * ien_local(1)
        fl21_x = csx(3) * ien_local(3)
        fl22_x = csx(1) * ien_local(3)
        fl31_x = csx(1) * ien_local(5)
        fl32_x = csx(2) * ien_local(5)
        fl11_y = csy(2) * ien_local(2)
        fl12_y = csy(3) * ien_local(2)
        fl21_y = csy(3) * ien_local(4)
        fl22_y = csy(1) * ien_local(4)
        fl31_y = csy(1) * ien_local(6)
        fl32_y = csy(2) * ien_local(6)
        crfs_x(1,ik) = - onesixth*(2.d0*fl31_x + fl32_x + fl21_x + 2.d0 * fl22_x)
        crfs_x(2,ik) = - onesixth*(2.d0*fl32_x + 2.d0 * fl11_x + fl12_x + fl31_x)
        crfs_x(3,ik) = - onesixth*(2.d0*fl12_x + 2.d0 * fl21_x + fl22_x + fl11_x)
        crfs_y(1,ik) = - onesixth*(2.d0*fl31_y + fl32_y + fl21_y + 2.d0 * fl22_y)
        crfs_y(2,ik) = - onesixth*(2.d0*fl32_y + 2.d0 * fl11_y + fl12_y + fl31_y)
        crfs_y(3,ik) = - onesixth*(2.d0*fl12_y + 2.d0 * fl21_y + fl22_y + fl11_y)
      ENDDO
 
      DO isp = 1, nspec
        ith     = 1 + mod(isp-1,nth)
        ik      = 1 + (isp-1)/nth
        k(1)     = k_x(1,ik) * ccosa(ith) + k_y(1,ik) * csina(ith) + k_u(1)
        k(2)     = k_x(2,ik) * ccosa(ith) + k_y(2,ik) * csina(ith) + k_u(2)
        k(3)     = k_x(3,ik) * ccosa(ith) + k_y(3,ik) * csina(ith) + k_u(3)
        crfs(1)  = crfs_x(1,ik) * ccosa(ith) + crfs_y(1,ik) * csina(ith) + crfs_u(1)
        crfs(2)  = crfs_x(2,ik) * ccosa(ith) + crfs_y(2,ik) * csina(ith) + crfs_u(2)
        crfs(3)  = crfs_x(3,ik) * ccosa(ith) + crfs_y(3,ik) * csina(ith) + crfs_u(3)
        !KM      = MIN(ZERO,K)
        kp(1:3)  = max(zero,k(1:3))
        deltal(1:3) = crfs(1:3) - kp(1:3)
        !NM      = 1.d0/MIN(-THR,SUM(MIN(ZERO,K)))
        dtk     = kp(pos) * dtg * iobpth1(ith)!IOBDP(IP_glob) * (1-IOBPA(IP_glob)) * IOBPD(ITH,IP_glob)
        tmp3    = dtk * 1.d0/min(-thr,sum(min(zero,k(1:3))))
        IF (fsgeoadvect) THEN
          aspar_diag_local(isp)     = aspar_diag_local(isp) + tria03 + dtk - tmp3*deltal(pos)
          d1                        = deltal(ipp1)*va(isp,ip1)
          d2                        = deltal(ipp2)*va(isp,ip2)
          aspar_off_diag_local(isp) = aspar_off_diag_local(isp) - ( tmp3 * ( d1 + d2 )  )
          !ASPAR_OFF_DIAG_LOCAL(ISP) = ASPAR_OFF_DIAG_LOCAL(ISP)            - D2
        ELSE
          aspar_diag_local(isp)     = aspar_diag_local(isp) + tria03
        END IF
        b_jac_local(isp) = b_jac_local(isp) + tria03 * vaold(isp,ip) * iobpth2(ith)!IOBDP(IP_glob) * IOBPD(ITH,IP_glob)
      END DO
    END DO
  END SUBROUTINE calcarray_jacobi4
  !/ ------------------------------------------------------------------- /
  SUBROUTINE calcarray_jacobi_spectral_1(DTG)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Compute matrix coefficients for spectral part
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE w3gdatmd, only: fsrefraction, fsfreqshift, fachfa
    USE w3odatmd, only : iaproc
    USE yownodepool, only: np, iplg, pdlib_si, pdlib_i_diag
    USE w3gdatmd, only: iobp_loc, iobpd_loc, iobpa_loc, iobdp_loc
    USE w3idatmd, only: fllev, flcur
    USE w3gdatmd, only: nk, nk2, nth, nspec, mapfs, dmin, dsip, nseal
    USE w3parall, only : prop_refraction_pr3, prop_refraction_pr1, prop_freq_shift, prop_freq_shift_m2, zero, imem
    USE w3adatmd, only: cg, dw
 
    REAL, INTENT(in) :: DTG
    INTEGER IP, IP_glob, ITH, IK
    INTEGER ISEA, ISP
    REAL ::  eSI
    REAL  :: B_SIG(NSPEC), B_THE(NSPEC)
    REAL  :: CP_SIG(NSPEC), CM_SIG(NSPEC)
    REAL  :: CP_THE(NSPEC), CM_THE(NSPEC)
    REAL  :: CAD(NSPEC), CAS(NSPEC)
    REAL  :: DMM(0:NK2), eVal
    REAL  :: DWNI_M2(NK), CWNB_M2(1-NTH:NSPEC)
    LOGICAL :: DoLimiterRefraction = .false.
    LOGICAL :: DoLimiterFreqShit   = .false. !AR: This one is missing ...
    INTEGER :: ITH0
 
    LOGICAL :: LSIG = .false.
    !AR: TODO: check&report if needed ...
    lsig = flcur .OR. fllev
 
    DO ip = 1, np
      ip_glob=iplg(ip)
      isea=mapfs(1,ip_glob)
      esi=pdlib_si(ip)
      IF (fsfreqshift .AND. lsig) THEN
        IF (freqshiftmethod .eq. 1) THEN
          IF (iobp_loc(ip).eq.1.and.iobdp_loc(ip).eq.1.and.iobpa_loc(ip).eq.0) THEN
            CALL prop_freq_shift(ip, isea, cas, dmm, dtg)
            cp_sig = max(zero,cas)
            cm_sig = min(zero,cas)
            b_sig=0
            DO ith=1,nth
              DO ik=1,nk
                isp=ith + (ik-1)*nth
                b_sig(isp)= cp_sig(isp)/dmm(ik-1) - cm_sig(isp)/dmm(ik)
              END DO
              isp  = ith + (nk-1)*nth
              b_sig(isp)= b_sig(isp) + cm_sig(isp)/dmm(nk) * fachfa
            END DO
            aspar_jac(:,pdlib_i_diag(ip))=aspar_jac(:,pdlib_i_diag(ip)) + b_sig(:)*esi
          ELSE
            cas=0
          END IF
          cas_sig(:,ip) = cas
        ELSE IF (freqshiftmethod .eq. 2) THEN
          IF (iobp_loc(ip).eq.1.and.iobdp_loc(ip).eq.1.and.iobpa_loc(ip).eq.0) THEN
            CALL prop_freq_shift_m2(ip, isea, cwnb_m2, dwni_m2, dtg)
#ifdef W3_DEBUGFREQSHIFT
            WRITE(740+iaproc,*) 'sum(CWNB_M2)=', sum(cwnb_m2)
#endif
            DO ith=1,nth
              DO ik=1,nk
                isp = ith + (ik-1)*nth
                eval = dwni_m2(ik) * ( min(cwnb_m2(isp - nth), zero) - max(cwnb_m2(isp),zero) )
                aspar_jac(isp,pdlib_i_diag(ip)) =  aspar_jac(isp,pdlib_i_diag(ip)) - esi * eval
              END DO
              eval = dwni_m2(nk) * min(cwnb_m2(ith + (nk-1)*nth), zero) * fachfa
              ith0 = nspec - nth
              aspar_jac(ith0 + ith,pdlib_i_diag(ip)) = aspar_jac(ith0 + ith,pdlib_i_diag(ip)) + esi * eval
            END DO
          ELSE
            cwnb_m2 = 0
          END IF
          cwnb_sig_m2(:,ip)=cwnb_m2
        END IF
      END IF
      !
      ! The refraction
      !
      IF (fsrefraction) THEN
        IF (iobp_loc(ip) .eq. 1 .and. iobdp_loc(ip).eq.1.and.iobpa_loc(ip).eq.0) THEN
          !    CALL PROP_REFRACTION_PR1(ISEA,DTG,CAD) !AR: Check statuts ...
          !    CALL PROP_REFRACTION_PR3(ISEA,DTG,CAD, DoLimiterRefraction)
          CALL prop_refraction_pr3(ip,isea,dtg,cad,dolimiterrefraction)
        ELSE
          cad=zero
        END IF
#ifdef W3_DEBUGREFRACTION
        WRITE(740+iaproc,*) 'refraction IP=', ip, ' ISEA=', isea
        WRITE(740+iaproc,*) 'sum(abs(CAD))=', sum(abs(cad))
#endif
        cad_the(:,ip)=cad
        cp_the = dtg*max(zero,cad)
        cm_the = dtg*min(zero,cad)
        b_the(:) = cp_the(:) - cm_the(:)
        aspar_jac(:,pdlib_i_diag(ip))=aspar_jac(:,pdlib_i_diag(ip)) + b_the(:)*esi
      END IF
    END DO
  END SUBROUTINE calcarray_jacobi_spectral_1
  !/ ------------------------------------------------------------------- /
  SUBROUTINE calcarray_jacobi_spectral_2(DTG,ASPAR_DIAG_LOCAL)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Compute matrix coefficients for spectral part
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
 
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE w3gdatmd, only: fsrefraction, fsfreqshift, fachfa
    USE w3odatmd, only : iaproc
    USE yownodepool, only: np, iplg, pdlib_si, pdlib_i_diag
    USE w3gdatmd, only: iobp_loc, iobpd_loc, iobpa_loc, iobdp_loc
    USE w3idatmd, only: fllev, flcur
    USE w3gdatmd, only: nk, nk2, nth, nspec, mapfs, dmin, dsip, nseal, mapsta
    USE w3parall, only : prop_refraction_pr3, prop_refraction_pr1, prop_freq_shift, prop_freq_shift_m2, zero, imem
    USE w3adatmd, only: cg, dw
 
    REAL, INTENT(in) :: DTG
    REAL, INTENT(inout) :: ASPAR_DIAG_LOCAL(nspec,NSEAL)
    INTEGER IP, IP_glob, ITH, IK
    INTEGER ISEA, ISP
    REAL ::  eSI
    REAL  :: B_SIG(NSPEC), B_THE(NSPEC)
    REAL  :: CP_SIG(NSPEC), CM_SIG(NSPEC)
    REAL  :: CP_THE(NSPEC), CM_THE(NSPEC)
    REAL  :: CAD(NSPEC), CAS(NSPEC)
    REAL  :: DMM(0:NK2), eVal
    REAL  :: DWNI_M2(NK), CWNB_M2(1-NTH:NSPEC)
    LOGICAL :: DoLimiterRefraction = .false.
    LOGICAL :: DoLimiterFreqShit   = .false. !AR: This one is missing ...
    INTEGER :: ITH0
 
    LOGICAL :: LSIG = .false.
    lsig = flcur .OR. fllev
 
    DO ip = 1, np
 
      ip_glob=iplg(ip)
      isea=mapfs(1,ip_glob)
      esi=pdlib_si(ip)
      !
      ! The frequency shifting
      !
      IF (fsfreqshift .AND. lsig) THEN
        IF (freqshiftmethod .eq. 1) THEN
          IF (iobp_loc(ip).eq.1.and.iobdp_loc(ip).eq.1.and.iobpa_loc(ip).eq.0) THEN
            CALL prop_freq_shift(ip, isea, cas, dmm, dtg)
            cp_sig = max(zero,cas)
            cm_sig = min(zero,cas)
            b_sig=0
            DO ith=1,nth
              DO ik=1,nk
                isp=ith + (ik-1)*nth
                b_sig(isp)= cp_sig(isp)/dmm(ik-1) - cm_sig(isp)/dmm(ik)
              END DO
              isp  = ith + (nk-1)*nth
              b_sig(isp)= b_sig(isp) + cm_sig(isp)/dmm(nk) * fachfa
            END DO
            aspar_diag_local(:,ip) = aspar_diag_local(:,ip) + b_sig * esi
          ELSE
            cas = 0
          END IF
          cas_sig(:,ip) = cas
        END IF
 
        IF (freqshiftmethod .eq. 2) THEN
          IF (iobp_loc(ip).eq.1) THEN
            CALL prop_freq_shift_m2(ip, isea, cwnb_m2, dwni_m2, dtg)
#ifdef W3_DEBUGFREQSHIFT
            WRITE(740+iaproc,*) 'sum(CWNB_M2)=', sum(cwnb_m2)
#endif
            DO ith=1,nth
              DO ik=1,nk
                isp = ith + (ik-1)*nth
                eval = dwni_m2(ik) * ( min(cwnb_m2(isp - nth), zero) - max(cwnb_m2(isp),zero) )
                IF (imem == 1) THEN
                  aspar_jac(isp,pdlib_i_diag(ip)) =  aspar_jac(isp,pdlib_i_diag(ip)) - esi * eval
                ELSE IF (imem == 2) THEN
                  aspar_diag_local(isp,ip) =  aspar_diag_local(isp,ip) - esi * eval
                ENDIF
              END DO
              eval = dwni_m2(nk) * min(cwnb_m2(ith + (nk-1)*nth), zero) * fachfa
              ith0 = nspec - nth
              aspar_diag_local(ith0 + ith,ip) = aspar_diag_local(ith0 + ith,ip) + esi * eval
            END DO
          ELSE
            cwnb_m2=0
          END IF
          cwnb_sig_m2(:,ip)=cwnb_m2
        END IF
      END IF
      !
      IF (fsrefraction) THEN
        IF (iobp_loc(ip) .eq. 1.and.iobdp_loc(ip).eq.1.and.iobpa_loc(ip).eq.0) THEN
          !    CALL PROP_REFRACTION_PR1(ISEA,DTG,CAD) !AR: Is this working?
          !    CALL PROP_REFRACTION_PR3(ISEA,DTG,CAD, DoLimiterRefraction)
          CALL prop_refraction_pr3(ip,isea,dtg,cad,dolimiterrefraction)
        ELSE
          cad=zero
        END IF
#ifdef W3_DEBUGREFRACTION
        WRITE(740+iaproc,*) 'refraction IP=', ip, ' ISEA=', isea
        WRITE(740+iaproc,*) 'sum(abs(CAD))=', sum(abs(cad))
#endif
        cad_the(:,ip)=cad
        cp_the = dtg*max(zero,cad)
        cm_the = dtg*min(zero,cad)
        b_the(:) = cp_the(:) - cm_the(:)
        aspar_diag_local(:,ip) = aspar_diag_local(:,ip) + b_the(:)*esi
      END IF
 
    END DO
  END SUBROUTINE calcarray_jacobi_spectral_2
  !/ ------------------------------------------------------------------- /
  SUBROUTINE calcarray_jacobi_source_1(DTG)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Compute matrix coefficients for source part
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE w3odatmd, only : iaproc
    USE yownodepool, only: iplg, pdlib_si, pdlib_i_diag, npa, np
    USE w3adatmd, only: cg, dw, wn
    USE w3wdatmd, only: ust, ustdir
    USE w3gdatmd, only: nk, nth, nspec, mapfs, optioncall, dmin
    USE w3gdatmd, only: mapsta, facp, sig
    USE w3gdatmd, only: iobp_loc, iobpd_loc, iobpa_loc, iobdp_loc
    USE w3parall, only: imem
    USE w3gdatmd, only: nseal, clats
#ifdef W3_DB1
    USE w3sdb1md
    USE w3gdatmd, only: sdbsc
#endif
#ifdef W3_DB2
    USE w3sdb2md
#endif
    USE w3wdatmd, only: va, vstot, vdtot, shavetot
    USE constants, only : tpi, tpiinv, grav
 
    REAL, INTENT(in) :: DTG
    REAL, PARAMETER :: COEF4 = 5.0e-07
    REAL, PARAMETER :: FACDAM = 1
    INTEGER JSEA, IP, IP_glob, ISEA
    INTEGER IK, ITH, ISP, IS0
    LOGICAL :: LBREAK
    REAL ::  eSI, eVS, eVD, SIDT
    REAL :: DEPTH, DAM(NSPEC), RATIO, MAXDAC, VSDB(NSPEC), VDDB(NSPEC)
    REAL :: PreVS, eDam, DVS, FREQ, EMEAN, FMEAN, WNMEAN, AMAX, CG1(NK),WN1(NK),SPEC_VA(NSPEC)
    REAL TheFactor
 
    DO jsea = 1, np
 
      ip      = jsea
      ip_glob = iplg(ip)
      isea    = mapfs(1,ip_glob)
 
      IF ((iobp_loc(ip).eq.1..or.iobp_loc(jsea).eq. 3).and.iobdp_loc(ip).eq.1.and.iobpa_loc(ip).eq.0) THEN
 
        DO ik=1, nk
          dam(1+(ik-1)*nth) = facp / ( sig(ik) * wn(ik,isea)**3 )
        END DO
        DO ik=1, nk
          is0    = (ik-1)*nth
          DO ith=2, nth
            dam(ith+is0) = dam(1+is0)
          END DO
        END DO
 
        esi    = pdlib_si(ip)
        sidt   = esi * dtg
        depth  = dw(isea)
#ifdef W3_DB1
        vsdb   = 0.
        vddb   = 0.
        cg1 = cg(1:nk,isea)
        wn1 = wn(1:nk,isea)
        DO ik=1,nk
          DO ith=1,nth
            isp=ith + (ik-1)*nth
            spec_va(isp) = va(isp,jsea) * cg(ik,isea) / clats(isea)
          ENDDO
        ENDDO
        CALL compute_mean_param(spec_va, cg1, wn1, emean, fmean, wnmean, amax)
        SELECT CASE (nint(sdbsc))
        CASE(1)
          CALL w3sdb1 ( jsea, spec_va, depth, emean, fmean, wnmean, cg1, lbreak, vsdb, vddb )
        CASE(2)
          !CALL W3SDB2 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, CG1, LBREAK, VSDB, VDDB )
        END SELECT
#endif
#ifdef W3_DB2
        vsdb   = 0.
        vddb   = 0.
        cg1 = cg(1:nk,isea)
        wn1 = wn(1:nk,isea)
        DO ik=1,nk
          DO ith=1,nth
            isp=ith + (ik-1)*nth
            spec_va(isp) = va(isp,jsea) * cg(ik,isea) / clats(isea)
          ENDDO
        ENDDO
        CALL compute_mean_param(spec_va, cg1, wn1, emean, fmean, wnmean, amax)
        CALL w3sdb2 ( jsea, spec_va, depth, emean, fmean, cg1, lbreak, vsdb, vddb )
#endif
        DO ik=1,nk
          DO ith=1,nth
            isp=ith + (ik-1)*nth
            IF (shavetot(jsea)) THEN ! Limit only the source term part ...
              maxdac    = facdam * dam(isp)
              thefactor = dtg / max( 1. , (1.-dtg*vdtot(isp,jsea)))
              dvs       = vstot(isp,jsea) * thefactor
              dvs       = sign(min(maxdac,abs(dvs)),dvs)
              prevs     = dvs / thefactor
            ELSE
              prevs     = vstot(isp,jsea)
            END IF
            evs = prevs * clats(isea) / cg(ik,isea)
            evd = dble(vdtot(isp,jsea))
#ifdef W3_DB1
            evs = evs + dble(vsdb(isp)) / cg(ik,isea) * clats(isea)
            evd = evd + dble(vddb(isp))
#endif
#ifdef W3_DB2
            evs = evs + dble(vsdb(isp)) / cg(ik,isea) * clats(isea)
            evd = evd + dble(vddb(isp))
#endif
            b_jac(isp,ip)                   = b_jac(isp,ip) + sidt * (evs - evd*va(isp,jsea))
            aspar_jac(isp,pdlib_i_diag(ip)) = aspar_jac(isp,pdlib_i_diag(ip)) - sidt * evd
          END DO
        END DO
      END IF
    END DO
  END SUBROUTINE calcarray_jacobi_source_1
  !/ ------------------------------------------------------------------- /
  SUBROUTINE calcarray_jacobi_source_2(DTG,ASPAR_DIAG_LOCAL)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Compute matrix coefficients for source part
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE w3odatmd, only : iaproc
    USE yownodepool, only: iplg, pdlib_si, pdlib_i_diag, npa, np
    USE w3adatmd, only: cg, dw, wn
    USE w3wdatmd, only: ust, ustdir
    USE w3gdatmd, only: nk, nth, nspec, mapfs, optioncall, dmin
    USE w3gdatmd, only: iobp, mapsta, facp, sig, iobpd, iobpa, iobdp
    USE w3parall, only: imem
    USE w3gdatmd, only: nseal, clats
#ifdef W3_DB1
    USE w3sdb1md
    USE w3gdatmd, only: sdbsc
#endif
#ifdef W3_DB2
    USE w3sdb2md
#endif
    USE w3wdatmd, only: va, vstot, vdtot, shavetot
    USE constants, only : tpi, tpiinv, grav
 
    REAL, INTENT(in) :: DTG
    REAL, INTENT(inout) :: ASPAR_DIAG_LOCAL(:,:)
    REAL, PARAMETER :: COEF4 = 5.0e-07
    REAL, PARAMETER :: FACDAM = 1
    INTEGER JSEA, IP, IP_glob, ISEA
    INTEGER IK, ITH, ISP, IS0
    LOGICAL :: LBREAK
    REAL ::  eSI, eVS, eVD, SIDT
    REAL :: DEPTH, DAM(NSPEC), RATIO, MAXDAC, VSDB(NSPEC), VDDB(NSPEC)
    REAL :: PreVS, eDam, DVS, FREQ, EMEAN, FMEAN, WNMEAN, AMAX, CG1(NK),WN1(NK),SPEC_VA(NSPEC)
    REAL TheFactor
 
    DO jsea = 1, np
 
      ip      = jsea
      ip_glob = iplg(ip)
      isea    = mapfs(1,ip_glob)
 
      IF (iobp(ip_glob).eq.1..and.iobdp(ip_glob).eq.1.and.iobpa(ip_glob).eq.0) THEN
        DO ik=1, nk
          dam(1+(ik-1)*nth) = facp / ( sig(ik) * wn(ik,isea)**3 )
        END DO
        DO ik=1, nk
          is0    = (ik-1)*nth
          DO ith=2, nth
            dam(ith+is0) = dam(1+is0)
          END DO
        END DO
        esi    = pdlib_si(ip)
        sidt   = esi * dtg
        depth  = dw(isea)
#ifdef W3_DB1
        vsdb   = 0.
        vddb   = 0.
        cg1 = cg(1:nk,isea)
        wn1 = wn(1:nk,isea)
        DO ik=1,nk
          DO ith=1,nth
            isp=ith + (ik-1)*nth
            spec_va(isp) = va(isp,jsea) * cg(ik,isea) / clats(isea)
          ENDDO
        ENDDO
        CALL compute_mean_param(spec_va, cg1, wn1, emean, fmean, wnmean, amax)
        SELECT CASE (nint(sdbsc))
        CASE(1)
          CALL w3sdb1 ( jsea, spec_va, depth, emean, fmean, wnmean, cg1, lbreak, vsdb, vddb )
        CASE(2)
          !CALL W3SDB2 ( JSEA, SPEC_VA, DEPTH, EMEAN, FMEAN, CG1, LBREAK, VSDB, VDDB )
        END SELECT
#endif
#ifdef W3_DB2
        vsdb   = 0.
        vddb   = 0.
        cg1 = cg(1:nk,isea)
        wn1 = wn(1:nk,isea)
        DO ik=1,nk
          DO ith=1,nth
            isp=ith + (ik-1)*nth
            spec_va(isp) = va(isp,jsea) * cg(ik,isea) / clats(isea)
          ENDDO
        ENDDO
        CALL compute_mean_param(spec_va, cg1, wn1, emean, fmean, wnmean, amax)
        CALL w3sdb2 ( jsea, spec_va, depth, emean, fmean, cg1, lbreak, vsdb, vddb )
#endif
        DO ik=1,nk
          DO ith=1,nth
            isp=ith + (ik-1)*nth
            IF (shavetot(jsea)) THEN ! Limit only the source term part ...
              maxdac    = facdam * dam(isp)
              thefactor = dtg / max( 1. , (1.-dtg*vdtot(isp,jsea)))
              dvs       = vstot(isp,jsea) * thefactor
              dvs       = sign(min(maxdac,abs(dvs)),dvs)
              prevs     = dvs / thefactor
            ELSE
              prevs     = vstot(isp,jsea)
            END IF
            evs = prevs / cg(ik,isea) * clats(isea)
            evd = dble(vdtot(isp,jsea))
#ifdef W3_DB1
            evs = evs + dble(vsdb(isp)) / cg(ik,isea) * clats(isea)
            evd = evd + dble(vddb(isp))
#endif
#ifdef W3_DB2
            evs = evs + dble(vsdb(isp)) / cg(ik,isea) * clats(isea)
            evd = evd + dble(vddb(isp))
#endif
            b_jac(isp,ip)                   = b_jac(isp,ip) + sidt * (evs - evd*va(isp,jsea))
            aspar_diag_local(isp,ip) = aspar_diag_local(isp,ip) - sidt * evd
          END DO
        END DO
      END IF
    END DO
  END SUBROUTINE calcarray_jacobi_source_2
  !/ ------------------------------------------------------------------- /
  SUBROUTINE apply_boundary_condition_va
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Boudary conditions on VA
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    USE yowrankmodule, only : ipgl_npa
    USE w3gdatmd, only: nseal, clats, gtype, ungtype
    USE w3wdatmd, only: time
    USE w3timemd, only: dsec21
    USE w3adatmd, only: cg, cx, cy
    USE w3wdatmd, only: va
    USE w3gdatmd, only: nk, nk2, nth, ecos, esin, nspec
    USE w3odatmd, only: tbpi0, tbpin, flbpi, iaproc, naproc, bbpi0, bbpin, isbpi, nbi
    USE w3parall, only : isea_to_jsea
    !/
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local PARAMETERs
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
    REAL    :: RD1, RD2, RD10, RD20
    REAL    :: eVA, eAC
    INTEGER :: IK, ITH, ISEA, JSEA
    INTEGER :: IBI, ISP
#ifdef W3_S
    CALL strace (ient, 'APPLY_BOUNDARY_CONDITION_VA')
#endif
    IF (gtype .eq. ungtype) THEN
      IF ( flbpi ) THEN
        rd10    = dsec21( tbpi0, time )
        rd20    = dsec21( tbpi0, tbpin )
      ELSE
        rd10=1.
        rd20=0.
      END IF
      IF (flbpi .and. (iaproc .le. naproc)) THEN
        rd1=rd10 ! I am not completely sure about that
        rd2=rd20
        IF ( rd2 .GT. 0.001 ) THEN
          rd2    = min(1.,max(0.,rd1/rd2))
          rd1    = 1. - rd2
        ELSE
          rd1    = 0.
          rd2    = 1.
        END IF
        DO ibi=1, nbi
          isea=isbpi(ibi)
          jsea=isea_to_jsea(isea)
          IF (jsea .gt. 0) THEN
            DO ith=1,nth
              DO ik=1,nk
                isp=ith + (ik-1)*nth
                eac = ( rd1*bbpi0(isp,ibi) + rd2*bbpin(isp,ibi) )   &
                     / cg(ik,isbpi(ibi)) * clats(isbpi(ibi))
                eva = max(0., cg(ik,isea)/clats(isea)*eac)
                va(isp,jsea) = eva
              END DO
            END DO
          END IF
        END DO
      END IF
    END IF
  END SUBROUTINE apply_boundary_condition_va
  !/ ------------------------------------------------------------------- /
  SUBROUTINE apply_boundary_condition(IMOD)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Apply boundary conditions
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    USE yownodepool, only: npa, np
    USE yowrankmodule, only : ipgl_npa
    USE w3gdatmd, only: nseal, clats, mapsf
    USE w3wdatmd, only: time
    USE w3timemd, only: dsec21
    USE w3wdatmd, only : va
    USE w3adatmd, only: cg, cx, cy
    USE w3gdatmd, only: nk, nk2, nth, nspec
    USE w3odatmd, only: tbpi0, tbpin, flbpi, iaproc, bbpi0, bbpin, isbpi, nbi
    USE w3gdatmd, only: iobp_loc, iobpd_loc, iobdp_loc, iobpa_loc
#ifdef W3_DEBUGIOBC
    USE w3gdatmd, only: dden
#endif
    !/
    INTEGER, INTENT(IN) :: IMOD
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local PARAMETERs
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
#ifdef W3_DEBUGSOLVER
    real*8 :: sumac(nspec)
    REAL :: sumBPI0(NSPEC), sumBPIN(NSPEC), sumCG, sumCLATS
#endif
#ifdef W3_DEBUGIOBC
    REAL :: ETOT, HSIG_bound, eVA, eAC, FACTOR
#endif
    REAL    :: RD1, RD2, RD10, RD20
    INTEGER :: IK, ITH, ISEA
    INTEGER :: IBI, IP_glob, ISP, JX
#ifdef W3_S
    CALL strace (ient, 'APPLY_BOUNDARY_CONDITION')
#endif
#ifdef W3_DEBUGSOLVERCOH
    CALL all_va_integral_print(imod, "VA(np) before boundary", 0)
    CALL all_va_integral_print(imod, "VA(npa) before boundary", 1)
#endif
    IF ( flbpi ) THEN
      rd10    = dsec21( tbpi0, time )
      rd20    = dsec21( tbpi0, tbpin )
    ELSE
      rd10=1.
      rd20=0.
    END IF
    IF ( flbpi ) THEN
      rd1=rd10 ! I am not completely sure about that
      rd2=rd20
      IF ( rd2 .GT. 0.001 ) THEN
        rd2    = min(1.,max(0.,rd1/rd2))
        rd1    = 1. - rd2
      ELSE
        rd1    = 0.
        rd2    = 1.
      END IF
#ifdef W3_DEBUGSOLVER
      WRITE(740+iaproc,*) 'Begin of APPLY_BOUNDARY_CONDITION'
      WRITE(740+iaproc,*) 'NBI=', nbi
      FLUSH(740+iaproc)
      sumac=0
      sumbpi0=0
      sumbpin=0
      sumcg=0
      sumclats=0
#endif
      DO ibi=1, nbi
        isea    = isbpi(ibi)
        ip_glob = mapsf(isea,1)
        jx      = ipgl_npa(ip_glob)
        IF (jx .gt. 0) THEN
          DO ith=1,nth
            DO ik=1,nk
              isp=ith + (ik-1)*nth
              va(isp,jx) = (( rd1*bbpi0(isp,ibi) + rd2*bbpin(isp,ibi) )  &
                   / cg(ik,isbpi(ibi)) * clats(isbpi(ibi))) * iobdp_loc(jx)
            END DO
          END DO
#ifdef W3_DEBUGIOBC
          etot=0
          DO ith=1,nth
            DO ik=1,nk
              factor = dden(ik)/cg(ik,isea)
              isp=ith + (ik-1)*nth
              eac=real(va(isp,jx))
              eva=cg(ik,isea)/clats(isea)*eac
              etot = etot + eva*factor
            END DO
          END DO
          hsig_bound=4.*sqrt(etot)
          WRITE(740+iaproc,*) 'IBI=', ibi, ' HSIG=', hsig_bound
#endif
 
#ifdef W3_DEBUGSOLVER
          sumac=sumac + va(:,jx)
          sumbpi0=sumbpi0 + bbpi0(:,ibi)
          sumbpin=sumbpin + bbpin(:,ibi)
          sumcg=sumcg + cg(ik,isbpi(ibi))
          sumclats=sumclats + clats(isbpi(ibi))
#endif
        END IF
      ENDDO
#ifdef W3_DEBUGSOLVER
      WRITE(740+iaproc,*) 'RD1=', rd1, ' RD2=', rd2
#endif
#ifdef W3_DEBUGSOLVERALL
      DO isp=1,nspec
        WRITE(740+iaproc,*) 'RD1=', rd1, ' RD2=', rd2
        WRITE(740+iaproc,*) 'ISP=', isp, 'sumAC=', sumac(isp)
        WRITE(740+iaproc,*) 'ISP=', isp, 'sumBPI0=', sumbpi0(isp)
        WRITE(740+iaproc,*) 'ISP=', isp, 'sumBPIN=', sumbpin(isp)
        WRITE(740+iaproc,*) 'ISP=', isp, 'sumCG=', sumcg
        WRITE(740+iaproc,*) 'ISP=', isp, 'sumCLATS=', sumclats
      END DO
#endif
#ifdef W3_DEBUGSOLVER
      WRITE(740+iaproc,*) 'Begin of APPLY_BOUNDARY_CONDITION'
      FLUSH(740+iaproc)
#endif
#ifdef W3_DEBUGSOLVERCOH
      CALL all_va_integral_print(imod, "VA(np) after boundary", 0)
      CALL all_va_integral_print(imod, "VA(npa) after boundary", 1)
#endif
    END IF
  END SUBROUTINE apply_boundary_condition
  !/ ------------------------------------------------------------------- /
  SUBROUTINE action_limiter_local(IP,ACLOC,ACOLD, DTG)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Computation of the limiter function
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    use yownodepool, only: iplg
    USE constants, only : grav, tpi
    USE w3adatmd, only : wn, cg
    USE w3gdatmd, only : nth, nk, nspec, mapfs, sig, facp
    !/
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local PARAMETERs
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
    INTEGER, INTENT(in) :: IP
    REAL, INTENT(in) :: ACOLD(NSPEC)
    REAL, INTENT(inout) :: ACLOC(NSPEC)
    REAL, INTENT(in) :: DTG
    INTEGER :: MELIM = 1
    REAL :: LIMFAK = 0.1
    REAL :: CONST, SND, eWN, eWK, eWKpow
    REAL :: eFact, eSPSIG
    REAL :: NewVAL
    REAL :: OLDAC, NEWAC, NEWDAC
    REAL :: MAXDAC
    REAL :: dac, limac, eDam
    INTEGER IP_glob, ISEA
    INTEGER :: IK, ITH, ISP
    LOGICAL :: LLIMITER_WWM
#ifdef W3_S
    CALL strace (ient, 'ACTION_LIMITER_LOCAL')!
#endif
    ip_glob=iplg(ip)
    isea=mapfs(1,ip_glob)
    espsig=sig(nk)
    const = tpi**2*3.0*1.0e-7*dtg*espsig
    snd   = tpi*5.6*1.0e-3
 
    llimiter_wwm = .false.
 
    IF (llimiter_wwm) THEN
      maxdac = 0
      DO ik=1,nk
        IF (melim .eq. 1) THEN
          efact=2.*sig(ik)
          ewn=wn(ik,isea)
          ewk=ewn
          ewkpow=ewk**3
          maxdac = dble(0.0081*limfak/(efact*ewkpow*cg(ik,isea)))
        END IF
        DO ith=1,nth
          isp=ith + (ik-1)*nth
          newac  = acloc(isp)
          oldac  = acold(isp)
          newdac = newac - oldac
          newdac = sign(min(maxdac,abs(newdac)), newdac)
          newval = max(0., oldac + newdac )
          acloc(isp) = newval
        END DO
      END DO
    ELSE
      DO ik = 1, nk
        edam=dble(facp / (sig(ik) * wn(ik,isea)**3))
        DO ith=1,nth
          isp = ith + (ik-1)*nth
          dac = acloc(isp) - acold(isp)
          limac = sign(min(edam,abs(dac)),dac)
          acloc(isp) = max(0., acloc(isp) + limac)
        END DO
      END DO
    ENDIF
  END SUBROUTINE action_limiter_local
  !/ ------------------------------------------------------------------- /
  SUBROUTINE pdlib_jacobi_gauss_seidel_block(IMOD, FACX, FACY, DTG, VGX, VGY, LCALC)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Block Gauss Seidel and Jacobi solver
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
    !
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !/
    USE constants, only : tpi, tpiinv, grav
    USE w3gdatmd, only: mapsta
    USE w3gdatmd, only: fsrefraction, fsfreqshift, fssource, nx, dsip
    USE w3gdatmd, only: b_jgs_norm_thr, b_jgs_terminate_norm, b_jgs_pmin
    USE w3gdatmd, only: b_jgs_terminate_difference, b_jgs_maxiter, b_jgs_limiter
    USE w3gdatmd, only: b_jgs_terminate_maxiter, b_jgs_block_gauss_seidel, b_jgs_diff_thr
    USE w3gdatmd, only: mapwn
#ifdef W3_DEBUGSRC
    USE w3gdatmd, only: optioncall
    USE w3wdatmd, only: shavetot
#endif
    USE yownodepool, only: pdlib_i_diag, pdlib_ia_p, pdlib_ja, np
    USE yownodepool, only: pdlib_si, pdlib_nnz, pdlib_ccon
    use yowdatapool, only: rtype
    use yownodepool, only: npa, iplg
    use yowexchangemodule, only : pdlib_exchange2dreal_zero, pdlib_exchange2dreal
    USE mpi, only : mpi_sum, mpi_int
    USE w3adatmd, only: mpi_comm_wcmp
    USE w3gdatmd, only: nsea, sig, facp, flsou
    USE w3gdatmd, only: iobp_loc, iobpd_loc, iobdp_loc, iobpa_loc
    USE w3gdatmd, only: nk, nk2, nth, ecos, esin, nspec, mapfs, nsea, sig
    USE w3wdatmd, only: time
    USE w3odatmd, only: nbi
    USE w3timemd, only: dsec21
    USE w3gdatmd, only: nseal, clats, fachfa
    USE w3idatmd, only: flcur, fllev
    USE w3wdatmd, only: va, vaold, vstot, vdtot, ust
    USE w3adatmd, only: cg, cx, cy, wn, dw
    USE w3odatmd, only: tbpin, flbpi, iaproc
    USE w3parall, only : imem
    USE w3parall, only : init_get_jsea_isproc, zero, thr8, lsloc
    USE w3parall, only : listispprevdir, listispnextdir
    USE w3parall, only : jx_to_jsea
    USE w3gdatmd, only: b_jgs_nlevel, b_jgs_source_nonlinear
    USE yowfunction, only : pdlib_abort
    USE yownodepool, only: np_global
    USE w3dispmd, only : wavnu_local
    USE w3adatmd, ONLY: u10, u10d
#ifdef W3_ST4
    USE w3src4md, only: w3spr4
#endif
#ifdef W3_REF1
    USE w3gdatmd, only: refpars
#endif
    implicit none
    LOGICAL, INTENT(IN) :: LCALC
    INTEGER, INTENT(IN) :: IMOD
    REAL, INTENT(IN) :: FACX, FACY, DTG, VGX, VGY
    !
    INTEGER :: IP, ISP, ITH, IK, JSEA, ISEA, IP_glob, IS0
    INTEGER :: myrank
    INTEGER :: nbIter, ISPnextDir, ISPprevDir
    INTEGER :: ISPp1, ISPm1, JP, ICOUNT1, ICOUNT2
    ! for the exchange
    real*8  :: ccos, csin, ccurx, ccury
    real*8  :: esum(nspec), frlocal
    real*8  :: ea_the, ec_the, ea_sig, ec_sig, esi
    real*8  :: cad(nspec), cas(nspec), acloc(nspec)
    real*8  :: cp_sig(nspec), cm_sig(nspec)
    real*8  :: efactm1, efactp1
    real*8  :: sum_prev, sum_new, p_is_converged, diffnew, prop_conv
    real*8  :: sum_l2, sum_l2_gl
    REAL  :: DMM(0:NK2), DAM(NSPEC), DAM2(NSPEC), SPEC(NSPEC)
    real*8  :: ediff(nspec), eprod(nspec), ediffb(nspec)
    real*8  :: dwni_m2(nk), cwnb_m2(1-nth:nspec)
    REAL  :: VAnew(NSPEC), VFLWN(1-NTH:NSPEC), JAC, JAC2
    REAL  :: VAAnew(1-NTH:NSPEC+NTH), VAAacloc(1-NTH:NSPEC+NTH)
    REAL  :: VAinput(NSPEC), VAacloc(NSPEC), ASPAR_DIAG(NSPEC)
    REAL  :: aspar_diag_local(nspec), aspar_off_diag_local(nspec), b_jac_local(nspec)
    real*8 :: ediffsing, esumpart
    REAL  :: EMEAN, FMEAN, FMEAN1, WNMEAN, AMAX, U10ABS, U10DIR, TAUA, TAUADIR
    REAL  :: USTAR, USTDIR, TAUWX, TAUWY, CD, Z0, CHARN, FMEANWS, DLWMEAN
    real*8  :: eval1, eval2
    real*8  :: eva, evo, cg2, newdac, newac, oldac, maxdac
    REAL  :: CG1(0:NK+1), WN1(0:NK+1)
    LOGICAL :: LCONVERGED(NSEAL), lexist, LLWS(NSPEC)
#ifdef WEIGHTS
    INTEGER :: ipiter(nseal), ipitergl(np_global), ipiterout(np_global)
#endif
#ifdef W3_DEBUGSRC
    REAL :: IntDiff, eVA_w3srce, eVAsolve, SumACout
    REAL :: SumVAin, SumVAout, SumVAw3srce, SumVS, SumVD, VS_w3srce
    REAL    :: VAsolve(NSPEC)
    real*8  :: acsolve
    REAL    :: eB
#endif
#ifdef W3_DEBUGSOLVERCOH
    REAL :: TheARR(NSPEC, npa)
    REAL :: PRE_VA(NSPEC, npa)
    REAL :: OffDIAG(NSPEC, npa)
    real*8 :: eoff(nspec)
    real*8 :: esum1(nspec), esum2(nspec)
#endif
    CHARACTER(len=128) eFile
    INTEGER ierr, i
    INTEGER JP_glob
    INTEGER is_converged, itmp
 
    INTEGER :: TESTNODE = 923
 
    LOGICAL :: LSIG = .false.
 
    memunit = 50000+iaproc
    !AR: this is missing in init ... but there is a design error in ww3_grid with FLCUR and FLLEV
    lsig = flcur .OR. fllev
#ifdef W3_DEBUGSOLVERCOH
    offdiag = zero
#endif
    call print_memcheck(memunit, 'memcheck_____:'//' WW3_PROP SECTION 0')
 
 
    ccurx  = facx
    ccury  = facy
    CALL mpi_comm_rank(mpi_comm_wcmp, myrank, ierr)
    !
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK, begin'
    WRITE(740+iaproc,*) 'NX=', nx
    WRITE(740+iaproc,*) 'NP=', np
    WRITE(740+iaproc,*) 'NPA=', npa
    WRITE(740+iaproc,*) 'NSEA=', nsea
    WRITE(740+iaproc,*) 'NSEAL=', nseal
    WRITE(740+iaproc,*) 'NBI=', nbi
    WRITE(740+iaproc,*) 'B_JGS_TERMINATE_NORM=', b_jgs_terminate_norm
    WRITE(740+iaproc,*) 'B_JGS_TERMINATE_DIFFERENCE=', b_jgs_terminate_difference
    WRITE(740+iaproc,*) 'B_JGS_TERMINATE_MAXITER=', b_jgs_terminate_maxiter
    WRITE(740+iaproc,*) 'B_JGS_MAXITER=', b_jgs_maxiter
    WRITE(740+iaproc,*) 'B_JGS_BLOCK_GAUSS_SEIDEL=', b_jgs_block_gauss_seidel
    WRITE(740+iaproc,*) 'FSREFRACTION=', fsrefraction
    WRITE(740+iaproc,*) 'FSFREQSHIFT=', fsfreqshift
    WRITE(740+iaproc,*) 'B_JGS_LIMITER=', b_jgs_limiter
    WRITE(740+iaproc,*) 'B_JGS_BLOCK_GAUSS_SEIDEL=', b_jgs_block_gauss_seidel
    FLUSH(740+iaproc)
#endif
#ifdef W3_DEBUGSRC
    WRITE(740+iaproc,*) 'optionCall=', optioncall
    FLUSH(740+iaproc)
#endif
    call print_memcheck(memunit, 'memcheck_____:'//' WW3_PROP SECTION 1')
    !
    ! 2.  Convert to Wave Action ---------------- *
    !
#ifdef W3_DEBUGSRC
    WRITE(740+iaproc,*) 'NSEAL =', nseal, 'NP    =', np, 'NPA   =', npa
#endif
#ifdef W3_DEBUGSOLVERCOH
    CALL all_va_integral_print(imod, "VA(np) before transform", 0)
    CALL all_va_integral_print(imod, "VA(npa) before transform", 1)
#endif
    DO jsea=1,nseal
      ip      = jsea
      ip_glob = iplg(ip)
      isea    = mapfs(1,ip_glob)
      DO isp=1,nspec
        ith    = 1 + mod(isp-1,nth)
        ik     = 1 + (isp-1)/nth
#ifdef NOCGTABLE
        CALL wavnu_local(sig(ik),dw(isea),wn1(ik),cg1(ik))
#else
        cg1(ik)    = cg(ik,isea)
#endif
        va(isp,jsea) = va(isp,jsea) / cg1(ik) * clats(isea)
      END DO
    END DO
    vaold = va(1:nspec,1:nseal)
 
#ifdef W3_DEBUGSRC
    DO jsea=1,nseal
      WRITE(740+iaproc,*) 'JSEA=', jsea
      WRITE(740+iaproc,*) 'min/max/sum(VA)=', minval(va(:,jsea)), maxval(va(:,jsea)), sum(va(:,jsea))
    END DO
#endif
 
#ifdef W3_DEBUGSOLVERCOH
    CALL all_va_integral_print(imod, "VA(np) just defined", 0)
    CALL all_va_integral_print(imod, "VA(npa) just defined", 1)
#endif
 
#ifdef W3_DEBUGSOLVER
    FLUSH(740+iaproc)
    WRITE(740+iaproc,*) 'JACOBI_SOLVER, step 4'
    WRITE(740+iaproc,*) 'FSSOURCE=', fssource
    WRITE(740+iaproc,*) 'FSREFRACTION=', fsrefraction
    WRITE(740+iaproc,*) 'FSFREQSHIFT=', fsfreqshift
    WRITE(740+iaproc,*) 'FSGEOADVECT=', fsgeoadvect
    WRITE(740+iaproc,*) 'DTG=', dtg
#endif
    !
    !    init matrix and right hand side
    !
    call print_memcheck(memunit, 'memcheck_____:'//' WW3_PROP SECTION 2')
    !
    IF (.not. lsloc) THEN
      IF (imem == 1) THEN
        aspar_jac = zero
      ELSE IF (imem == 2) THEN
        aspar_diag_all = zero
      ENDIF
      b_jac = zero
    ENDIF
    call print_memcheck(memunit, 'memcheck_____:'//' WW3_PROP SECTION 3')
    !
    !     source terms
    !
    IF (fssource) THEN
      IF (.not. lsloc) THEN
        IF (imem == 1) THEN
          call calcarray_jacobi_source_1(dtg)
        ELSE IF (imem == 2) THEN
          call calcarray_jacobi_source_2(dtg,aspar_diag_all)
        ENDIF
      ENDIF
    END IF
    call print_memcheck(memunit, 'memcheck_____:'//' WW3_PROP SECTION 4')
    !
    !     geographical advection
    !
    IF (imem == 1) THEN
      call calcarray_jacobi_vec(dtg,facx,facy,vgx,vgy)
    ENDIF
 
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,'(A20,20E20.10)') 'SUM BJAC 1', sum(b_jac), sum(aspar_jac)
#endif
    call print_memcheck(memunit, 'memcheck_____:'//' WW3_PROP SECTION 5')
    !
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,'(A20,20E20.10)') 'SUM BJAC 1', sum(b_jac), sum(aspar_jac)
#endif
    !
    !     spectral advection
    !
    IF (fsfreqshift .or. fsrefraction) THEN
      IF (imem == 1) THEN
        call calcarray_jacobi_spectral_1(dtg)
      ELSE IF (imem == 2) THEN
        call calcarray_jacobi_spectral_2(dtg,aspar_diag_all)
      ENDIF
    END IF
    CALL apply_boundary_condition(imod)
    call print_memcheck(memunit, 'memcheck_____:'//' WW3_PROP SECTION 6')
    !
#ifdef W3_DEBUGSOLVERCOH
    CALL check_array_integral_nx_r8(b_jac, "B_JAC after calcARRAY", np)
    DO ip=1,npa
      thearr(:, ip)=real(aspar_jac(:, pdlib_i_diag(ip)))
    END DO
    CALL check_array_integral_nx_r8(thearr, "ASPAR diag after calArr", np)
#endif
    nbiter=0
    do ip = 1, np
      lconverged(ip) = .false.
#ifdef WEIGHTS
      ipiter(ip) = 0
#endif
    enddo
    !
    DO
 
      is_converged = 0
 
      call print_memcheck(memunit, 'memcheck_____:'//' WW3_PROP SECTION SOLVER LOOP 1')
 
      DO ip = 1, np
 
        ip_glob = iplg(ip)
        isea    = mapfs(1,ip_glob)
        IF (iobdp_loc(ip) .eq. 0) THEN
          is_converged   = is_converged + 1
          lconverged(ip) = .true.
          cycle
        ENDIF
 
        DO ik = 0, nk + 1
#ifdef NOCGTABLE
          CALL wavnu_local(sig(ik),dw(isea),wn1(ik),cg1(ik))
#else
          cg1(ik)  = cg(ik,isea)
          wn1(ik)  = wn(ik,isea)
#endif
        ENDDO
 
        jsea  = jx_to_jsea(ip)
        isea  = mapfs(1,ip_glob)
        esi   = pdlib_si(ip)
        acloc = va(:,jsea)
 
        IF (.NOT. lconverged(ip)) THEN
#ifdef WEIGHTS
          ipiter(ip) = ipiter(ip) + 1
#endif
#ifdef W3_DEBUGFREQSHIFT
          WRITE(740+iaproc,*) 'Begin loop'
          WRITE(740+iaproc,*) 'IP/IP_glob/ISEA/JSEA=', ip, ip_glob, isea, jsea
#endif
#ifdef W3_DEBUGSRC
          WRITE(740+iaproc,*) 'IP=', ip, ' IP_glob=', ip_glob
          WRITE(740+iaproc,*) 'sum(VA)in=', sum(va(:,ip))
#endif
#ifdef W3_DEBUGFREQSHIFT
          DO isp=1,nspec
            vaold(isp) = va(isp,jsea)
            ik=mapwn(isp)
            vainput(isp) = dble(cg(ik,isea)/clats(isea)) * va(isp, ip)
            vaacloc(isp) = dble(cg(ik,isea)/clats(isea)) * acloc(isp)
          END DO
          WRITE(740+iaproc,*) 'sum(VAold/VAinput/VAacloc)=', sum(vaold), sum(vainput), sum(vaacloc)
#endif
 
          sum_prev = sum(acloc)
 
          IF (imem == 2) THEN
            CALL calcarray_jacobi4(ip,dtg,facx,facy,vgx,vgy,aspar_diag_local,aspar_off_diag_local,b_jac_local)
            aspar_diag(1:nspec) = aspar_diag_local(1:nspec) + aspar_diag_all(1:nspec,ip)
            esum       = b_jac_local - aspar_off_diag_local + b_jac(1:nspec,ip)
          ELSEIF (imem == 1) THEN
            esum(1:nspec)       = b_jac(1:nspec,ip)
            aspar_diag(1:nspec) = aspar_jac(1:nspec,pdlib_i_diag(ip))
#ifdef W3_DEBUGFREQSHIFT
            WRITE(740+iaproc,*) 'eSI=', esi
            WRITE(740+iaproc,*) 'sum(ASPAR_DIAG)=', sum(aspar_diag)
#endif
#ifdef W3_DEBUGSRC
            WRITE(740+iaproc,*) 'Step 1: sum(eSum)=', sum(esum)
#endif
#ifdef W3_DEBUGSOLVERCOH
            eoff=zero
#endif
            DO i = pdlib_ia_p(ip)+1, pdlib_ia_p(ip+1)
              jp = pdlib_ja(i)
              IF (jp .ne. ip) THEN
                eprod(1:nspec) = aspar_jac(1:nspec,i) * va(1:nspec,jp)
                esum(1:nspec)  = esum(1:nspec) - eprod(1:nspec)
#ifdef W3_DEBUGSOLVERALL
                WRITE(740+iaproc,'(A20,3I10,20E20.10)') 'OFF DIAGONAL', ip, i, jp, sum(b_jac(:,ip)), sum(esum), sum(aspar_jac(:,i)), sum(va(:,jp))
#endif
#ifdef W3_DEBUGSOLVERCOH
                eoff=eoff + abs(aspar_jac(:,i))
#endif
              END IF
            END DO
          ENDIF ! IMEM
 
#ifdef W3_DEBUGSOLVERCOH
          offdiag(:, ip)=real(eoff)
#endif
#ifdef W3_DEBUGSOLVERCOHALL
          WRITE(740+iaproc,*) 'Step 2: sum(eSum)=', sum(esum), ' eOff=', sum(eoff)
#endif
          IF (fsrefraction) THEN
#ifdef W3_DEBUGREFRACTION
            WRITE(740+iaproc,*) 'Adding refraction terms to eSum'
#endif
            cad = cad_the(:,ip)
            DO isp=1,nspec
              ispprevdir=listispprevdir(isp)
              ispnextdir=listispnextdir(isp)
              ea_the = - dtg*esi*max(zero,cad(ispprevdir))
              ec_the =   dtg*esi*min(zero,cad(ispnextdir))
              esum(isp) = esum(isp) - ea_the * va(ispprevdir,ip)
              esum(isp) = esum(isp) - ec_the * va(ispnextdir,ip)
            END DO
          END IF
#ifdef W3_DEBUGSRC
          WRITE(740+iaproc,*) 'Step 3: sum(eSum)=', sum(esum)
#endif
          IF (fsfreqshift .and. lsig) THEN
            IF (freqshiftmethod .eq. 1) THEN
              cas = cas_sig(:,ip)
              cp_sig = max(zero,cas)
              cm_sig = min(zero,cas)
              DO ik=0, nk
                dmm(ik+1) = dble(wn1(ik+1) - wn1(ik))
              END DO
              dmm(nk+2) = zero
              dmm(0)=dmm(1)
              DO ith=1,nth
                DO ik=2,nk
                  isp       = ith + (ik   -1)*nth
                  ispm1     = ith + (ik-1 -1)*nth
                  efactm1   = cg1(ik-1) / cg1(ik)
                  ea_sig    = - esi * cp_sig(ispm1)/dmm(ik-1) * efactm1
                  esum(isp) = esum(isp) - ea_sig*va(ispm1,ip)
                END DO
                DO ik=1,nk-1
                  isp       = ith + (ik   -1)*nth
                  ispp1     = ith + (ik+1 -1)*nth
                  efactp1   = cg1(ik+1) / cg1(ik)
                  ec_sig    = esi * cm_sig(ispp1)/dmm(ik) * efactp1
                  esum(isp) = esum(isp) - ec_sig*va(ispp1,ip)
                END DO
              END DO
            ELSE IF (freqshiftmethod .eq. 2) THEN
              cwnb_m2=cwnb_sig_m2(:,ip)
              DO ik=1, nk
                dwni_m2(ik) = dble( cg1(ik) / dsip(ik) )
              END DO
#ifdef W3_DEBUGFREQSHIFT
              WRITE(740+iaproc,*) 'Before FreqShift oper eSum=', sum(abs(esum))
#endif
              DO ith=1,nth
                DO ik=2,nk
                  isp       = ith + (ik   -1)*nth
                  ispm1     = ith + (ik-1 -1)*nth
                  efactm1   = dble( cg1(ik-1) / cg1(ik) )
                  ea_sig    = - esi * dwni_m2(ik) * max(cwnb_m2(ispm1),zero) *efactm1
                  esum(isp) = esum(isp) - ea_sig*va(ispm1,ip)
                END DO
                DO ik=1,nk-1
                  isp       = ith + (ik   -1)*nth
                  ispp1     = ith + (ik+1 -1)*nth
                  efactp1   = dble( cg1(ik+1) / cg1(ik) )
                  ec_sig    = esi * dwni_m2(ik) * min(cwnb_m2(isp),zero) * efactp1
                  esum(isp) = esum(isp) - ec_sig*va(ispp1,ip)
                END DO
              END DO
#ifdef W3_DEBUGFREQSHIFT
              WRITE(740+iaproc,*) ' after FreqShift oper eSum=', sum(abs(esum))
#endif
            END IF
          END IF
#ifdef W3_DEBUGSRC
          WRITE(740+iaproc,*) 'Step 4: sum(eSum)=', sum(esum)
#endif
#ifdef W3_DEBUGSOLVERCOH
          pre_va(:, ip)=real(esum)
#endif
          esum(1:nspec)  = esum(1:nspec) / aspar_diag(1:nspec)
#ifdef W3_DEBUGFREQSHIFT
          WRITE(740+iaproc,*) 'JSEA=', jsea, ' nbIter=', nbiter
          DO isp=1,nspec
            ik=mapwn(isp)
            vanew(isp) = dble(cg(ik,isea)/clats(isea)) * esum(isp)
          END DO
          DO isp=1,nspec
            vaanew(isp)   = vanew(isp)
            vaaacloc(isp) = vaacloc(isp)
          END DO
          DO ith=1,nth
            vaanew(ith + nspec) = fachfa * vaanew(ith + nspec - nth)
            vaanew(ith - nth  ) = 0.
            vaaacloc(ith + nspec) = fachfa * vaaacloc(ith + nspec - nth)
            vaaacloc(ith - nth  ) = 0.
          END DO
          DO isp=1-nth,nspec
            vflwn(isp) = max(cwnb_m2(isp),0.) * vaanew(isp) + min(cwnb_m2(isp),0.) * vaanew(isp + nth)
          END DO
          DO isp=1,nspec
            ediff(isp)  = vanew(isp) - vaold(isp) - dwni_m2(mapwn(isp)) * (vflwn(isp-nth) - vflwn(isp) )
            eval1=max(cwnb_m2(isp-nth),0.) * vaaacloc(isp-nth) + min(cwnb_m2(isp-nth),0.) * vaanew(isp)
            eval2=max(cwnb_m2(isp),0.) * vaanew(isp) + min(cwnb_m2(isp),0.) * vaaacloc(isp + nth)
            ediffb(isp) = vanew(isp) - vaold(isp) - dwni_m2(mapwn(isp)) * (eval1 - eval2)
          END DO
          IF (isea .eq. 190) THEN
            DO ik=1,nk
              DO ith=1,nth
                isp = ith + (ik-1)*nth
                WRITE(740+iaproc,*) 'ISP/ITH/IK=', isp, ith, ik
                WRITE(740+iaproc,*) 'eDiff(A/B)=', ediff(isp), ediffb(isp)
              END DO
            END DO
          END IF
          WRITE(740+iaproc,*) 'NK=', nk, ' NTH=', nth
          esumpart=0
          DO ik=1,nk
            DO ith=1,nth
              isp  = ith + (ik-1)*nth
              esumpart = esumpart + abs(ediff(isp))
            END DO
            IF (isea .eq. 190) THEN
              WRITE(740+iaproc,*) 'IK=', ik, ' eSumDiff=', esumpart
            END IF
          END DO
          WRITE(740+iaproc,*) 'sum(eDiff/VAnew/VAold)=', sum(abs(ediff)), sum(abs(vanew)), sum(abs(vaold))
#endif
 
          IF (b_jgs_block_gauss_seidel) THEN
            va(1:nspec,ip) = real(esum) * iobdp_loc(ip)
#ifdef W3_REF1
            DO ik=1,nk
              DO ith=1,nth
                isp  = ith + (ik-1)*nth
                IF (refpars(3) .LT. 0.5 .AND. iobpd_loc(ith,ip) .EQ. 0 .AND. iobpa_loc(ip) .EQ. 0) THEN
                  va(isp,ip) = vaold(isp,ip) * iobdp_loc(ip) ! Restores reflected action spectra ...
                ENDIF
              ENDDO
            ENDDO
#endif
          ELSE
            u_jac(1:nspec,ip) = esum
          END IF
        ELSE
          esum = va(1:nspec,ip)
        ENDIF ! .NOT. LCONVERGED
 
        IF (b_jgs_terminate_difference) THEN
          sum_new = sum(esum)
          if (sum_new .gt. 0.d0) then
            diffnew = abs(sum(acloc-esum))/sum_new
#ifdef W3_DEBUGFREQSHIFT
            WRITE(740+iaproc,*) 'DiffNew=', diffnew, ' Sum_new=', sum_new
#endif
            p_is_converged = diffnew
          else
            p_is_converged = zero
          endif
#ifdef W3_DEBUGFREQSHIFT
          WRITE(740+iaproc,*) 'p_is_converged=', p_is_converged
#endif
          IF (p_is_converged .lt. b_jgs_diff_thr .and. nbiter .gt. 1) then
            is_converged   = is_converged + 1
            lconverged(ip) = .true.
          ELSE
            lconverged(ip) = .false.
          ENDIF
        END IF
#ifdef W3_DEBUGSRC
        WRITE(740+iaproc,*) 'sum(VA)out=', sum(va(:,ip))
#endif
      END DO ! IP
 
      call print_memcheck(memunit, 'memcheck_____:'//' WW3_PROP SECTION SOLVER LOOP 2')
 
#ifdef W3_DEBUGSOLVERCOH
      WRITE (efile,40) nbiter
40    FORMAT ('PRE_VA_',i4.4,'.txt')
      CALL check_array_integral_nx_r8(offdiag, "OffDiag(np) just check", np)
      !     CALL WRITE_VAR_TO_TEXT_FILE(PRE_VA, eFile)
      CALL check_array_integral_nx_r8(pre_va, "PRE_VA(np) just check", np)
      CALL all_va_integral_print(imod, "VA(np) before exchanges", 0)
#endif
      IF (b_jgs_block_gauss_seidel) THEN
        CALL pdlib_exchange2dreal_zero(va)
      ELSE
        CALL pdlib_exchange2dreal(u_jac)
        va(:,1:npa) = u_jac
      END IF
      call print_memcheck(memunit, 'memcheck_____:'//' WW3_PROP SECTION SOLVER LOOP 3')
      !
      ! Terminate via number of iteration
      !
      IF (b_jgs_terminate_maxiter) THEN
        IF (nbiter .gt. b_jgs_maxiter) THEN
#ifdef W3_DEBUGSOLVER
          WRITE(740+iaproc,*) 'Exiting by TERMINATE_MAXITER'
#endif
          EXIT
        END IF
      END IF
      call print_memcheck(memunit, 'memcheck_____:'//' WW3_PROP SECTION SOLVER LOOP 4')
      !
      ! Terminate via differences
      !
      IF (b_jgs_terminate_difference .and. int(mod(nbiter,10)) == 0) THEN ! Every 10th step check conv.
        CALL mpi_allreduce(is_converged, itmp, 1, mpi_int, mpi_sum, mpi_comm_wcmp, ierr)
        is_converged = itmp
        prop_conv = (dble(nx) - dble(is_converged))/dble(nx) * 100.
#ifdef W3_DEBUGSOLVER
        WRITE(740+iaproc,*) 'solver', nbiter, is_converged, prop_conv, b_jgs_pmin
        FLUSH(740+iaproc)
#endif
        IF (myrank == 0) WRITE(*,*) 'No. of solver iterations', nbiter, is_converged, prop_conv, b_jgs_pmin
        IF (prop_conv .le. b_jgs_pmin + tiny(1.)) THEN
#ifdef W3_DEBUGFREQSHIFT
          WRITE(740+iaproc,*) 'prop_conv=', prop_conv
          WRITE(740+iaproc,*) 'NX=', nx
          WRITE(740+iaproc,*) 'is_converged=', is_converged
          WRITE(740+iaproc,*) 'Exiting by TERMINATE_DIFFERENCE'
#endif
          EXIT
        END IF
      END IF
      call print_memcheck(memunit, 'memcheck_____:'//' WW3_PROP SECTION SOLVER LOOP 5')
      !
      ! Terminate via norm
      !
      IF (b_jgs_terminate_norm) THEN
        sum_l2 =0
        DO ip = 1, np
          ip_glob=iplg(ip)
          IF (iobp_loc(ip).eq.1) THEN
            jsea=jx_to_jsea(ip)
            esi=pdlib_si(ip)
            esum=b_jac(:,ip)
            acloc=va(:,ip)
            isea= mapfs(1,ip_glob)
            esum(:) = esum(:) - aspar_diag(:)*acloc
            DO i = pdlib_ia_p(ip)+1, pdlib_ia_p(ip+1)
              jp=pdlib_ja(i)
              esum(:) = esum(:) - aspar_jac(:,i)*va(:,jp)
            END DO
            IF (fsrefraction) THEN
              cad=cad_the(:,ip)
              DO isp=1,nspec
                ispprevdir=listispprevdir(isp)
                ispnextdir=listispnextdir(isp)
                ea_the = - dtg*esi*max(zero,cad(ispprevdir))
                ec_the =   dtg*esi*min(zero,cad(ispnextdir))
                esum(isp) = esum(isp) - ea_the*va(ispprevdir,ip)
                esum(isp) = esum(isp) - ec_the*va(ispnextdir,ip)
              END DO
            END IF
            IF (fsfreqshift) THEN
              cas=cas_sig(:,ip)
              cp_sig = max(zero,cas)
              cm_sig = min(zero,cas)
              DO ik = 0, nk + 1
#ifdef NOCGTABLE
                CALL wavnu_local(sig(ik),dw(isea),wn1(ik),cg1(ik))
#else
                cg1(ik)  = cg(ik,isea)
                wn1(ik)  = wn(ik,isea)
#endif
              ENDDO
              DO ith=1,nth
                IF (iobpd_loc(ith,ip) .NE. 0) THEN
                  DO ik=2,nk
                    isp  =ith + (ik  -1)*nth
                    ispm1=ith + (ik-1-1)*nth
                    efactm1=cg(ik-1,isea) / cg1(ik)
                    ea_sig= - esi*cp_sig(ispm1)/dmm(ik-1) * efactm1
                    esum(isp) = esum(isp) - ea_sig*va(ispm1,ip)
                  END DO
                  DO ik=1,nk-1
                    isp  =ith + (ik  -1)*nth
                    ispp1=ith + (ik+1-1)*nth
                    efactp1=cg(ik+1,isea) / cg1(ik)
                    ec_sig= esi*cm_sig(ispp1)/dmm(ik) * efactp1
                    esum(isp) = esum(isp) - ec_sig*va(ispp1,ip)
                  END DO
                END IF
              END DO
            END IF
            sum_l2 = sum_l2 + sum(esum*esum)
          END IF
        END DO
        CALL mpi_allreduce(sum_l2, sum_l2_gl, 1, rtype, mpi_sum, mpi_comm_wcmp, ierr)
#ifdef W3_DEBUGSOLVER
        WRITE(740+iaproc,*) 'Sum_L2_gl=', sum_l2_gl
        FLUSH(740+iaproc)
#endif
        IF (sum_l2_gl .le. b_jgs_norm_thr) THEN
#ifdef W3_DEBUGFREQSHIFT
          WRITE(740+iaproc,*) 'Exiting by TERMINATE_NORM'
#endif
          EXIT
        END IF
      END IF
      call print_memcheck(memunit, 'memcheck_____:'//' WW3_PROP SECTION SOLVER LOOP 6')
 
      nbiter = nbiter + 1
 
    END DO ! Open Do Loop ... End of Time Interval
 
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'nbIter=', nbiter, ' B_JGS_MAXITER=', b_jgs_maxiter
    FLUSH(740+iaproc)
#endif
    ! Tihs is below also goes into the matrix ... like the wave boundary ...
    DO ip = 1, npa
#ifdef W3_DEBUGSRC
      WRITE(740+iaproc,*) 'IOBPD loop, Before, sum(VA)=', sum(va(:,ip))
#endif
      DO isp=1,nspec
        ith    = 1 + mod(isp-1,nth)
        va(isp,ip)=max(zero, va(isp,ip))*iobdp_loc(ip)*dble(iobpd_loc(ith,ip))
#ifdef W3_REF1
        IF (refpars(3).LT.0.5.AND.iobpd_loc(ith,ip).EQ.0.AND.iobpa_loc(ip).EQ.0) THEN
          va(isp,ip) = vaold(isp,ip) ! restores reflected boundary values
        ENDIF
#endif
      END DO
#ifdef W3_DEBUGSRC
      WRITE(740+iaproc,*) 'IOBPD loop, After, sum(VA)=', sum(va(:,ip))
#endif
    END DO
#ifdef W3_DEBUGSOLVERCOH
    CALL all_va_integral_print(imod, "VA(npa) after loop", 1)
#endif
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'FLBPI=', flbpi
    FLUSH(740+iaproc)
#endif
 
    DO jsea=1, nseal
 
      ip      = jsea
      ip_glob = iplg(ip)
      isea    = mapfs(1,ip_glob)
      !
#ifdef W3_DEBUGSRC
      intdiff=0
      sumvs=0
      sumvd=0
      sumvain=0
      sumvaout=0
      sumvaw3srce=0
      sumacout=0
#endif
      !
      DO isp=1,nspec
 
        ik     = 1 + (isp-1)/nth
#ifdef NOCGTABLE
        CALL wavnu_local(sig(ik),dw(isea),wn1(ik),cg1(ik))
#else
        cg1(ik)    = cg(ik,isea)
#endif
        eva = max( zero ,cg1(ik)/clats(isea)*real(va(isp,ip)) )
        evo = max( zero ,cg1(ik)/clats(isea)*real(vaold(isp,jsea)) )
#ifdef W3_DEBUGSRC
        sumacout=sumacout + real(va(isp,ip))
        vs_w3srce = vstot(isp,jsea) * dtg / max(1., (1. - dtg*vdtot(isp,jsea)))
        eva_w3srce = max(0., va(isp,jsea) + vs_w3srce)
        intdiff = intdiff + abs(eva - eva_w3srce)
        acsolve=b_jac(isp,ip)/aspar_jac(isp,pdlib_i_diag(ip))
        eb=va(isp,jsea) + dtg*(vstot(isp,jsea) - vdtot(isp,jsea)*va(isp,jsea))
        evasolve=max(0., cg(ik,isea)/clats(isea)*acsolve)
        vasolve(isp)=evasolve
        sumvs = sumvs + abs(vstot(isp,jsea))
        sumvd = sumvd + abs(vdtot(isp,jsea))
        sumvain = sumvain + abs(va(isp,jsea))
        sumvaout = sumvaout + abs(eva)
        sumvaw3srce = sumvaw3srce + abs(eva_w3srce)
#endif
        vaold(isp,jsea) = evo
        va(isp,jsea) = eva
      END DO
#ifdef W3_DEBUGSRC
      WRITE(740+iaproc,*) 'ISEA=', isea, ' IntDiff=', intdiff, ' DTG=', dtg
      IF (isea .eq. testnode) THEN
        DO isp=1,nspec
          WRITE(740+iaproc,*) 'ISP=', isp, 'VA/VAsolve=', va(isp,jsea), vasolve(isp)
        END DO
      END IF
      WRITE(740+iaproc,*) 'SHAVE=', shavetot(jsea)
      WRITE(740+iaproc,*) 'Sum(VS/VD)=', sumvs, sumvd
      WRITE(740+iaproc,*) 'min/max/sum(VS)=', minval(vstot(:,jsea)), maxval(vstot(:,jsea)), sum(vstot(:,jsea))
      WRITE(740+iaproc,*) 'min/max/sum(VD)=', minval(vdtot(:,jsea)), maxval(vdtot(:,jsea)), sum(vdtot(:,jsea))
      WRITE(740+iaproc,*) 'min/max/sum(VA)=', minval(va(:,jsea)), maxval(va(:,jsea)), sum(va(:,jsea))
      WRITE(740+iaproc,*) 'min/max/sum(VAsolve)=', minval(vasolve), maxval(vasolve), sum(vasolve)
      WRITE(740+iaproc,*) 'SumVA(in/out/w3srce)=', sumvain, sumvaout, sumvaw3srce
      WRITE(740+iaproc,*) 'SumACout=', sumacout
#endif
 
      IF (flsou) THEN
        IF (b_jgs_limiter) THEN
 
          DO isp=1,nspec
            ik   = 1 + (isp-1)/nth
            spec(isp) = vaold(isp,jsea)
          ENDDO
#ifdef W3_ST4
          CALL w3spr4 (spec, cg1, wn1, emean, fmean, fmean1, wnmean, &
               amax, u10(isea), u10d(isea),                           &
#ifdef W3_FLX5
               taua, tauadir, dair,                             &
#endif
               ustar, ustdir,                                  &
               tauwx, tauwy, cd, z0, charn, llws, fmeanws, dlwmean)
#endif
 
          dam = 0.
          DO ik=1, nk
            dam(1+(ik-1)*nth) = 0.0081*0.1 / ( 2 * sig(ik) * wn(ik,isea)**3 * cg(ik,isea)) * cg1(ik) / clats(isea)
          END DO
          !
          DO ik=1, nk
            is0    = (ik-1)*nth
            DO ith=2, nth
              dam(ith+is0) = dam(1+is0)
            END DO
          END DO
 
          dam2 = 0.
          DO ik=1, nk
            jac2     = 1./tpi/sig(ik)
            frlocal  = sig(ik)*tpiinv
            dam2(1+(ik-1)*nth) = 1e-06 * grav/frlocal**4 * ustar * max(fmeanws,fmean) * dtg * jac2 * cg1(ik) / clats(isea)
          END DO
          DO ik=1, nk
            is0  = (ik-1)*nth
            DO ith=2, nth
              dam2(ith+is0) = dam2(1+is0)
            END DO
          END DO
 
          DO ik = 1, nk
            DO ith = 1, nth
              isp = ith + (ik-1)*nth
              newdac     = va(isp,ip) - vaold(isp,jsea)
              maxdac     = max(dam(isp),dam2(isp))
              newdac     = sign(min(maxdac,abs(newdac)), newdac)
              va(isp,ip) = max(0., vaold(isp,ip) + newdac)
            ENDDO
          ENDDO
        ENDIF ! B_JGS_LIMITER
      ENDIF  ! FLSOU
    END DO ! JSEA
 
#ifdef WEIGHTS
    INQUIRE ( file='weights.ww3', exist = lexist )
    if (.not. lexist) then
      ipitergl = 0
      ipiterout = 0
      DO ip = 1, np
        ipitergl(iplg(ip)) = ipiter(ip)
      END DO
      call mpi_reduce(ipitergl,ipiterout,np_global,mpi_int,mpi_sum,0,mpi_comm_wcmp,ierr)
      if (myrank == 0) tHEN
        OPEN(100001,file='weights.ww3',form='FORMATTED',status='unknown')
        do ip = 1, np_global
          write(100001,*) ipiterout(ip)
        enddo
        CLOSE(100001)
      endif
    endif
#endif
    !
    call print_memcheck(memunit, 'memcheck_____:'//' WW3_PROP SECTION LOOP 7')
    !
#ifdef W3_DEBUGSRC
    DO jsea=1,nseal
      WRITE(740+iaproc,*) 'JSEA=', jsea
      WRITE(740+iaproc,*) 'min/max/sum(VA)=', minval(va(:,jsea)), maxval(va(:,jsea)), sum(va(:,jsea))
    END DO
    WRITE(740+iaproc,*) 'min/max/sum(VAtot)=', minval(va), maxval(va), sum(va)
#endif
 
 
#ifdef W3_DEBUGSOLVER
    WRITE(740+iaproc,*) 'PDLIB_JACOBI_GAUSS_SEIDEL_BLOCK, end'
    FLUSH(740+iaproc)
#endif
  END SUBROUTINE pdlib_jacobi_gauss_seidel_block
  !/ ------------------------------------------------------------------- /
  SUBROUTINE pdlib_explicit_block(IMOD, FACX, FACY, DTG, VGX, VGY, LCALC)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Explicit block solver
    !  2. Method : It uses the n-scheme and the idea is to reduce latency due
    !              to DD communication and increase vectorization level on the
    !              single core
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
    !
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    USE w3gdatmd, ONLY: nk, nth, nspec, sig, dth, esin, ecos, nseal, fsbccfl, clats, mapfs
    USE w3gdatmd, ONLY: iobp_loc, iobpd_loc, iobpa_loc, iobdp_loc, mapsf, nsea
    USE w3odatmd, ONLY: ndse, ndst, flbpi, nbi, tbpi0, tbpin, isbpi, bbpi0, bbpin
    USE w3adatmd, ONLY: dw, cx, cy, mpi_comm_wcmp
    USE w3idatmd, ONLY: flcur, fllev
    USE w3wdatmd, ONLY: va
    USE w3dispmd, ONLY: wavnu3
    USE w3odatmd, ONLY : iaproc
#ifdef W3_PDLIB
    USE yowelementpool, only: ne, ine
    USE yownodepool, only: np, npa, pdlib_ien, pdlib_si, iplg
    use yowdatapool, only: rtype
    use yowexchangemodule, only: pdlib_exchange2dreal_zero, pdlib_exchange2dreal
    use yowrankmodule,     only: ipgl_npa
    USE mpi, only : mpi_min
#endif
#ifdef W3_REF1
    USE w3gdatmd, only: refpars
#endif
 
    IMPLICIT NONE
 
    LOGICAL, INTENT(IN) :: LCALC
 
    INTEGER, INTENT(IN) :: IMOD
 
    REAL, INTENT(IN)    :: FACX, FACY, DTG, VGX, VGY
 
    REAL              :: KTMP(3), UTILDE(NTH), ST(NTH,NPA)
    REAL              :: FL11(NTH), FL12(NTH), FL21(NTH), FL22(NTH), FL31(NTH), FL32(NTH), KKSUM(NTH,NPA)
    REAL              :: FL111(NTH), FL112(NTH), FL211(NTH), FL212(NTH), FL311(NTH), FL312(NTH)
 
    REAL              :: KSIG(NPA), CGSIG(NPA), CXX(NTH,NPA), CYY(NTH,NPA)
    REAL              :: LAMBDAX(NTH), LAMBDAY(NTH)
    REAL              :: DTMAX(NTH), DTMAXEXP(NTH), DTMAXOUT, DTMAXGL
    REAL              :: FIN(1), FOUT(1), REST, CFLXY, RD1, RD2, RD10, RD20
    REAL              :: UOLD(NTH,NPA), U(NTH,NPA)
 
    REAL, PARAMETER   :: ONESIXTH = 1.0/6.0
    REAL, PARAMETER   :: ZERO = 0.0
    REAL, PARAMETER   :: THR = 1.0e-12
 
    INTEGER           :: IK, ISP, ITH, IE, IP, IT, IBI, NI(3), I1, I2, I3, JX, IERR, IP_GLOB, ISEA
    !
    ! 1.b Initialize arrays
    !
    ! 2.  Calculate velocities ---------------- *
    !
    !   2a. Vectorized for all points looping over each wave number (maybe do a dirty save will be nice!)
    !
 
    DO ik = 1, nk
 
      IF (lcalc) THEN
 
        DO ip = 1, npa
          CALL wavnu3 (sig(ik), dw(iplg(ip)), ksig(ip), cgsig(ip))
        ENDDO
 
        DO ip = 1, npa
          DO ith = 1, nth
            isea = iplg(ip)
            cxx(ith,ip) = cgsig(ip) * facx * ecos(ith) / clats(isea)
            cyy(ith,ip) = cgsig(ip) * facy * esin(ith)
          ENDDO ! ith
          IF (flcur) THEN
            DO ith = 1, nth
              isea = iplg(ip)
              IF (iobp_loc(ip) .GT. 0) THEN
                cxx(ith,ip) = cxx(ith,ip) + facx * cx(isea)/clats(isea)
                cyy(ith,ip) = cyy(ith,ip) + facy * cy(isea)
              ENDIF
            ENDDO !ith
          ENDIF
        ENDDO
 
        DO ie = 1, ne
 
          ni  = ine(:,ie)
 
          i1  = ni(1)
          i2  = ni(2)
          i3  = ni(3)
 
          DO ith = 1, nth
            lambdax(ith) = onesixth *(cxx(ith,i1)+cxx(ith,i2)+cxx(ith,i3)) ! Linearized advection speed in X and Y direction
            lambday(ith) = onesixth *(cyy(ith,i1)+cyy(ith,i2)+cyy(ith,i3))
            kelem1(ith,ie,ik) = lambdax(ith) * pdlib_ien(1,ie) + lambday(ith) * pdlib_ien(2,ie) ! K-Values - so called Flux Jacobians
            kelem2(ith,ie,ik) = lambdax(ith) * pdlib_ien(3,ie) + lambday(ith) * pdlib_ien(4,ie)
            kelem3(ith,ie,ik) = lambdax(ith) * pdlib_ien(5,ie) + lambday(ith) * pdlib_ien(6,ie)
            ktmp(1)           = kelem1(ith,ie,ik) ! Extract
            ktmp(2)           = kelem2(ith,ie,ik)
            ktmp(3)           = kelem3(ith,ie,ik)
            nm(ith,ie,ik)     = - 1.d0/min(-thr,sum(min(zero,ktmp))) ! N-Values
            kelem1(ith,ie,ik) = max(zero,ktmp(1))
            kelem2(ith,ie,ik) = max(zero,ktmp(2))
            kelem3(ith,ie,ik) = max(zero,ktmp(3))
          ENDDO
 
          fl11  = cxx(:,i2) * pdlib_ien(1,ie) + cyy(:,i2) * pdlib_ien(2,ie) ! Weights for Simpson Integration
          fl12  = cxx(:,i3) * pdlib_ien(1,ie) + cyy(:,i3) * pdlib_ien(2,ie)
          fl21  = cxx(:,i3) * pdlib_ien(3,ie) + cyy(:,i3) * pdlib_ien(4,ie)
          fl22  = cxx(:,i1) * pdlib_ien(3,ie) + cyy(:,i1) * pdlib_ien(4,ie)
          fl31  = cxx(:,i1) * pdlib_ien(5,ie) + cyy(:,i1) * pdlib_ien(6,ie)
          fl32  = cxx(:,i2) * pdlib_ien(5,ie) + cyy(:,i2) * pdlib_ien(6,ie)
 
          fl111 = 2.d0 * fl11 + fl12
          fl112 = 2.d0 * fl12 + fl11
          fl211 = 2.d0 * fl21 + fl22
          fl212 = 2.d0 * fl22 + fl21
          fl311 = 2.d0 * fl31 + fl32
          fl312 = 2.d0 * fl32 + fl31
 
          flall1(:,ie,ik) = (fl311 + fl212) * onesixth + kelem1(:,ie,ik)
          flall2(:,ie,ik) = (fl111 + fl312) * onesixth + kelem2(:,ie,ik)
          flall3(:,ie,ik) = (fl211 + fl112) * onesixth + kelem3(:,ie,ik)
 
        ENDDO  ! IE
 
        kksum = zero
        DO ie = 1, ne
          ni = ine(:,ie)
          DO ith = 1, nth
            kksum(ith,ni(1)) = kksum(ith,ni(1)) + kelem1(ith,ie,ik)
            kksum(ith,ni(2)) = kksum(ith,ni(2)) + kelem2(ith,ie,ik)
            kksum(ith,ni(3)) = kksum(ith,ni(3)) + kelem3(ith,ie,ik)
          ENDDO
        END DO
 
        dtmaxexp = 1.e10
        dtmax    = 1.e10
        DO ip = 1, npa
          IF (iobp_loc(ip) .EQ. 1 .OR. fsbccfl) THEN
            DO ith = 1, nth
              dtmaxexp(ith) = pdlib_si(ip)/max(thr,kksum(ith,ip)*iobdp_loc(ip))
              dtmax(ith)    = min(dtmax(ith),dtmaxexp(ith))
            ENDDO
            dtmaxout = minval(dtmax)
          ENDIF
        END DO
 
        fin(1) = dtmaxout
        CALL mpi_allreduce(fin,fout,1,rtype,mpi_min,mpi_comm_wcmp,ierr)
        dtmaxgl = fout(1)
 
        cflxy = dble(dtg)/dtmaxgl
        rest  = abs(mod(cflxy,1.0d0))
        IF (rest .LT. thr) THEN
          iter(ik) = abs(nint(cflxy))
        ELSE IF (rest .GT. thr .AND. rest .LT. 0.5d0) THEN
          iter(ik) = abs(nint(cflxy)) + 1
        ELSE
          iter(ik) = abs(nint(cflxy))
        END IF
 
        DO ip = 1, npa
          dtsi(ip) = dble(dtmaxgl)/dble(iter(ik))/pdlib_si(ip) ! Some precalculations for the time integration.
        END DO
 
      END IF ! LCALC
 
      ! Exact and convert Wave Action - should be some subroutine function or whatever
      do ip = 1,npa
        isp = 0
        do ith = 1,nth
          isp = ith + (ik-1)*nth
          u(ith,ip) = va(isp,ip) / cgsig(ip) * clats(iplg(ip))
        enddo
      enddo
      CALL pdlib_exchange2dreal(u)
 
      DO it = 1, iter(ik)
        st = zero
        DO ie = 1, ne
          ni  = ine(:,ie)
          DO ith = 1, nth
            utilde(ith)   = nm(ith,ie,ik) * (flall1(ith,ie,ik)*u(ith,ni(1)) + flall2(ith,ie,ik)*u(ith,ni(2)) + flall3(ith,ie,ik)*u(ith,ni(3)))
            st(ith,ni(1)) = st(ith,ni(1)) + kelem1(ith,ie,ik) * (u(ith,ni(1)) - utilde(ith)) ! the 2nd term are the theta values of each node ...
            st(ith,ni(2)) = st(ith,ni(2)) + kelem2(ith,ie,ik) * (u(ith,ni(2)) - utilde(ith)) ! the 2nd term are the theta values of each node ...
            st(ith,ni(3)) = st(ith,ni(3)) + kelem3(ith,ie,ik) * (u(ith,ni(3)) - utilde(ith)) ! the 2nd term are the theta values of each node ...
          ENDDO
        END DO ! IE
        DO ip = 1, npa
          DO ith = 1, nth
            u(ith,ip) = max(zero,u(ith,ip)-dtsi(ip)*st(ith,ip)*(1-iobpa_loc(ip)))*iobpd_loc(ith,ip)*iobdp_loc(ip)
#ifdef W3_REF1
            IF (refpars(3).LT.0.5.AND.iobpd_loc(ith,ip).EQ.0.AND.iobpa_loc(ip).EQ.0) u(ith,ip) = uold(ith,ip) ! restores reflected boundary values
#endif
          ENDDO
        ENDDO ! IP
 
        IF ( flbpi ) THEN
          DO ith = 1, nth
            isp = ith + (ik-1) * nth
            rd1 = rd10 - dtg * real(iter(ik)-it)/real(iter(ik))
            rd2 = rd20
            IF ( rd2 .GT. 0.001 ) THEN
              rd2    = min(1.,max(0.,rd1/rd2))
              rd1    = 1. - rd2
            ELSE
              rd1    = 0.
              rd2    = 1.
            END IF
            DO ibi = 1, nbi
              ip_glob = mapsf(isbpi(ibi),1)
              jx      = ipgl_npa(ip_glob)
              IF (jx .gt. 0) THEN
                u(ith,jx) = ( rd1*bbpi0(isp,ibi) + rd2*bbpin(isp,ibi) ) / cgsig(isbpi(ibi)) * clats(isbpi(ibi))
              END IF
            END DO
          ENDDO
        ENDIF ! FLBPI
 
        CALL pdlib_exchange2dreal(u)
 
      ENDDO ! IT
 
      ! Exact and convert Wave Action
      do ip = 1,npa
        isp = 0
        do ith = 1,nth
          isp = ith + (ik-1)*nth
          va(isp,ip) = u(ith,ip) * cgsig(ip) / clats(iplg(ip))
        end do
      end do
 
    ENDDO ! IK
 
  END SUBROUTINE pdlib_explicit_block
  !/ ------------------------------------------------------------------- /
  SUBROUTINE block_solver_explicit_init()
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Initialization of the block solver
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    USE w3gdatmd, only:  nth, nk
#ifdef W3_PDLIB
    USE yownodepool, only: np, npa
    USE yowelementpool, only: ne
#endif
    IMPLICIT NONE
    !/
 
    ALLOCATE(flall1(nth,ne,nk), flall2(nth,ne,nk), flall3(nth,ne,nk))
    ALLOCATE(kelem1(nth,ne,nk), kelem2(nth,ne,nk), kelem3(nth,ne,nk))
    ALLOCATE(nm(nth,ne,nk), dtsi(npa))
    ALLOCATE(iter(nk))
 
    !/ ------------------------------------------------------------------- /
    !/
  END SUBROUTINE block_solver_explicit_init
  !/ ------------------------------------------------------------------- /
  SUBROUTINE block_solver_init(IMOD)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Initialization of the block solver
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !
    USE constants, only : lpdlib, tpi, tpiinv
    USE w3gdatmd, only: mapsf, nseal, dmin, iobdp, mapsta, iobp, mapfs, nx
    USE w3adatmd, only: dw
    USE w3parall, only: init_get_isea
    USE yownodepool, only: iplg, np
    USE yowfunction, only: pdlib_abort
    use yownodepool, only: npa
    USE w3gdatmd, only: b_jgs_use_jacobi
    USE w3parall, only : listispprevdir, listispnextdir
    USE w3parall, only : listispprevfreq, listispnextfreq
    USE w3gdatmd, only: nspec, nth, nk
    USE w3gdatmd, only: fstotalimp
    USE w3odatmd, only: iaproc
    !/
    INTEGER, INTENT(IN) :: IMOD
    !
    !/ ------------------------------------------------------------------- /
    !/
    INTEGER ISP, ITH, IK, ISPprevFreq, ISPnextFreq
    INTEGER NewISP, JTH, istat
 
    pos_trick(1,1) = 2
    pos_trick(1,2) = 3
    pos_trick(2,1) = 3
    pos_trick(2,2) = 1
    pos_trick(3,1) = 1
    pos_trick(3,2) = 2
 
#ifdef W3_DEBUGINIT
    WRITE(740+iaproc,*) 'BLOCK_SOLVER_INIT, step 1'
    FLUSH(740+iaproc)
#endif
    ALLOCATE(listispnextdir(nspec), listispprevdir(nspec), listispnextfreq(nspec), listispprevfreq(nspec),stat=istat)
    IF (istat /= 0) CALL pdlib_abort(8)
#ifdef W3_DEBUGINIT
    WRITE(740+iaproc,*) 'BLOCK_SOLVER_INIT, step 2'
    FLUSH(740+iaproc)
#endif
    DO isp=1,nspec
      ith    = 1 + mod(isp-1,nth)
      ik     = 1 + (isp-1)/nth
      IF (ik .eq. 1) THEN
        ispprevfreq=-1
      ELSE
        ispprevfreq=ith + (ik-1 -1)*nth
      END IF
      listispprevfreq(isp)=ispprevfreq
      IF (ik .eq. nk) THEN
        ispnextfreq=-1
      ELSE
        ispnextfreq=ith + (ik+1 -1)*nth
      END IF
      listispnextfreq(isp)=ispnextfreq
      !
      IF (ith .eq. 1) THEN
        jth=nth
      ELSE
        jth=ith-1
      ENDIF
      newisp=jth + (ik-1)*nth
      listispprevdir(isp)=newisp
      IF (ith .eq. nth) THEN
        jth=1
      ELSE
        jth=ith+1
      ENDIF
      newisp=jth + (ik-1)*nth
      listispnextdir(isp)=newisp
    END DO
#ifdef W3_DEBUGINIT
    WRITE(740+iaproc,*) 'BLOCK_SOLVER_INIT, step 3'
    FLUSH(740+iaproc)
#endif
    IF (fstotalimp .and. b_jgs_use_jacobi) THEN
#ifdef W3_DEBUGINIT
      WRITE(740+iaproc,*) 'BLOCK_SOLVER_INIT, step 4'
      FLUSH(740+iaproc)
#endif
      CALL jacobi_init(imod)
#ifdef W3_DEBUGINIT
      WRITE(740+iaproc,*) 'BLOCK_SOLVER_INIT, step 5'
      FLUSH(740+iaproc)
#endif
    END IF
#ifdef W3_DEBUGINIT
    WRITE(740+iaproc,*) 'BLOCK_SOLVER_INIT, step 6'
    FLUSH(740+iaproc)
#endif
  END SUBROUTINE block_solver_init
  !/ ------------------------------------------------------------------ /
  SUBROUTINE set_iobdp_pdlib
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Set depth pointer
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    USE constants, only : lpdlib
    USE w3gdatmd, only: mapsf, nseal, dmin, mapsta, nx
    USE w3gdatmd, only: iobp_loc, iobpd_loc, iobpa_loc, iobdp_loc
    USE w3adatmd, only: dw
    USE w3parall, only: init_get_isea
    USE yownodepool, only: iplg, np, npa
    !/
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local PARAMETERs
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
    !
    INTEGER :: JSEA, ISEA, IX, IP, IP_glob
    real*8, PARAMETER :: dthr = 10e-6
#ifdef W3_S
    CALL strace (ient, 'SETDEPTH_PDLIB')
#endif
    DO jsea=1,npa
      ip = jsea
      ip_glob = iplg(ip)
      IF (dw(ip_glob) .LT. dmin + dthr) THEN
        iobdp_loc(ip)  = 0
      ELSE
        iobdp_loc(ip)  = 1
      ENDIF
    END DO
    !/
    !/ End of SETDEPTH_PDLIB --------------------------------------------- /
    !/
  END SUBROUTINE set_iobdp_pdlib
 
 
  SUBROUTINE set_iobpa_pdlib
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Set depth pointer
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    USE constants, only : lpdlib
    USE w3gdatmd, only: mapsf, nseal, dmin, mapsta, nx
    USE w3gdatmd, only: iobp_loc, iobpd_loc, iobpa_loc, iobdp_loc
    USE w3adatmd, only: dw
    USE w3parall, only: init_get_isea
    USE yownodepool, only: iplg, np
    !/
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local PARAMETERs
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
    !
    INTEGER :: JSEA, ISEA, IX, IP, IP_glob
    real*8, PARAMETER :: dthr = 10e-6
#ifdef W3_S
    CALL strace (ient, 'SETDEPTH_PDLIB')
#endif
    DO jsea=1,nseal
      ip_glob = iplg(jsea)
      IF (mapsta(1,ip_glob).EQ.2) THEN
        iobpa_loc(jsea) = 1
      ELSE
        iobpa_loc(jsea) = 0
      ENDIF
    END DO
    !/
    !/ End of SETDEPTH_PDLIB --------------------------------------------- /
    !/
  END SUBROUTINE set_iobpa_pdlib
 
 
  SUBROUTINE set_ug_iobp_pdlib_init()
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |        Fabrice Ardhuin            |
    !/                  |        Aron Roland                |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :         17-Apr-2016 |
    !/                  +-----------------------------------+
    !/
    !/    23-Aug-2011 : Origination.                        ( version 4.04 )
    !/    17-Apr-2016 : Uses optimized boundary detection   ( version 5.10 )
    !/
    !  1. Purpose :
    !
    !     Redefines the values of the boundary points and angle pointers
    !     based on the MAPSTA array
    !
    !  2. Method :
    !
    !     Adapted boundary detection from A. Roland and M. Dutour (WWM code)
    !
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !     Local variables.
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
 
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      WW3_GRID  Prog. WW3_GRID Grid preprocessor
    !      W3ULEV    Subr. W3UPDTMD Water level update
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !
    !       None.
    !
    !  7. Remarks :
    !
    !  8. Structure :
    !
    !
    !  9. Switches :
    !
    !       !/S     Enable subroutine tracing.
    !
    !
    ! 10. Source code :
    !/ ------------------------------------------------------------------- /
    !/
    !
    USE constants
    !
    !
    USE w3gdatmd, only: nx, ny, nsea, mapfs,                        &
         nk, nth, dth, xfr, mapsta, countri,         &
         ecos, esin, ien, ntri, trigp,               &
         iobp,iobpd, iobpa,                          &
#ifdef w3_ref1
         refpars, reflc, refld,                      &
#endif
         angle0, angle, nseal
 
    USE w3odatmd, only: tbpi0, tbpin, flbpi
    USE w3adatmd, only: cg, cx, cy, atrnx, atrny, itime, cflxymax
    USE w3gdatmd, only: iobp_loc, iobpd_loc, iobpa_loc, iobdp_loc
    USE w3idatmd, only: flcur
    USE w3odatmd, only : iaproc
    USE yownodepool,    only: pdlib_si, pdlib_ien, pdlib_tria, ipgl, iplg, npa, np
    use yowelementpool, only: ne, ine
    use yowexchangemodule, only : pdlib_exchange1dreal
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    INTEGER                 :: ITH, IX, I, J, IP, IE, NDIRSUM
    REAL (KIND = 8)         :: cossum, sinsum
    REAL (KIND = 8)         :: dirmin, dirmax, shift, tempo, dircoast
    REAL (KIND = 8)         :: x1, x2, y1, y2, dxp1, dxp2, dxp3
    REAL (KIND = 8)         :: dyp1, dyp2, dyp3, edet1, edet2, evx, evy
    REAL(KIND=8), parameter :: thr    = tiny(1.)
    INTEGER                 :: I1, I2, I3
    INTEGER                 :: ITMP(NX), NEXTVERT(NX), PREVVERT(NX)
    INTEGER                 :: MAX_IOBPD, MIN_IOBPD
    REAL                    :: rtmp(NPA)
    CHARACTER(60) :: FNAME
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/ ------------------------------------------------------------------- /
    !
    !
    DO ie = 1, ne
      i1   =   ine(1,ie)
      i2   =   ine(2,ie)
      i3   =   ine(3,ie)
      dxp1 =   pdlib_ien(6,ie)
      dyp1 = - pdlib_ien(5,ie)
      dxp2 =   pdlib_ien(2,ie)
      dyp2 = - pdlib_ien(1,ie)
      dxp3 =   pdlib_ien(4,ie)
      dyp3 = - pdlib_ien(3,ie)
      DO ith = 1, nth
        evx = ecos(ith)
        evy = esin(ith)
        DO i = 1, 3
          IF (i .eq. 1) THEN
            x1 =   dxp1
            y1 =   dyp1
            x2 = - dxp3
            y2 = - dyp3
            ip =   i1
          ELSE IF (i.eq.2) THEN
            x1 =   dxp2
            y1 =   dyp2
            x2 = - dxp1
            y2 = - dyp1
            ip =   i2
          ELSE IF (i.eq.3) THEN
            x1 =   dxp3
            y1 =   dyp3
            x2 = - dxp2
            y2 = - dyp2
            ip =   i3
          END IF
          IF (iobp_loc(ip) .eq. 0) THEN ! physical boundary
            edet1 = thr-x1*evy+y1*evx
            edet2 = thr+x2*evy-y2*evx
            IF ((edet1.gt.0.).and.(edet2.gt.0.)) THEN
              ! this is the case of waves going towards the boundary ...
              iobpd_loc(ith,ip) = 1
            ENDIF
          ELSE ! water ...
            iobpd_loc(ith,ip) = 1
          END IF
        END DO
      END DO
    END DO
 
    DO ith = 1, nth
      rtmp = real(iobpd_loc(ith,1:npa))
      CALL pdlib_exchange1dreal(rtmp)
      iobpd_loc(ith,1:npa) = int(rtmp)
    ENDDO
    max_iobpd = maxval(iobpd_loc)
    min_iobpd = minval(iobpd_loc)
 
    IF (max_iobpd .gt. 1 .OR. min_iobpd .lt. 0) THEN
      WRITE(*,*) 'MAX_IOBPD - MIN_IOBPD', max_iobpd, min_iobpd
      stop 'MAX_IOBPD ERRROR'
    ENDIF
 
#ifdef W3_DEBUGSETUGIOBP
    WRITE(740+iaproc,*) 'Calling SETUGIOBP, step 5'
    FLUSH(740+iaproc)
#endif
    DO ip = 1, npa
      IF ( iobpa_loc(ip) .eq. 1 .OR. iobp_loc(ip) .eq. 3 .OR. iobp_loc(ip) .eq. 4) iobpd_loc(:,ip) = 1
    END DO
#ifdef W3_DEBUGSETUGIOBP
    WRITE(740+iaproc,*) 'Calling SETUGIOBP, step 7'
    FLUSH(740+iaproc)
#endif
    !--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    ! 3. Updates the reflection direction and sharp / flat shoreline angle
 
#ifdef W3_REF1
    !
    ! Finds the shoreline direction from IOBPD
    !
    reflc(1,:)= 0.
    refld(:,:)= 1
    DO ip=1,nx
      IF (iobp(ip).EQ.0.AND.mapsta(1,ip).EQ.1) THEN
        cossum=0.
        sinsum=0.
        ndirsum=0.
        DO ith=1,nth
          cossum=cossum+iobpd(ith,ip)*ecos(ith)
          sinsum=sinsum+iobpd(ith,ip)*esin(ith)
          ndirsum=ndirsum+iobpd(ith,ip)
        END DO
        dircoast=atan2(sinsum, cossum)
        refld(1,mapfs(1,ip)) = 1+mod(nth+nint(dircoast/dth),nth)
        refld(2,mapfs(1,ip)) = 4-max(2,nint(4.*real(ndirsum)/real(nth)))
        reflc(1,mapfs(1,ip))= refpars(1)
      END IF
    END DO
#endif
#ifdef W3_DEBUGSETUGIOBP
    WRITE(740+iaproc,*) 'Calling SETUGIOBP, step 8'
    FLUSH(740+iaproc)
#endif
  END SUBROUTINE set_ug_iobp_pdlib_init
  !/ ------------------------------------------------------------------- /
  !/ ------------------------------------------------------------------- /
  SUBROUTINE block_solver_finalize
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Finalize Solver
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    USE w3gdatmd, only: b_jgs_use_jacobi
    !/
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local PARAMETERs
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
    !
#ifdef W3_S
    CALL strace (ient, 'BLOCK_SOLVER_FINALIZE')
#endif
    IF (b_jgs_use_jacobi) THEN
      CALL jacobi_finalize
    END IF
    !/
    !/ End of SETDEPTH_PDLIB --------------------------------------------- /
    !/
  END SUBROUTINE block_solver_finalize
  !/ ------------------------------------------------------------------- /
  SUBROUTINE deallocate_pdlib_global(IMOD)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Init jacobi solver
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    USE w3gdatmd, only: nspec, b_jgs_block_gauss_seidel, grids
    use yownodepool, only: pdlib_nnz, npa, np
    USE yowfunction, only: pdlib_abort
    USE w3gdatmd, only: nth, nk, nseal
    USE w3parall, only: imem
#ifdef W3_DEBUGINIT
    USE w3odatmd, only : iaproc
#endif
    !/
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local PARAMETERs
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
    INTEGER, INTENT(IN) :: IMOD
 
    DEALLOCATE (                 &
                                ! GRIDS(IMOD)%TRIGP,    &
         grids(imod)%SI,         &
         grids(imod)%TRIA,       &
         grids(imod)%CROSSDIFF,  &
         grids(imod)%IEN,        &
         grids(imod)%LEN,        &
         grids(imod)%ANGLE,      &
         grids(imod)%ANGLE0,     &
         grids(imod)%CCON,       &
         grids(imod)%COUNTCON,   &
         grids(imod)%INDEX_CELL, &
         grids(imod)%IE_CELL,    &
         grids(imod)%POS_CELL,   &
         grids(imod)%IAA,        &
         grids(imod)%JAA,        &
         grids(imod)%POSI,       &
         grids(imod)%I_DIAG,     &
         grids(imod)%JA_IE,      &
                                !GRIDS(IMOD)%IOBP,      &
                                !GRIDS(IMOD)%IOBPD,     &
         grids(imod)%IOBDP,      &
         grids(imod)%IOBPA  )
    !/
    !/ End of DEALLOCATE_PDLIB_GLOBAL ------------------------------------------------ /
    !/
  END SUBROUTINE deallocate_pdlib_global
 
  SUBROUTINE ergout(FHNDL, ERGNAME)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :      01-Januar-2023 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 7.xx )
    !/
    !  1. Purpose : write spatial out for xfn
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    USE w3gdatmd, only: nspec, nth, nk, nseal
    USE w3wdatmd, only: va, vaold
    IMPLICIT NONE
 
    INTEGER, INTENT(IN)           :: FHNDL
    CHARACTER(LEN=*), INTENT(IN) :: ERGNAME
    REAL    :: SUMVA(NSEAL)
    INTEGER :: JSEA
 
    IF (linit_output) THEN
      OPEN(fhndl, file  = trim(ergname), form = 'UNFORMATTED')
      linit_output = .false.
    ENDIF
 
    rtime = rtime + 1.
 
    DO jsea = 1, nseal
      sumva(jsea) = sum(va(:,jsea))
    ENDDO
 
    WRITE(fhndl)  rtime
    WRITE(fhndl) (sumva(jsea), sumva(jsea), sumva(jsea), jsea = 1, nseal)
 
  END SUBROUTINE ergout
  !/ ------------------------------------------------------------------- /
  SUBROUTINE jacobi_init(IMOD)
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Init jacobi solver
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, only: strace
#endif
    USE w3gdatmd, only: nspec, b_jgs_block_gauss_seidel, grids
    use yownodepool, only: pdlib_nnz, npa, np
    USE yowfunction, only: pdlib_abort
    USE w3gdatmd, only: nth, nk, nseal
    USE w3parall, only: imem
#ifdef W3_DEBUGINIT
    USE w3odatmd, only : iaproc
#endif
    !/
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local PARAMETERs
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
    INTEGER, INTENT(IN) :: IMOD
 
    INTEGER istat
    IF (imem == 1) THEN
      ALLOCATE(aspar_jac(nspec, pdlib_nnz), stat=istat)
      if(istat /= 0) CALL pdlib_abort(9)
    ELSE IF (imem == 2) THEN
      ALLOCATE(aspar_diag_all(nspec, npa), stat=istat)
      if(istat /= 0) CALL pdlib_abort(9)
    ENDIF
    ALLOCATE(b_jac(nspec,nseal), stat=istat)
    if(istat /= 0) CALL pdlib_abort(10)
    ALLOCATE(cad_the(nspec,nseal), stat=istat)
    if(istat /= 0) CALL pdlib_abort(11)
    IF (freqshiftmethod .eq. 1) THEN
      ALLOCATE(cas_sig(nspec,nseal), stat=istat)
      if(istat /= 0) CALL pdlib_abort(11)
    ELSE IF (freqshiftmethod .eq. 2) THEN
      ALLOCATE(cwnb_sig_m2(1-nth:nspec,nseal), stat=istat)
      if(istat /= 0) CALL pdlib_abort(11)
    END IF
    IF (.NOT. b_jgs_block_gauss_seidel) THEN
      ALLOCATE(u_jac(nspec,npa), stat=istat)
      if(istat /= 0) CALL pdlib_abort(12)
    END IF
    !/
    !/ End of JACOBI_INIT ------------------------------------------------ /
    !/
  END SUBROUTINE jacobi_init
  !/ ------------------------------------------------------------------- /
  SUBROUTINE jacobi_finalize
    !/
    !/                  +-----------------------------------+
    !/                  | WAVEWATCH III           NOAA/NCEP |
    !/                  |                                   |
    !/                  | Aron Roland (BGS IT&E GmbH)       |
    !/                  | Mathieu Dutour-Sikiric (IRB)      |
    !/                  |                                   |
    !/                  |                        FORTRAN 90 |
    !/                  | Last update :        01-June-2018 |
    !/                  +-----------------------------------+
    !/
    !/    01-June-2018 : Origination.                        ( version 6.04 )
    !/
    !  1. Purpose : Finalize jacobi solver
    !  2. Method :
    !  3. Parameters :
    !
    !     Parameter list
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  4. Subroutines used :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !      STRACE    Subr. W3SERVMD Subroutine tracing.
    !     ----------------------------------------------------------------
    !
    !  5. Called by :
    !
    !      Name      Type  Module   Description
    !     ----------------------------------------------------------------
    !     ----------------------------------------------------------------
    !
    !  6. Error messages :
    !  7. Remarks
    !  8. Structure :
    !  9. Switches :
    !
    !     !/S  Enable subroutine tracing.
    !
    ! 10. Source code :
    !
    !/ ------------------------------------------------------------------- /
    USE w3gdatmd, only: b_jgs_block_gauss_seidel
    USE w3parall, only: imem
    !/
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local PARAMETER
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
#ifdef W3_S
    CALL strace (ient, 'JACOBI_FINALIZE')
#endif
    IF (imem == 1) THEN
      DEALLOCATE(aspar_jac)
    ELSE IF (imem == 2) THEN
      DEALLOCATE(aspar_diag_all)
    ENDIF
    DEALLOCATE(b_jac)
    DEALLOCATE(cad_the)
    IF (freqshiftmethod .eq. 1) THEN
      DEALLOCATE(cas_sig)
    ELSE IF (freqshiftmethod .eq. 2) THEN
      DEALLOCATE(cwnb_sig_m2)
    END IF
    IF (.NOT. b_jgs_block_gauss_seidel) THEN
      DEALLOCATE(u_jac)
    END IF
    !/
    !/ End of JACOBI_FINALIZE -------------------------------------------- /
    !/
  END SUBROUTINE jacobi_finalize
  !/ ------------------------------------------------------------------- /
END MODULE pdlib_w3profsmd