w3parall.F90

Go to the documentation of this file.

 
 
!/ ------------------------------------------------------------------- /
MODULE w3parall
  !/
  !/                  +-----------------------------------+
  !/                  | 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 : Parallel routines for implicit 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
  !/
  !/ ------------------------------------------------------------------- /
  !/ Parameter list
  !/
  !/ ------------------------------------------------------------------- /
  !/ Local parameters
  !/
#ifdef W3_S
  INTEGER, SAVE           :: ient = 0
#endif
  !
#ifdef W3_PDLIB
  INTEGER :: pdlib_nseal, pdlib_nsealm
  INTEGER, ALLOCATABLE :: jx_to_jsea(:), isea_to_jsea(:)
#endif
 
  INTEGER, ALLOCATABLE :: listispnextdir(:), listispprevdir(:)
  INTEGER, ALLOCATABLE :: listispnextfreq(:), listispprevfreq(:)
 
  LOGICAL, PARAMETER   :: lsloc = .true.
  INTEGER, PARAMETER   :: imem = 1
 
  REAL,  PARAMETER     :: onesixth  = 1.0d0/6.0d0
  REAL,  PARAMETER     :: onethird  = 1.0d0/3.0d0
  REAL,  PARAMETER     :: zero      = 0.0d0
 
  real*8,  PARAMETER     :: thr8      = tiny(1.d0)
  REAL,  PARAMETER     :: thr       = tiny(1.0)
CONTAINS
  !/ ------------------------------------------------------------------- /
  SUBROUTINE wav_my_wtime(eTime)
    !/ ------------------------------------------------------------------- /
    !/
    !/                  +-----------------------------------+
    !/                  | 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 :
    !  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
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    IMPLICIT NONE
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    INTEGER mpimode
    REAL(8), intent(out) :: eTime
#ifdef W3_MPI
    REAL(8) mpi_wtime
#endif
    mpimode=0
#ifdef W3_MPI
    mpimode=1
    etime=mpi_wtime()
#endif
#ifdef W3_S
    CALL strace (ient, 'WAV_MY_WTIME')
#endif
    IF (mpimode .eq. 0) THEN
      CALL cpu_time(etime)
    END IF
    !/
    !/ End of JACOBI_INIT ------------------------------------------------ /
    !/
  END SUBROUTINE wav_my_wtime
  !/ ------------------------------------------------------------------- /
  SUBROUTINE print_my_time(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 : Print timings
    !  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
    IMPLICIT NONE
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !
    character(*), intent(in) :: string
    REAL(8) :: eTime
#ifdef W3_S
    CALL strace (ient, 'PRINT_MY_TIME')
#endif
    CALL wav_my_wtime(etime)
    WRITE(740+iaproc,*) 'TIMING time=', etime, ' at step ', string
    !/
    !/ End of JACOBI_INIT ------------------------------------------------ /
    !/
  END SUBROUTINE print_my_time
  !/ ------------------------------------------------------------------- /
  SUBROUTINE prop_refraction_pr1(ISEA,DTG, CAD)
    !/
    !/                  +-----------------------------------+
    !/                  | 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 refraction part in matrix
    !  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, sig, dsip, ecos, esin, &
         ec2, esc, es2, fachfa, mapwn, flcth, flck,  &
         ctmax, dmin, dth, cthg0s, mapsf
    USE w3adatmd, ONLY: cg, wn, dcxdx, dcxdy, dcydx, dcydy, dddx,   &
         dddy, dw
#ifdef W3_REFRX
    USE w3adatmd, ONLY: dcdx, dcdy
#endif
    USE w3idatmd, ONLY: flcur
    USE w3odatmd, only : iaproc
    IMPLICIT NONE
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
    !/
    REAL, intent(out) :: CAD(NSPEC)
    INTEGER, intent(in) :: ISEA
    REAL, intent(in) :: DTG
    INTEGER :: ISP, IK, ITH, IX, IY
    REAL :: FRK(NK), FRG(NK), DSDD(0:NK+1)
    REAL :: FACTH, DCXY, DCYX, DCXXYY, DTTST
    REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eDDDX, eDDDY, eCTHG0
    REAL :: VCFLT(NSPEC), DEPTH, FDG
    REAL :: FDDMAX
#ifdef W3_S
    CALL strace (ient, 'PROP_REFRACTION_PR1')
#endif
    ix=mapsf(isea,1)
    iy=mapsf(isea,2)
    edddx=dddx(iy,ix)
    edddy=dddy(iy,ix)
    ecthg0 = cthg0s(isea)
    facth  = dtg / dth
    !
    fdg    = facth * ecthg0
    depth  = max( dmin , dw(isea) )
    DO ik=0, nk+1
      IF ( depth*wn(ik,isea) .LT. 5. ) THEN
        dsdd(ik) = max( 0. , cg(ik,isea)*wn(ik,isea)-0.5*sig(ik) ) / depth
      ELSE
        dsdd(ik) = 0.
      END IF
    END DO
    fddmax=0
    DO ith=1, nth
      fddmax = max( fddmax , abs(esin(ith)*edddx - ecos(ith)*edddy ) )
    END DO
    DO ik=1, nk
      frk(ik) = facth * dsdd(ik) / wn(ik,isea)
      !FRK(IK) = FRK(IK) / MAX ( 1. , FRK(IK)*FDDMAX/CTMAX )
      frg(ik) = fdg * cg(ik,isea)
    END DO
    DO isp=1, nspec
      vcflt(isp) = frg(mapwn(isp)) * ecos(isp) +                     &
           frk(mapwn(isp)) * ( esin(isp)*edddx - ecos(isp)*edddy )
    END DO
    !
#ifdef W3_REFRX
    ! 3.c @C/@x refraction and great-circle propagation
    vcflt  = 0.
    frk    = 0.
    DO ik=1, nk
      frk(ik) = facth * cg(ik,isea) * wn(ik,isea) / sig(ik)
    END DO
    DO isp=1, nspec
      vcflt(isp) = frg(mapwn(isp)) * ecos(isp)           &
           + frk(mapwn(isp)) * ( esin(isp)*dcdx(isp,1,mapwn(isp)) &
           - ecos(isp)*dcdy(isp,1,mapwn(isp)) )
    END DO
#endif
    !
    IF ( flcur ) THEN
      edcxdx=dcxdx(iy,ix)
      edcxdy=dcxdy(iy,ix)
      edcydx=dcydx(iy,ix)
      edcydy=dcydy(iy,ix)
      dcyx   = facth *   edcydx
      dcxxyy = facth * ( edcxdx - edcydy )
      dcxy   = facth *   edcxdy
      DO isp=1, nspec
        vcflt(isp) = vcflt(isp) + es2(isp)*dcyx  + esc(isp)*dcxxyy - ec2(isp)*dcxy
      END DO
    END IF
    DO isp=1,nspec
      cad(isp)=dble(vcflt(isp))
    END DO
    !/
    !/ End of JACOBI_INIT ------------------------------------------------ /
    !/
  END SUBROUTINE prop_refraction_pr1
  !/ ------------------------------------------------------------------- /
  !
  SUBROUTINE prop_refraction_pr3(IP, ISEA, DTG, CAD, DoLimiter)
    !/
    !/                  +-----------------------------------+
    !/                  | 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 refraction part in matrix alternative approach
    !  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: nk, nk2, nth, nspec, sig, dsip, ecos, esin, &
         ec2, esc, es2, fachfa, mapwn, flcth, flck,  &
         ctmax, dmin, dth, cthg0s, mapsf, sig
    USE w3adatmd, ONLY: cg, wn, dcxdx, dcxdy, dcydx, dcydy, dddx,   &
         dddy, dw
    USE w3idatmd, ONLY: flcur
    USE w3odatmd, only : iaproc
    IMPLICIT NONE
    !/
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    REAL, intent(out) :: CAD(NSPEC)
    INTEGER, intent(in) :: ISEA, IP
    REAL, intent(in) :: DTG
    logical, intent(in) :: DoLimiter
    INTEGER :: ISP, IK, ITH, IX, IY
    REAL :: FRK(NK), FRG(NK), DSDD(0:NK+1)
    REAL :: FACTH, DCXY, DCYX, DCXXYY, DTTST
    REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eDDDX, eDDDY, eCTHG0
    REAL :: VCFLT(NSPEC), DEPTH, FDG, CG1(0:NK+1), WN1(0:NK+1)
    REAL :: FDDMAX, CFLTHMAX, VELNOFILT, CTMAX_eff
#ifdef W3_S
    CALL strace (ient, 'PROP_REFRACTION_PR3')
#endif
 
    ix = mapsf(isea,1)
    iy = mapsf(isea,2)
    edddx=dddx(1,ip)
    edddy=dddy(1,ip)
    ecthg0 = cthg0s(isea)
    facth  = 1.0 / dth
    !
    fdg    = facth * ecthg0
    depth  = max( dmin , dw(isea) )
    DO ik=0, nk+1
      IF ( depth*wn(ik,isea) .LT. 5. ) THEN
        dsdd(ik) = max( 0. , cg(ik,isea)*wn(ik,isea)-0.5*sig(ik) ) / depth
      ELSE
        dsdd(ik) = 0.
      END IF
    END DO
    DO ik=1, nk
      frk(ik) = facth * dsdd(ik) / wn(ik,isea)
      frg(ik) = fdg * cg(ik,isea)
    END DO
    IF (flcur) THEN
      edcxdx = dcxdx(1,ip)
      edcxdy = dcxdy(1,ip)
      edcydx = dcydx(1,ip)
      edcydy = dcydy(1,ip)
      dcyx   = facth *   edcydx
      dcxxyy = facth * ( edcxdx - edcydy )
      dcxy   = facth *   edcxdy
      DO isp=1, nspec
        vcflt(isp) = es2(isp)*dcyx  + esc(isp)*dcxxyy - ec2(isp)*dcxy
      END DO
    ELSE
      vcflt=0
    END IF
    !
#ifdef W3_REFRX
    ! 3.c @C/@x refraction and great-circle propagation
    DO ik=1, nk
      frk(ik) = facth * cg(ik,isea) * wn(ik,isea) / sig(ik)
    END DO
#endif
    !
    ctmax_eff=ctmax/dtg
    DO isp=1, nspec
      velnofilt = vcflt(isp)                                       &
           + frg(mapwn(isp)) * ecos(isp)                             &
           + frk(mapwn(isp)) * (esin(isp)*edddx - ecos(isp)*edddy)
      !
      ! Puts filtering on total velocity (including currents and great circle effects)
      ! the filtering limits VCFLT to be less than CTMAX
      ! this modification was proposed by F. Ardhuin 2011/03/06
      !
      IF (dolimiter) THEN
        vcflt(isp)=sign(min(abs(velnofilt),ctmax_eff),velnofilt)
      ELSE
        vcflt(isp)=velnofilt
      END IF
    END DO
    DO isp=1,nspec
      cad(isp)=dble(vcflt(isp))
    END DO
    !/
    !/ End of JACOBI_INIT ------------------------------------------------ /
    !/
  END SUBROUTINE prop_refraction_pr3
  !/ ------------------------------------------------------------------- /
  SUBROUTINE prop_freq_shift(IP, ISEA, CAS, DMM, 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 freq. shift in matrix
    !  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: nk, nk2, nth, nspec, sig, dsip, ecos, esin, &
         ec2, esc, es2, fachfa, mapwn, flcth, flck,  &
         ctmax, dmin, dth, mapsf
    USE w3adatmd, ONLY: cg, wn, dcxdx, dcxdy, dcydx, dcydy, cx, cy, dddx, dddy, dw
    USE w3odatmd, only : iaproc
    IMPLICIT NONE
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    INTEGER, intent(in) :: ISEA, IP
    REAL, intent(out) :: DMM(0:NK2)
    REAL, intent(in) :: DTG
    REAL, intent(out) :: CAS(NSPEC)
    REAL :: DB(NK2), DSDD(0:NK+1)
    REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eCX, eCY, eDDDX, EDDDY
    REAL :: DCXX, DCXYYX, DCYY, FKD, FACK
    REAL :: VELNOFILT, VELFAC, DEPTH
    REAL :: CFLK(NK2,NTH), FKC(NTH), FKD0
    INTEGER :: IK, ITH, ISP, IY, IX
#ifdef W3_S
    CALL strace (ient, 'PROP_FREQ_SHIFT')
#endif
    !
    IF (lpdlib) THEN
      edcxdx = dcxdx(1,ip)
      edcxdy = dcxdy(1,ip)
      edcydx = dcydx(1,ip)
      edcydy = dcydy(1,ip)
      edddx  = dddx(1,ip)
      edddy  = dddy(1,ip)
    ELSE
      ix=mapsf(isea,1)
      iy=mapsf(isea,2)
      edcxdx=dcxdx(iy,ix)
      edcxdy=dcxdy(iy,ix)
      edcydx=dcydx(iy,ix)
      edcydy=dcydy(iy,ix)
      edddx=dddx(iy,ix)
      edddy=dddy(iy,ix)
    ENDIF
    ecx=cx(isea)
    ecy=cy(isea)
    dcxx   =  -   edcxdx
    dcxyyx =  - ( edcxdy + edcydx )
    dcyy   =  -   edcydy
    fkd    =    ( ecx*edddx + ecy*edddy )
    fack = dtg
    DO ith=1, nth
      fkc(ith) = ec2(ith)*dcxx + esc(ith)*dcxyyx + es2(ith)*dcyy
    END DO
    DO ik=0, nk
      db(ik+1) = dsip(ik) / cg(ik,isea)
      dmm(ik+1) = dble(wn(ik+1,isea) - wn(ik,isea))
    END DO
    db(nk+2) = dsip(nk+1) / cg(nk+1,isea)
    dmm(nk+2) = zero
    dmm(0)=dmm(1)
    !
    depth  = max( dmin , dw(isea) )
    DO ik=0, nk+1
      IF ( depth*wn(ik,isea) .LT. 5. ) THEN
        dsdd(ik) = max( 0. , cg(ik,isea)*wn(ik,isea)-0.5*sig(ik) ) / depth
      ELSE
        dsdd(ik) = 0.
      END IF
    END DO
    DO ik=0, nk+1
      fkd0   = fkd / cg(ik,isea) * dsdd(ik)
      velfac =  fack/db(ik+1)
      DO ith=1, nth
        velnofilt = ( fkd0 + wn(ik,isea)*fkc(ith) ) * velfac
        cflk(ik+1,ith) = velnofilt/velfac
      END DO
    END DO
    DO ik=1,nk
      DO ith=1,nth
        isp=ith + (ik-1)*nth
        cas(isp)=dble(cflk(ik,ith))
      END DO
    END DO
    !/
    !/ End of JACOBI_INIT ------------------------------------------------ /
    !/
  END SUBROUTINE prop_freq_shift
  !/ ------------------------------------------------------------------- /
  SUBROUTINE prop_freq_shift_m2(IP, ISEA, CWNB_M2, DWNI_M2, 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 freq. shift alternative approach
    !  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: nk, nk2, nth, nspec, sig, dsip, ecos, esin, &
         ec2, esc, es2, fachfa, mapwn, flcth, flck,  &
         ctmax, dmin, dth, mapsf
    USE w3adatmd, ONLY: cg, wn, dcxdx, dcxdy, dcydx, dcydy, cx, cy, dddx, dddy, dw
    USE w3odatmd, only : iaproc
 
    IMPLICIT NONE
 
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
 
    INTEGER, intent(in) :: ISEA, IP
    REAL, intent(out) :: CWNB_M2(1-NTH:NSPEC)
    REAL, intent(out) :: DWNI_M2(NK)
    REAL, intent(in) :: DTG
    !
    REAL :: eDCXDX, eDCXDY, eDCYDX, eDCYDY, eCX, eCY, eDDDX, EDDDY
    REAL :: DCXX, DCXYYX, DCYY, FKD, FACK
    REAL :: DEPTH
    REAL :: FKC(NTH), FKD0
    REAL :: VCWN(1-NTH:NSPEC+NTH)
    REAL :: DSDD(0:NK+1)
    REAL :: sumDiff, sumDiff1, sumDiff2, sumDiff3
    REAL :: sumDiff0, sumDiff4, sumDiff5
    INTEGER :: IK, ITH, ISP, IY, IX
 
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    CALL strace (ient, 'PROP_FREQ_SHIFT_M2')
#endif
 
    IF (lpdlib) THEN
      edcxdx = dcxdx(1,ip)
      edcxdy = dcxdy(1,ip)
      edcydx = dcydx(1,ip)
      edcydy = dcydy(1,ip)
      edddx  = dddx(1,ip)
      edddy  = dddy(1,ip)
    ELSE
      ix=mapsf(isea,1)
      iy=mapsf(isea,2)
      edcxdx=dcxdx(iy,ix)
      edcxdy=dcxdy(iy,ix)
      edcydx=dcydx(iy,ix)
      edcydy=dcydy(iy,ix)
      edddx=dddx(iy,ix)
      edddy=dddy(iy,ix)
    ENDIF
 
    ecx = cx(isea)
    ecy = cy(isea)
    fack = dtg
    dcxx   =  - fack *   edcxdx
    dcxyyx =  - fack * ( edcxdy + edcydx )
    dcyy   =  - fack *   edcydy
    fkd    =    fack * ( ecx*edddx + ecy*edddy )
 
    DO ith=1, nth
      fkc(ith) = ec2(ith)*dcxx + esc(ith)*dcxyyx + es2(ith)*dcyy
    END DO
    !
    depth  = max( dmin , dw(isea) )
    DO ik=0, nk+1
      IF ( depth*wn(ik,isea) .LT. 5. ) THEN
        dsdd(ik) = max( 0. , cg(ik,isea)*wn(ik,isea)-0.5*sig(ik) ) / depth
      ELSE
        dsdd(ik) = 0.
      END IF
    END DO
    isp = -nth
    DO ik=0, nk+1
      fkd0   = fkd / cg(ik,isea) * dsdd(ik)
      DO ith=1, nth
        isp = isp + 1
        vcwn(isp) = fkd0 + wn(ik,isea)*fkc(ith)
      END DO
    END DO
 
    sumdiff=0
    DO isp=1-nth,nspec
      cwnb_m2(isp) = dble(0.5 * ( vcwn(isp) + vcwn(isp+nth) ))
      sumdiff = sumdiff + max(cwnb_m2(isp), zero)
    END DO
    DO ik=1,nk
      dwni_m2(ik) = dble( cg(ik,isea) / dsip(ik) )
    END DO
    !/
    !/ End of JACOBI_INIT ------------------------------------------------ /
    !/
  END SUBROUTINE prop_freq_shift_m2
  !/ ------------------------------------------------------------------- /
  SUBROUTINE synchronize_ipgl_etc_array(IMOD, IsMulti)
    !/
    !/                  +-----------------------------------+
    !/                  | 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 : Sync global local arrays
    !  2. Method :
    !       All the process need to have IPGL_tot and IPGL_TO_PROC
    !       This is especially the case for the output process.
    !       So we need some painful exportation business
    !  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
#ifdef W3_PDLIB
    USE yowdatapool, only: istatus
    USE yownodepool, only: np_global
    USE w3odatmd, ONLY: ntproc, naproc, iaproc
    USE w3gdatmd, ONLY: mapsf, nsea
    USE w3adatmd, ONLY: mpi_comm_wave, mpi_comm_wcmp
    USE yowrankmodule, only : ipgl_to_proc, ipgl_tot
    USE wmmdatmd, ONLY: mdatas
#endif
    IMPLICIT NONE
#ifdef W3_PDLIB
    include "mpif.h"
#endif
    INTEGER, intent(in) :: IMOD
    logical, intent(in) :: IsMulti
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
#ifdef W3_PDLIB
    INTEGER :: Iarr(1)
    INTEGER :: ISEA, IP_glob
    INTEGER :: IPROC, IERR_MPI, istat
#endif
 
#ifdef W3_S
    CALL strace (ient, 'SYNCHRONIZE_IPGL_ETC_ARRAY')
#endif
 
#ifdef W3_PDLIB
    IF (iaproc .le. naproc) THEN
      IF (iaproc .eq. 1) THEN
        iarr(1)=np_global
        DO iproc=naproc+1,ntproc
          CALL mpi_send(iarr,1,mpi_int, iproc-1, 37, mpi_comm_wave, ierr_mpi)
        END DO
        DO iproc=naproc+1,ntproc
          CALL mpi_send(ipgl_tot,np_global,mpi_int, iproc-1, 43, mpi_comm_wave, ierr_mpi)
          CALL mpi_send(ipgl_to_proc,np_global,mpi_int, iproc-1, 91, mpi_comm_wave, ierr_mpi)
        END DO
      END IF
    ELSE
      CALL mpi_recv(iarr,1,mpi_int, 0, 37, mpi_comm_wave, istatus, ierr_mpi)
      np_global=iarr(1)
      allocate(ipgl_tot(np_global), ipgl_to_proc(np_global), stat=istat)
      CALL mpi_recv(ipgl_tot,np_global,mpi_int, 0, 43, mpi_comm_wave, istatus, ierr_mpi)
      CALL mpi_recv(ipgl_to_proc,np_global,mpi_int, 0, 91, mpi_comm_wave, istatus, ierr_mpi)
    END IF
    IF (ismulti) THEN
      WRITE(*,*) ' Before allocation of MDATAS % SEA_IPGL, SEA_IPGL_TO_PROC : IMOD=', imod, ' NSEA=', nsea
      ALLOCATE(mdatas(imod)%SEA_IPGL(nsea), mdatas(imod)%SEA_IPGL_TO_PROC(nsea), stat=istat)
      !CHECK_ALLOC_STATUS ( ISTAT )
      DO isea=1,nsea
        ip_glob = mapsf(isea, 1)
        mdatas(imod)%SEA_IPGL(isea) = ipgl_tot(ip_glob)
        mdatas(imod)%SEA_IPGL_TO_PROC(isea) = ipgl_to_proc(ip_glob)
      END DO
    END IF
#endif
    !/
    !/ End of JACOBI_INIT ------------------------------------------------ /
    !/
  END SUBROUTINE synchronize_ipgl_etc_array
  !/ ....................----------------------------------------------- /
  SUBROUTINE set_up_nseal_nsealm(NSEALout, NSEALMout)
    !/
    !/                  +-----------------------------------+
    !/                  | 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 : Setup nseal, nsealm in contect of 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
    !/
    !/ ------------------------------------------------------------------- /
#ifdef W3_PDLIB
    use yowdatapool, only: istatus
    use yownodepool, only: npa
    use yowrankmodule, only : rank
    USE w3gdatmd, ONLY: gtype, ungtype
#endif
#ifdef W3_MPI
    USE w3adatmd, ONLY: mpi_comm_wave, mpi_comm_wcmp
#endif
    USE constants, ONLY : lpdlib
    USE w3gdatmd, ONLY: nsea
    USE w3odatmd, ONLY: ntproc, naproc, iaproc
    IMPLICIT NONE
    INTEGER, intent(out) :: NSEALout, NSEALMout
    !/ Local parameters
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
#ifdef W3_S
    CALL strace (ient, 'SET_UP_NSEAL_NSEALM')
#endif
 
#ifdef W3_SHRD
    nsealout  = nsea
    nsealmout = nsea
#endif
    !
#ifdef W3_DIST
    IF (.NOT. lpdlib ) THEN
      IF ( iaproc .LE. naproc ) THEN
        nsealout  = 1 + (nsea-iaproc)/naproc
      ELSE
        nsealout  = 0
      END IF
      nsealmout = 1 + (nsea-1)/naproc
    ELSE
#endif
#ifdef W3_PDLIB
      IF (gtype .eq. ungtype) THEN
        nsealout  = pdlib_nseal
        nsealmout = pdlib_nsealm
      ELSE
        IF ( iaproc .LE. naproc ) THEN
          nsealout  = 1 + (nsea-iaproc)/naproc
        ELSE
          nsealout  = 0
        END IF
        nsealmout = 1 + (nsea-1)/naproc
      ENDIF
#endif
#ifdef W3_DIST
    ENDIF
#endif
    !/
    !/ End of JACOBI_INIT ------------------------------------------------ /
    !/
  END SUBROUTINE set_up_nseal_nsealm
  !/ ------------------------------------------------------------------- /
  SUBROUTINE init_get_jsea_isproc(ISEA, JSEA, ISPROC)
    !/ ------------------------------------------------------------------- /
    !/
    !/                  +-----------------------------------+
    !/                  | 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 Jsea for all schemes
    !  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: outpts, iaproc, naproc
    USE w3gdatmd, ONLY: gtype, ungtype, mapsf
    USE constants, ONLY : lpdlib
#ifdef W3_PDLIB
    USE yowrankmodule, only : ipgl_to_proc, ipgl_tot
    use yownodepool, only: ipgl, iplg
#endif
    IMPLICIT NONE
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    INTEGER, intent(in) :: ISEA
    INTEGER, intent(out) :: JSEA, ISPROC
    INTEGER IP_glob
#ifdef W3_S
    CALL strace (ient, 'INIT_GET_JSEA_ISPROC')
#endif
 
#ifdef W3_PDLIB
    IF (.NOT. lpdlib) THEN
#endif
      jsea   = 1 + (isea-1)/naproc
      isproc = isea - (jsea-1)*naproc
#ifdef W3_PDLIB
    ELSE
      ip_glob = mapsf(isea,1)
      IF (iaproc .le. naproc) THEN
        jsea   = isea_to_jsea(isea)
      ELSE
        jsea   = -1
      END IF
      isproc = ipgl_to_proc(ip_glob)
    ENDIF
#endif
    !/
    !/ End of JACOBI_INIT ------------------------------------------------ /
    !/
  END SUBROUTINE init_get_jsea_isproc
  !/ ------------------------------------------------------------------- /
  SUBROUTINE get_jsea_ibelong(ISEA, JSEA, IBELONG)
    !/ ------------------------------------------------------------------- /
    !/
    !/                  +-----------------------------------+
    !/                  | 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 belongings of jsea in context of 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 w3odatmd, ONLY: outpts, iaproc, naproc
    USE w3gdatmd, ONLY: gtype, ungtype, mapsf
    USE constants, ONLY : lpdlib
#ifdef W3_PDLIB
    USE yowrankmodule, only : ipgl_to_proc, ipgl_tot, ipgl_npa
    use yownodepool, only: ipgl, iplg
#endif
    IMPLICIT NONE
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
    INTEGER, intent(in) :: ISEA
    INTEGER, intent(out) :: JSEA, IBELONG
    INTEGER ISPROC, IX, JX
#ifdef W3_S
    CALL strace (ient, 'GET_JSEA_IBELONG')
#endif
    IF (.NOT. lpdlib) THEN
      jsea   = 1 + (isea-1)/naproc
      isproc = isea - (jsea-1)*naproc
      IF (isproc .eq. iaproc) THEN
        ibelong=1
      ELSE
        ibelong=0
      END IF
    ELSE
#ifdef W3_PDLIB
      IF (gtype .ne. ungtype) THEN
        jsea   = 1 + (isea-1)/naproc
        isproc = isea - (jsea-1)*naproc
        IF (isproc .eq. iaproc) THEN
          ibelong=1
        ELSE
          ibelong=0
        END IF
      ELSE
        IF (iaproc .le. naproc) THEN
          ix     = mapsf(isea,1)
          jx     = ipgl_npa(ix)
          IF (jx .eq. 0) THEN
            ibelong=0
            jsea=-1
          ELSE
            ibelong=1
            jsea = jx_to_jsea(jx)
          END IF
        ELSE
          ibelong=0
          jsea=-1
        END IF
      ENDIF
#endif
    ENDIF
    !/
    !/ End of INIT_GET_ISEA ---------------------------------------------- /
    !/
  END SUBROUTINE get_jsea_ibelong
  !/ ------------------------------------------------------------------- /
  SUBROUTINE init_get_isea(ISEA, JSEA)
    !/ ------------------------------------------------------------------- /
    !/
    !/                  +-----------------------------------+
    !/                  | 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 Isea for all schemes
    !  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: outpts, iaproc, naproc
    USE w3gdatmd, ONLY: gtype, ungtype
    USE constants, ONLY : lpdlib
#ifdef W3_PDLIB
    USE yownodepool, ONLY: iplg
#endif
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
    !/ ------------------------------------------------------------------- /
    !/
    !/
    !/ ------------------------------------------------------------------- /
    !/
    !/ ------------------------------------------------------------------- /
    !
    USE w3odatmd, ONLY: outpts, iaproc, naproc
    USE w3gdatmd, ONLY: gtype, ungtype
    USE constants, ONLY : lpdlib
#ifdef W3_PDLIB
    USE yownodepool, ONLY: iplg
#endif
    IMPLICIT NONE
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    INTEGER, intent(in) :: JSEA
    INTEGER, intent(out) :: ISEA
#ifdef W3_S
    CALL strace (ient, 'INIT_GET_ISEA')
#endif
#ifdef W3_SHRD
    isea         = jsea
#endif
#ifdef W3_DIST
    IF (.NOT. lpdlib) THEN
      isea         = iaproc + (jsea-1)*naproc
    ELSE
#endif
#ifdef W3_PDLIB
      IF (gtype .eq. ungtype) THEN
        isea         = iplg(jsea)
      ELSE
        isea         = iaproc + (jsea-1)*naproc
      ENDIF
#endif
#ifdef W3_DIST
    ENDIF
#endif
    !/
    !/ End of INIT_GET_ISEA ------------------------------------------------ /
    !/
  END SUBROUTINE init_get_isea
 
  SUBROUTINE synchronize_global_array(TheVar)
    !/ ------------------------------------------------------------------- /
    !**********************************************************************
    !*  An array of size (NSEA) is send but only the (1:NSEAL) values     *
    !*  are correct. The program synchonizes everything on all nodes.     *
    !**********************************************************************
    !/
    !/                  +-----------------------------------+
    !/                  | 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 : Sync global array in context of pdlib
    !  2. Method :
    !           An array of size (NSEA) is send but only the (1:NSEAL) values
    !           are correct. The program synchonizes everything on 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 :
    !
    !/ ------------------------------------------------------------------- /
#ifdef W3_S
    USE w3servmd, ONLY: strace
#endif
    !
    USE w3gdatmd, ONLY: nseal, nsea, nx
#ifdef W3_PDLIB
    USE w3odatmd, only : iaproc, naproc, ntproc
    USE w3adatmd, ONLY: mpi_comm_wcmp
    use yowdatapool, only: rtype, istatus
    USE yownodepool, only: npa
    use yownodepool, only: iplg
    use yowdatapool, only: rkind
#endif
    IMPLICIT NONE
    !/ ------------------------------------------------------------------- /
    !/ Parameter list
    !/
    !/ ------------------------------------------------------------------- /
    !/ Local parameters
    !/
#ifdef W3_S
    INTEGER, SAVE           :: IENT = 0
#endif
    !/
    !/ ------------------------------------------------------------------- /
    !/
#ifdef W3_MPI
    include "mpif.h"
#endif
    INTEGER ISEA, JSEA, Status(NX), rStatus(NX)
    INTEGER IPROC, I, ierr, IP, IX, IP_glob
#ifdef W3_PDLIB
    REAL(rkind), intent(inout) :: TheVar(NX)
    REAL(rkind) ::  rVect(NX)
#else
    DOUBLE PRECISION, intent(inout) :: TheVar(NX)
    DOUBLE PRECISION                ::  rVect(NX)
#endif
    status=0
#ifdef W3_S
    CALL strace (ient, 'SYNCHRONIZE_GLOBAL_ARRAY')
#endif
#ifdef W3_PDLIB
    DO ip=1,npa
      ip_glob=iplg(ip)
      status(ip_glob)=1
    END DO
    IF (iaproc .eq. 1) THEN
      DO iproc=2,naproc
        CALL mpi_recv(rvect,nx,rtype, iproc-1, 19, mpi_comm_wcmp, istatus, ierr)
        CALL mpi_recv(rstatus,nx,mpi_integer, iproc-1, 23, mpi_comm_wcmp, istatus, ierr)
        DO i=1,nx
          IF (rstatus(i) .eq. 1) THEN
            thevar(i)=rvect(i)
            status(i)=1
          END IF
        END DO
      END DO
      DO iproc=2,naproc
        CALL mpi_send(thevar,nx,rtype, iproc-1, 29, mpi_comm_wcmp, ierr)
      END DO
    ELSE
      CALL mpi_send(thevar,nx,rtype, 0, 19, mpi_comm_wcmp, ierr)
      CALL mpi_send(status,nx,mpi_integer, 0, 23, mpi_comm_wcmp, ierr)
      CALL mpi_recv(thevar,nx,rtype, 0, 29, mpi_comm_wcmp, istatus, ierr)
    END IF
#endif
    !/
    !/ End of JACOBI_INIT ------------------------------------------------ /
    !/
  END SUBROUTINE synchronize_global_array
  !/ ------------------------------------------------------------------- /
END MODULE w3parall
!/ ------------------------------------------------------------------- /