pkg/thsice/thsice_get_bulkf.F

fc7306ba7d Jean*0001 #include "THSICE_OPTIONS.h"
df91b0899e Jean*0002 #ifdef ALLOW_BULK_FORCE
                0003 #include "BULK_FORCE_OPTIONS.h"
                0004 #endif
fc7306ba7d Jean*0005
87ea84cac6 Jean*0006 CBOP
                0007 C     !ROUTINE: THSICE_GET_BULKF
                0008 C     !INTERFACE:
fc7306ba7d Jean*0009       SUBROUTINE THSICE_GET_BULKF(
6dc8890c80 Patr*0010      I                  bi, bj,
9dcf02c6ac Jean*0011      I                  iMin,iMax, jMin,jMax,
c1c3d0f9d7 Patr*0012      I                  icFlag, hSnow, Tsf,
9dcf02c6ac Jean*0013      O                  flxExcSw, dFlxdT, evap, dEvdT,
                0014      I                  myTime, myIter, myThid )
87ea84cac6 Jean*0015 C     !DESCRIPTION: \bv
fc7306ba7d Jean*0016 C     *==========================================================*
df91b0899e Jean*0017 C     | S/R  THSICE_GET_BULKF
fc7306ba7d Jean*0018 C     *==========================================================*
                0019 C     | Interface S/R : get Surface Fluxes from pkg BULK_FORCE
                0020 C     *==========================================================*
87ea84cac6 Jean*0021 C     \ev
                0022
                0023 C     !USES:
fc7306ba7d Jean*0024       IMPLICIT NONE
                0025
                0026 C     == Global data ==
                0027 #include "SIZE.h"
9dcf02c6ac Jean*0028 #ifdef ALLOW_BULK_FORCE
fc7306ba7d Jean*0029 #include "EEPARAMS.h"
df91b0899e Jean*0030 #include "BULKF_PARAMS.h"
fc7306ba7d Jean*0031 #include "BULKF.h"
                0032 #endif
                0033
87ea84cac6 Jean*0034 C     !INPUT/OUTPUT PARAMETERS:
fc7306ba7d Jean*0035 C     === Routine arguments ===
9dcf02c6ac Jean*0036 C     bi,bj       :: tile indices
                0037 C     iMin,iMax   :: computation domain: 1rst index range
                0038 C     jMin,jMax   :: computation domain: 2nd  index range
c1c3d0f9d7 Patr*0039 C     icFlag     :: sea-ice fractional mask [0-1]
                0040 C     icFlag     :: True= get fluxes at this location ; False= do nothing
170766e9fd Jean*0041 C     hSnow       :: snow height [m]
87ea84cac6 Jean*0042 C     Tsf         :: surface (ice or snow) temperature (oC)
9dcf02c6ac Jean*0043 C     flxExcSw    :: net (downward) surface heat flux, except short-wave [W/m2]
                0044 C     dFlxdT      :: deriv of flx with respect to Tsf    [W/m/K]
87ea84cac6 Jean*0045 C     evap        :: surface evaporation (>0 if evaporate) [kg/m2/s]
                0046 C     dEvdT       :: deriv of evap. with respect to Tsf  [kg/m2/s/K]
fc7306ba7d Jean*0047 C     myThid      :: Thread no. that called this routine.
9dcf02c6ac Jean*0048       INTEGER bi, bj
                0049       INTEGER iMin, iMax
                0050       INTEGER jMin, jMax
c1c3d0f9d7 Patr*0051       _RL     icFlag  (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
6dc8890c80 Patr*0052       _RL     hSnow   (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
9dcf02c6ac Jean*0053       _RL     Tsf     (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0054       _RL     flxExcSw(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0055       _RL     dFlxdT  (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0056       _RL     evap    (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0057       _RL     dEvdT   (1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0058       _RL     myTime
                0059       INTEGER myIter
170766e9fd Jean*0060       INTEGER myThid
87ea84cac6 Jean*0061 CEOP
fc7306ba7d Jean*0062
                0063 #ifdef ALLOW_THSICE
                0064 #ifdef ALLOW_BULK_FORCE
                0065
                0066 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0067 C     === Local variables ===
170766e9fd Jean*0068 C     iceornot    :: 0=open water, 1=ice cover, 2=ice+snow
                0069       INTEGER iceornot
9dcf02c6ac Jean*0070       INTEGER i, j
fc7306ba7d Jean*0071       _RL  flwup         ! upward LW at surface (W m-2)
                0072       _RL  flwNet_dwn    ! net (downward) LW at surface (W m-2)
                0073       _RL  fsh           ! surface downward sensible heat (W m-2)
                0074       _RL  flh           ! surface downward latent heat (W m-2)
                0075       _RL  ust, vst, ssq
df91b0899e Jean*0076 #ifdef ALLOW_FORMULA_AIM
                0077       _RL     Tsurf(1), SHF(1), EVPloc(1), SLRU(1)
                0078       _RL     dEvp(1), sFlx(0:2)
                0079 #endif
                0080
9dcf02c6ac Jean*0081       DO j=jMin,jMax
                0082        DO i=iMin,iMax
c1c3d0f9d7 Patr*0083         IF ( icFlag(i,j).GT.0. _d 0 ) THEN
9dcf02c6ac Jean*0084 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0085
                0086          IF ( hSnow(i,j).GT.3. _d -1 ) THEN
170766e9fd Jean*0087           iceornot=2
9dcf02c6ac Jean*0088          ELSE
170766e9fd Jean*0089           iceornot=1
9dcf02c6ac Jean*0090          ENDIF
170766e9fd Jean*0091
df91b0899e Jean*0092 #ifdef ALLOW_FORMULA_AIM
9dcf02c6ac Jean*0093          IF ( useFluxFormula_AIM ) THEN
                0094
                0095           Tsurf(1) = Tsf(i,j)
                0096           CALL BULKF_FORMULA_AIM(
                0097      I               Tsurf, flwdwn(i,j,bi,bj),
                0098      I               ThAir(i,j,bi,bj), Tair(i,j,bi,bj),
                0099      I               Qair(i,j,bi,bj), wspeed(i,j,bi,bj),
                0100      O               SHF, EVPloc, SLRU,
                0101      O               dEvp, sFlx,
                0102      I               iceornot, myThid )
                0103
                0104           flxExcSw(i,j) = sFlx(1)
                0105           dFlxdT(i,j)   = sFlx(2)
df91b0899e Jean*0106 C-      convert from [g/m2/s] to [kg/m2/s]
9dcf02c6ac Jean*0107           evap(i,j)  = EVPloc(1) * 1. _d -3
                0108           dEvdT(i,j) = dEvp(1)   * 1. _d -3
df91b0899e Jean*0109
9dcf02c6ac Jean*0110          ELSE
df91b0899e Jean*0111 #else  /* ALLOW_FORMULA_AIM */
9dcf02c6ac Jean*0112          IF ( .TRUE. ) THEN
df91b0899e Jean*0113 #endif /* ALLOW_FORMULA_AIM */
                0114
9dcf02c6ac Jean*0115           ust = 0.
                0116           vst = 0.
                0117           ssq = 0.
                0118
                0119           IF ( blk_nIter.EQ.0 ) THEN
                0120            CALL BULKF_FORMULA_LANL(
                0121      I          uwind(i,j,bi,bj), vwind(i,j,bi,bj), wspeed(i,j,bi,bj),
                0122      I          Tair(i,j,bi,bj), Qair(i,j,bi,bj),
                0123      I          cloud(i,j,bi,bj), Tsf(i,j),
                0124      O          flwup, flh, fsh, dFlxdT(i,j), ust, vst,
                0125      O          evap(i,j), ssq, dEvdT(i,j),
                0126      I          iceornot, myThid )
                0127           ELSE
                0128            CALL BULKF_FORMULA_LAY(
                0129      I          uwind(i,j,bi,bj), vwind(i,j,bi,bj), wspeed(i,j,bi,bj),
                0130      I          Tair(i,j,bi,bj), Qair(i,j,bi,bj), Tsf(i,j),
                0131      O          flwup, flh, fsh, dFlxdT(i,j), ust, vst,
                0132      O          evap(i,j), ssq, dEvdT(i,j),
                0133      I          iceornot, i,j,bi,bj,myThid )
                0134           ENDIF
                0135
                0136           flwNet_dwn = flwdwn(i,j,bi,bj) - flwup
                0137           flxExcSw(i,j) = flwNet_dwn + fsh + flh
                0138
                0139          ENDIF
fc7306ba7d Jean*0140
                0141 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
9dcf02c6ac Jean*0142         ENDIF
                0143        ENDDO
                0144       ENDDO
fc7306ba7d Jean*0145
                0146 #endif /* ALLOW_BULK_FORCE */
                0147 #endif /* ALLOW_THSICE */
                0148
                0149       RETURN
                0150       END