source: LMDZ6/branches/Amaury_posttrusting/libf/phylmd/diagphy.f90 @ 5333

! $Header$

SUBROUTINE diagphy(airephy, tit, iprt, tops, topl, sols, soll, sens, evap, &
    rain_fall, snow_fall, ts, d_etp_tot, d_qt_tot, d_ec_tot, fs_bound, &
    fq_bound)
  ! ======================================================================

  ! Purpose:
  ! Compute the thermal flux and the watter mass flux at the atmosphere
  ! boundaries. Print them and also the atmospheric enthalpy change and
  ! the  atmospheric mass change.

  ! Arguments:
  ! airephy-------input-R-  grid area
  ! tit---------input-A15- Comment to be added in PRINT (CHARACTER*15)
  ! iprt--------input-I-  PRINT level ( <=0 : no PRINT)
  ! tops(klon)--input-R-  SW rad. at TOA (W/m2), positive up.
  ! topl(klon)--input-R-  LW rad. at TOA (W/m2), positive down
  ! sols(klon)--input-R-  Net SW flux above surface (W/m2), positive up
  ! (i.e. -1 * flux absorbed by the surface)
  ! soll(klon)--input-R-  Net LW flux above surface (W/m2), positive up
  ! (i.e. flux emited - flux absorbed by the surface)
  ! sens(klon)--input-R-  Sensible Flux at surface  (W/m2), positive down
  ! evap(klon)--input-R-  Evaporation + sublimation watter vapour mass flux
  ! (kg/m2/s), positive up
  ! rain_fall(klon)
  ! --input-R- Liquid  watter mass flux (kg/m2/s), positive down
  ! snow_fall(klon)
  ! --input-R- Solid  watter mass flux (kg/m2/s), positive down
  ! ts(klon)----input-R- Surface temperature (K)
  ! d_etp_tot---input-R- Heat flux equivalent to atmospheric enthalpy
  ! change (W/m2)
  ! d_qt_tot----input-R- Mass flux equivalent to atmospheric watter mass
  ! change (kg/m2/s)
  ! d_ec_tot----input-R- Flux equivalent to atmospheric cinetic energy
  ! change (W/m2)

  ! fs_bound---output-R- Thermal flux at the atmosphere boundaries (W/m2)
  ! fq_bound---output-R- Watter mass flux at the atmosphere boundaries
  ! (kg/m2/s)

  ! J.L. Dufresne, July 2002
  ! Version prise sur
  ! ~rlmd833/LMDZOR_201102/modipsl/modeles/LMDZ.3.3/libf/phylmd
  ! le 25 Novembre 2002.
  ! ======================================================================

USE yoethf_mod_h
    USE dimphy
  USE yomcst_mod_h
IMPLICIT NONE



  ! Input variables
  REAL airephy(klon)
  CHARACTER *15 tit
  INTEGER iprt
  REAL tops(klon), topl(klon), sols(klon), soll(klon)
  REAL sens(klon), evap(klon), rain_fall(klon), snow_fall(klon)
  REAL ts(klon)
  REAL d_etp_tot, d_qt_tot, d_ec_tot
  ! Output variables
  REAL fs_bound, fq_bound

  ! Local variables
  REAL stops, stopl, ssols, ssoll
  REAL ssens, sfront, slat
  REAL airetot, zcpvap, zcwat, zcice
  REAL rain_fall_tot, snow_fall_tot, evap_tot

  INTEGER i

  INTEGER pas
  SAVE pas
  DATA pas/0/
  !$OMP THREADPRIVATE(pas)

  pas = pas + 1
  stops = 0.
  stopl = 0.
  ssols = 0.
  ssoll = 0.
  ssens = 0.
  sfront = 0.
  evap_tot = 0.
  rain_fall_tot = 0.
  snow_fall_tot = 0.
  airetot = 0.

  ! Pour les chaleur specifiques de la vapeur d'eau, de l'eau et de
  ! la glace, on travaille par difference a la chaleur specifique de l'
  ! air sec. En effet, comme on travaille a niveau de pression donne,
  ! toute variation de la masse d'un constituant est totalement
  ! compense par une variation de masse d'air.

  zcpvap = rcpv - rcpd
  zcwat = rcw - rcpd
  zcice = rcs - rcpd

  DO i = 1, klon
    stops = stops + tops(i)*airephy(i)
    stopl = stopl + topl(i)*airephy(i)
    ssols = ssols + sols(i)*airephy(i)
    ssoll = ssoll + soll(i)*airephy(i)
    ssens = ssens + sens(i)*airephy(i)
    sfront = sfront + (evap(i)*zcpvap-rain_fall(i)*zcwat-snow_fall(i)*zcice)* &
      ts(i)*airephy(i)
    evap_tot = evap_tot + evap(i)*airephy(i)
    rain_fall_tot = rain_fall_tot + rain_fall(i)*airephy(i)
    snow_fall_tot = snow_fall_tot + snow_fall(i)*airephy(i)
    airetot = airetot + airephy(i)
  END DO
  stops = stops/airetot
  stopl = stopl/airetot
  ssols = ssols/airetot
  ssoll = ssoll/airetot
  ssens = ssens/airetot
  sfront = sfront/airetot
  evap_tot = evap_tot/airetot
  rain_fall_tot = rain_fall_tot/airetot
  snow_fall_tot = snow_fall_tot/airetot

  slat = rlvtt*rain_fall_tot + rlstt*snow_fall_tot
  ! Heat flux at atm. boundaries
  fs_bound = stops - stopl - (ssols+ssoll) + ssens + sfront + slat
  ! Watter flux at atm. boundaries
  fq_bound = evap_tot - rain_fall_tot - snow_fall_tot

  IF (iprt>=1) WRITE (6, 6666) tit, pas, fs_bound, d_etp_tot, fq_bound, &
    d_qt_tot

  IF (iprt>=1) WRITE (6, 6668) tit, pas, d_etp_tot + d_ec_tot - fs_bound, &
    d_qt_tot - fq_bound

  IF (iprt>=2) WRITE (6, 6667) tit, pas, stops, stopl, ssols, ssoll, ssens, &
    slat, evap_tot, rain_fall_tot + snow_fall_tot

  RETURN

6666 FORMAT ('Phys. Flux Budget ', A15, 1I6, 2F8.2, 2(1PE13.5))
6667 FORMAT ('Phys. Boundary Flux ', A15, 1I6, 6F8.2, 2(1PE13.5))
6668 FORMAT ('Phys. Total Budget ', A15, 1I6, F8.2, 2(1PE13.5))

END SUBROUTINE diagphy

! ======================================================================
SUBROUTINE diagetpq(airephy, tit, iprt, idiag, idiag2, dtime, t, q, ql, qs, &
    u, v, paprs, pplay, d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
  ! ======================================================================

  ! Purpose:
  ! Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
  ! et calcul le flux de chaleur et le flux d'eau necessaire a ces
  ! changements. Ces valeurs sont moyennees sur la surface de tout
  ! le globe et sont exprime en W/2 et kg/s/m2
  ! Outil pour diagnostiquer la conservation de l'energie
  ! et de la masse dans la physique. Suppose que les niveau de
  ! pression entre couche ne varie pas entre 2 appels.

  ! Plusieurs de ces diagnostics peuvent etre fait en parallele: les
  ! bilans sont sauvegardes dans des tableaux indices. On parlera
  ! "d'indice de diagnostic"


  ! ======================================================================
  ! Arguments:
  ! airephy-------input-R-  grid area
  ! tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
  ! iprt----input-I-  PRINT level ( <=1 : no PRINT)
  ! idiag---input-I- indice dans lequel sera range les nouveaux
  ! bilans d' entalpie et de masse
  ! idiag2--input-I-les nouveaux bilans d'entalpie et de masse
  ! sont compare au bilan de d'enthalpie de masse de
  ! l'indice numero idiag2
  ! Cas parriculier : si idiag2=0, pas de comparaison, on
  ! sort directement les bilans d'enthalpie et de masse
  ! dtime----input-R- time step (s)
  ! t--------input-R- temperature (K)
  ! q--------input-R- vapeur d'eau (kg/kg)
  ! ql-------input-R- liquid watter (kg/kg)
  ! qs-------input-R- solid watter (kg/kg)
  ! u--------input-R- vitesse u
  ! v--------input-R- vitesse v
  ! paprs----input-R- pression a intercouche (Pa)
  ! pplay----input-R- pression au milieu de couche (Pa)

  ! the following total value are computed by UNIT of earth surface

  ! d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy
  ! change (J/m2) during one time step (dtime) for the whole
  ! atmosphere (air, watter vapour, liquid and solid)
  ! d_qt------output-R- total water mass flux (kg/m2/s) defined as the
  ! total watter (kg/m2) change during one time step (dtime),
  ! d_qw------output-R- same, for the watter vapour only (kg/m2/s)
  ! d_ql------output-R- same, for the liquid watter only (kg/m2/s)
  ! d_qs------output-R- same, for the solid watter only (kg/m2/s)
  ! d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column

  ! other (COMMON...)
  ! RCPD, RCPV, ....

  ! J.L. Dufresne, July 2002
  ! ======================================================================

USE yoethf_mod_h
    USE dimphy
  USE yomcst_mod_h
IMPLICIT NONE



  ! Input variables
  REAL airephy(klon)
  CHARACTER *15 tit
  INTEGER iprt, idiag, idiag2
  REAL dtime
  REAL t(klon, klev), q(klon, klev), ql(klon, klev), qs(klon, klev)
  REAL u(klon, klev), v(klon, klev)
  REAL paprs(klon, klev+1), pplay(klon, klev)
  ! Output variables
  REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec

  ! Local variables

  REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot, h_qs_tot, qw_tot, ql_tot, &
    qs_tot, ec_tot
  ! h_vcol_tot--  total enthalpy of vertical air column
  ! (air with watter vapour, liquid and solid) (J/m2)
  ! h_dair_tot-- total enthalpy of dry air (J/m2)
  ! h_qw_tot----  total enthalpy of watter vapour (J/m2)
  ! h_ql_tot----  total enthalpy of liquid watter (J/m2)
  ! h_qs_tot----  total enthalpy of solid watter  (J/m2)
  ! qw_tot------  total mass of watter vapour (kg/m2)
  ! ql_tot------  total mass of liquid watter (kg/m2)
  ! qs_tot------  total mass of solid watter (kg/m2)
  ! ec_tot------  total cinetic energy (kg/m2)

  REAL zairm(klon, klev) ! layer air mass (kg/m2)
  REAL zqw_col(klon)
  REAL zql_col(klon)
  REAL zqs_col(klon)
  REAL zec_col(klon)
  REAL zh_dair_col(klon)
  REAL zh_qw_col(klon), zh_ql_col(klon), zh_qs_col(klon)

  REAL d_h_dair, d_h_qw, d_h_ql, d_h_qs

  REAL airetot, zcpvap, zcwat, zcice

  INTEGER i, k

  INTEGER ndiag ! max number of diagnostic in parallel
  PARAMETER (ndiag=10)
  INTEGER pas(ndiag)
  SAVE pas
  DATA pas/ndiag*0/
  !$OMP THREADPRIVATE(pas)

  REAL h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag), &
    h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag), ql_pre(ndiag), &
    qs_pre(ndiag), ec_pre(ndiag)
  SAVE h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre, h_qs_pre, qw_pre, ql_pre, &
    qs_pre, ec_pre
  !$OMP THREADPRIVATE(h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre)
  !$OMP THREADPRIVATE(h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre)
  ! ======================================================================

  DO k = 1, klev
    DO i = 1, klon
      ! layer air mass
      zairm(i, k) = (paprs(i,k)-paprs(i,k+1))/rg
    END DO
  END DO

  ! Reset variables
  DO i = 1, klon
    zqw_col(i) = 0.
    zql_col(i) = 0.
    zqs_col(i) = 0.
    zec_col(i) = 0.
    zh_dair_col(i) = 0.
    zh_qw_col(i) = 0.
    zh_ql_col(i) = 0.
    zh_qs_col(i) = 0.
  END DO

  zcpvap = rcpv
  zcwat = rcw
  zcice = rcs

  ! Compute vertical sum for each atmospheric column
  ! ================================================
  DO k = 1, klev
    DO i = 1, klon
      ! Watter mass
      zqw_col(i) = zqw_col(i) + q(i, k)*zairm(i, k)
      zql_col(i) = zql_col(i) + ql(i, k)*zairm(i, k)
      zqs_col(i) = zqs_col(i) + qs(i, k)*zairm(i, k)
      ! Cinetic Energy
      zec_col(i) = zec_col(i) + 0.5*(u(i,k)**2+v(i,k)**2)*zairm(i, k)
      ! Air enthalpy
      zh_dair_col(i) = zh_dair_col(i) + rcpd*(1.-q(i,k)-ql(i,k)-qs(i,k))* &
        zairm(i, k)*t(i, k)
      zh_qw_col(i) = zh_qw_col(i) + zcpvap*q(i, k)*zairm(i, k)*t(i, k)
      zh_ql_col(i) = zh_ql_col(i) + zcwat*ql(i, k)*zairm(i, k)*t(i, k) - &
        rlvtt*ql(i, k)*zairm(i, k)
      zh_qs_col(i) = zh_qs_col(i) + zcice*qs(i, k)*zairm(i, k)*t(i, k) - &
        rlstt*qs(i, k)*zairm(i, k)

    END DO
  END DO

  ! Mean over the planete surface
  ! =============================
  qw_tot = 0.
  ql_tot = 0.
  qs_tot = 0.
  ec_tot = 0.
  h_vcol_tot = 0.
  h_dair_tot = 0.
  h_qw_tot = 0.
  h_ql_tot = 0.
  h_qs_tot = 0.
  airetot = 0.

  DO i = 1, klon
    qw_tot = qw_tot + zqw_col(i)*airephy(i)
    ql_tot = ql_tot + zql_col(i)*airephy(i)
    qs_tot = qs_tot + zqs_col(i)*airephy(i)
    ec_tot = ec_tot + zec_col(i)*airephy(i)
    h_dair_tot = h_dair_tot + zh_dair_col(i)*airephy(i)
    h_qw_tot = h_qw_tot + zh_qw_col(i)*airephy(i)
    h_ql_tot = h_ql_tot + zh_ql_col(i)*airephy(i)
    h_qs_tot = h_qs_tot + zh_qs_col(i)*airephy(i)
    airetot = airetot + airephy(i)
  END DO

  qw_tot = qw_tot/airetot
  ql_tot = ql_tot/airetot
  qs_tot = qs_tot/airetot
  ec_tot = ec_tot/airetot
  h_dair_tot = h_dair_tot/airetot
  h_qw_tot = h_qw_tot/airetot
  h_ql_tot = h_ql_tot/airetot
  h_qs_tot = h_qs_tot/airetot

  h_vcol_tot = h_dair_tot + h_qw_tot + h_ql_tot + h_qs_tot

  ! Compute the change of the atmospheric state compare to the one
  ! stored in "idiag2", and convert it in flux. THis computation
  ! is performed IF idiag2 /= 0 and IF it is not the first CALL
  ! for "idiag"
  ! ===================================

  IF ((idiag2>0) .AND. (pas(idiag2)/=0)) THEN
    d_h_vcol = (h_vcol_tot-h_vcol_pre(idiag2))/dtime
    d_h_dair = (h_dair_tot-h_dair_pre(idiag2))/dtime
    d_h_qw = (h_qw_tot-h_qw_pre(idiag2))/dtime
    d_h_ql = (h_ql_tot-h_ql_pre(idiag2))/dtime
    d_h_qs = (h_qs_tot-h_qs_pre(idiag2))/dtime
    d_qw = (qw_tot-qw_pre(idiag2))/dtime
    d_ql = (ql_tot-ql_pre(idiag2))/dtime
    d_qs = (qs_tot-qs_pre(idiag2))/dtime
    d_ec = (ec_tot-ec_pre(idiag2))/dtime
    d_qt = d_qw + d_ql + d_qs
  ELSE
    d_h_vcol = 0.
    d_h_dair = 0.
    d_h_qw = 0.
    d_h_ql = 0.
    d_h_qs = 0.
    d_qw = 0.
    d_ql = 0.
    d_qs = 0.
    d_ec = 0.
    d_qt = 0.
  END IF

  IF (iprt>=2) THEN
    WRITE (6, 9000) tit, pas(idiag), d_qt, d_qw, d_ql, d_qs
9000 FORMAT ('Phys. Watter Mass Budget (kg/m2/s)', A15, 1I6, 10(1PE14.6))
    WRITE (6, 9001) tit, pas(idiag), d_h_vcol
9001 FORMAT ('Phys. Enthalpy Budget (W/m2) ', A15, 1I6, 10(F8.2))
    WRITE (6, 9002) tit, pas(idiag), d_ec
9002 FORMAT ('Phys. Cinetic Energy Budget (W/m2) ', A15, 1I6, 10(F8.2))
  END IF

  ! Store the new atmospheric state in "idiag"

  pas(idiag) = pas(idiag) + 1
  h_vcol_pre(idiag) = h_vcol_tot
  h_dair_pre(idiag) = h_dair_tot
  h_qw_pre(idiag) = h_qw_tot
  h_ql_pre(idiag) = h_ql_tot
  h_qs_pre(idiag) = h_qs_tot
  qw_pre(idiag) = qw_tot
  ql_pre(idiag) = ql_tot
  qs_pre(idiag) = qs_tot
  ec_pre(idiag) = ec_tot

  RETURN
END SUBROUTINE diagetpq