WW3/w3sis1md_8F90_source.html

#include "w3macros.h"

!/ ------------------------------------------------------------------- /


MODULE w3sis1md

  !/

  !/                  +-----------------------------------+

  !/                  | WAVEWATCH III           NOAA/NCEP |

  !/                  |           S. Zieger               |

  !/                  |                        FORTRAN 90 |

  !/                  | Last update :         20-Dec-2013 |

  !/                  +-----------------------------------+

  !/

  !/    For updates see W3SID1 documentation.

  !/

  !  1. Purpose :

  !

  !     Diffusion source term.

  !

  !  2. Variables and types :

  !

  !  3. Subroutines and functions :

  !

  !      Name      Type  Scope    Description

  !     ----------------------------------------------------------------

  !      W3SIS1    Subr. Public   Ice scattering term.

  !     ----------------------------------------------------------------

  !

  !  4. Subroutines and functions used :

  !

  !     See subroutine documentation.

  !

  !  5. Remarks :

  !

  !  6. Switches :

  !

  !     See subroutine documentation.

  !

  !  7. Source code :

  !/

  !/ ------------------------------------------------------------------- /

  !/

  PUBLIC :: w3sis1

  !/

CONTAINS

  !/ ------------------------------------------------------------------- /

  SUBROUTINE w3sis1 (A, ICE, S)

    !/

    !/                  +-----------------------------------+

    !/                  | WAVEWATCH III           NOAA/NCEP |

    !/                  |           S. Zieger               |

    !/                  |                        FORTRAN 90 |

    !/                  | Last update :         20-Dec-2013 |

    !/                  +-----------------------------------+

    !/

    !/    16-Nov-2012 : Origination.                        ( version 4.14 )

    !/                                                        (S. Zieger)

    !  1. Purpose :

    !     Spectral reflection due to ice.

    !

    !/ ------------------------------------------------------------------- /

    !

    !  2. Method :

    !

    !  3. Parameters :

    !

    !     Parameter list

    !     ----------------------------------------------------------------

    !       A       R.A.  I   Action density spectrum (1-D)

    !       ICE     Real  I   Sea ice concentration.

    !       S       R.A.  O   Source term (1-D version).

    !     ----------------------------------------------------------------

    !

    !  4. Subroutines used :

    !

    !      Name      Type  Module   Description

    !     ----------------------------------------------------------------

    !     ----------------------------------------------------------------

    !

    !  5. Called by :

    !

    !      Name      Type  Module   Description

    !     ----------------------------------------------------------------

    !      W3SRCE    Subr. W3SRCEMD Source term integration.

    !      W3EXPO    Subr.   N/A    ASCII Point output post-processor.

    !      W3EXNC    Subr.   N/A    NetCDF Point output post-processor.

    !      GXEXPO    Subr.   N/A    GrADS point output post-processor.

    !     ----------------------------------------------------------------

    !

    !  6. Error messages :

    !

    !     None.

    !

    !  7. Remarks :

    !

    !     If ice parameter 1 is zero, no calculations are made.

    !

    !  8. Structure :

    !

    !     See source code.

    !

    !  9. Switches :

    !

    !     !/S  Enable subroutine tracing.

    !     !/T   Enable general test output.

    !           2-D print plot of source term.

    !

    ! 10. Source code :

    !

    !/ ------------------------------------------------------------------- /

    USE w3odatmd, ONLY: ndse

    USE w3servmd, ONLY: extcde

    USE w3gdatmd, ONLY: nk, nth, nspec, sig, sig2, dden2

    USE w3gdatmd, ONLY: dtmin, th, dth, ecos, dtmin

    USE w3gdatmd, ONLY: is1c1, is1c2

#ifdef W3_T

    USE w3odatmd, ONLY: ndst

#endif

#ifdef W3_S

    USE w3servmd, ONLY: strace

#endif

#ifdef W3_T

    USE w3arrymd, ONLY: prt2ds

#endif

    !

    IMPLICIT NONE

    !/

    !/ ------------------------------------------------------------------- /

    !/ Parameter list

    REAL, INTENT(IN)        :: a(nspec), ice

    REAL, INTENT(OUT)       :: s(nspec)

    !/

    !/ ------------------------------------------------------------------- /

    !/ Local parameters

    !/

#ifdef W3_S

    INTEGER, SAVE           :: ient = 0

#endif

    INTEGER                 :: ik, ith, ith2, is, is2

    REAL                    :: alpha

#ifdef W3_T

    REAL                    :: sout(nk,nth)

#endif

    !/

    !/ ------------------------------------------------------------------- /

    !/

#ifdef W3_S

    CALL strace (ient, 'W3SIS1')

#endif

    !

    ! 0.  Initializations ------------------------------------------------ *

    !

    s     = 0.

#ifdef W3_T

    sout  = 0.

#endif

    !

    !     Calculate scattering coefficient (linear transfer function) ---- *

    alpha = max(0., is1c1 * ice + is1c2)

#ifdef W3_T

    WRITE(ndst,8000) alpha

#endif

    !

    IF (alpha.GT.0. .AND. ice.GT.0.) THEN

      ! 1. Calculate the derivative ---------------------------------------- *

      DO ik = 1,nk

        DO ith = 1,nth

          is  = ith+(ik-1)*nth

          IF (a(is).GE.0.) THEN

            s(is)   = s(is)  -  alpha * a(is)

            DO ith2 = 1,nth

              is2 = ith2+(ik-1)*nth

              IF (is2.NE.is) THEN

                s(is2) = s(is2)  +  alpha * a(is) / real(nth-1)

              END IF

            END DO

          END IF

        END DO

      END DO

      !

      s = s / dtmin

      !

#ifdef W3_T

      DO ik = 1, nk

        DO ith = 1, nth

          is  = ith+(ik-1)*nth

          sout(ik,ith) = s(is)

        END DO

      END DO

      CALL prt2ds (ndst, nk, nk, nth, sout, sig(1:nk), '  ', 1.,    &

           0.0, 0.001, 'Diag Sir1', ' ', 'NONAME')

#endif

      !

    END IF

    ! Formats

8000 FORMAT (' TEST W3SIS1 : ALPHA :',e10.3)

    !

    !/

    !/ End of W3SIS1 ----------------------------------------------------- /

    !/

  END SUBROUTINE w3sis1

  !/

  !/ End of module W3SIS1MD -------------------------------------------- /

  !/

END MODULE w3sis1md