pkg/seaice/seaice_budget_ocean.F

500c623734 Mart*0001 #include "SEAICE_OPTIONS.h"
8377b8ee87 Mart*0002 #ifdef ALLOW_EXF
                0003 # include "EXF_OPTIONS.h"
                0004 #endif
500c623734 Mart*0005
                0006 CStartOfInterface
                0007       SUBROUTINE SEAICE_BUDGET_OCEAN(
                0008      I     UG,
4dbf9a1125 Jean*0009      I     TSURF,
500c623734 Mart*0010      O     netHeatFlux, SWHeatFlux,
1ce2a5cdfd Dimi*0011      I     bi, bj, myTime, myIter, myThid )
4dbf9a1125 Jean*0012 C     *================================================================*
                0013 C     | SUBROUTINE seaice_budget_ocean
                0014 C     | o Calculate surface heat fluxes over open ocean
                0015 C     |   see Hibler, MWR, 108, 1943-1973, 1980
                0016 C     |   If SEAICE_EXTERNAL_FLUXES is defined this routine simply
                0017 C     |   copies the global fields to the seaice-local fields.
                0018 C     *================================================================*
500c623734 Mart*0019       IMPLICIT NONE
                0020
                0021 C     === Global variables ===
                0022 #include "SIZE.h"
                0023 #include "EEPARAMS.h"
                0024 #include "FFIELDS.h"
b4e48588dd Mart*0025 #ifndef SEAICE_EXTERNAL_FLUXES
                0026 # include "PARAMS.h"
                0027 # include "GRID.h"
7303eab4f2 Patr*0028 # include "SEAICE_SIZE.h"
b4e48588dd Mart*0029 # include "SEAICE_PARAMS.h"
                0030 # ifdef ALLOW_EXF
                0031 #  include "EXF_FIELDS.h"
                0032 # endif
ae1fb66b64 Dimi*0033 #endif
500c623734 Mart*0034
                0035 C     === Routine arguments ===
                0036 C     INPUT:
                0037 C     UG      :: thermal wind of atmosphere
4dbf9a1125 Jean*0038 C     TSURF   :: ocean surface temperature in Kelvin
500c623734 Mart*0039 C     bi,bj   :: loop indices
1ce2a5cdfd Dimi*0040 C     myTime  :: Simulation time
                0041 C     myIter  :: Simulation timestep number
7a1536dd10 Mart*0042 C     myThid  :: Thread no. that called this routine.
500c623734 Mart*0043 C     OUTPUT:
                0044 C     netHeatFlux :: net surface heat flux over open water or under ice
                0045 C     SWHeatFlux  :: short wave heat flux over open water or under ice
6eb23881b9 Dimi*0046       _RL UG         (1:sNx,1:sNy)
4dbf9a1125 Jean*0047       _RL TSURF      (1:sNx,1:sNy)
6eb23881b9 Dimi*0048       _RL netHeatFlux(1:sNx,1:sNy)
                0049       _RL SWHeatFlux (1:sNx,1:sNy)
1ce2a5cdfd Dimi*0050       _RL myTime
                0051       INTEGER bi, bj, myIter, myThid
500c623734 Mart*0052 CEndOfInterface
                0053
                0054 C     === Local variables ===
                0055 C     i,j - Loop counters
                0056       INTEGER i, j
                0057 #ifndef SEAICE_EXTERNAL_FLUXES
5552aab1d3 Dimi*0058       _RL  QS1, D1, D1W, D3, TMELT
500c623734 Mart*0059
                0060 C     local copies of global variables
6eb23881b9 Dimi*0061       _RL tsurfLoc   (1:sNx,1:sNy)
                0062       _RL atempLoc   (1:sNx,1:sNy)
                0063       _RL lwdownLoc  (1:sNx,1:sNy)
362c253f5c Mart*0064
500c623734 Mart*0065 C     auxiliary variable
362c253f5c Mart*0066       _RL ssq, sstdegC
                0067       _RL recip_rhoConstFresh, recip_lhEvap
500c623734 Mart*0068
                0069 C NOW DEFINE ASSORTED CONSTANTS
                0070 C SATURATION VAPOR PRESSURE CONSTANT
4dbf9a1125 Jean*0071       QS1=0.622 _d 0/1013.0 _d 0
500c623734 Mart*0072 C SENSIBLE HEAT CONSTANT
fff6be1885 Mart*0073       D1=SEAICE_dalton*SEAICE_cpAir*SEAICE_rhoAir
500c623734 Mart*0074 C WATER LATENT HEAT CONSTANT
fff6be1885 Mart*0075       D1W=SEAICE_dalton*SEAICE_lhEvap*SEAICE_rhoAir
d778130a13 Mart*0076 C STEFAN BOLTZMAN CONSTANT TIMES EMISSIVITY
                0077       D3=SEAICE_emissivity*SEAICE_boltzmann
500c623734 Mart*0078 C MELTING TEMPERATURE OF ICE
adff6dba40 Jean*0079       TMELT = celsius2K
4dbf9a1125 Jean*0080 C
362c253f5c Mart*0081       recip_lhEvap = 1./SEAICE_lhEvap
                0082       recip_rhoConstFresh = 1./rhoConstFresh
500c623734 Mart*0083
8377b8ee87 Mart*0084       DO j=1,sNy
                0085        DO i=1,sNx
                0086         netHeatFlux(i,j) = 0. _d 0
                0087         SWHeatFlux (i,j) = 0. _d 0
4dbf9a1125 Jean*0088 C
042d274f05 Mart*0089 C     MAX_TICE does not exist anly longer, lets see if it works without
                0090 C       tsurfLoc (I,J) = MIN(celsius2K+MAX_TICE,TSURF(I,J))
8377b8ee87 Mart*0091         tsurfLoc (i,j) = TSURF(i,j)
1ce2a5cdfd Dimi*0092 # ifdef ALLOW_ATM_TEMP
500c623734 Mart*0093 C     Is this necessary?
8377b8ee87 Mart*0094         atempLoc (i,j) = MAX(celsius2K+MIN_ATEMP,ATEMP(i,j,bi,bj))
1ce2a5cdfd Dimi*0095 # endif
                0096 # ifdef ALLOW_DOWNWARD_RADIATION
8377b8ee87 Mart*0097         lwdownLoc(i,j) = MAX(MIN_LWDOWN,LWDOWN(i,j,bi,bj))
1ce2a5cdfd Dimi*0098 # endif
500c623734 Mart*0099        ENDDO
                0100       ENDDO
                0101 #endif /* SEAICE_EXTERNAL_FLUXES */
                0102
                0103 C NOW DETERMINE OPEN WATER HEAT BUD. ASSUMING TSURF=WATER TEMP.
                0104 C WATER ALBEDO IS ASSUMED TO BE THE CONSTANT SEAICE_waterAlbedo
8377b8ee87 Mart*0105       DO j=1,sNy
                0106        DO i=1,sNx
500c623734 Mart*0107 #ifdef SEAICE_EXTERNAL_FLUXES
8377b8ee87 Mart*0108         netHeatFlux(i,j) = Qnet(i,j,bi,bj)
                0109         SWHeatFlux (i,j) =  Qsw(i,j,bi,bj)
500c623734 Mart*0110 #else /* SEAICE_EXTERNAL_FLUXES undefined */
4dbf9a1125 Jean*0111 C     This is an example of how one could implement surface fluxes
b4e48588dd Mart*0112 C     over the ocean (if one dislikes the fluxes computed in pkg/exf).
                0113 C     In this example, the exf-fields are re-used so that they no longer
4dbf9a1125 Jean*0114 C     have the same values as at the time when they are saved for
                0115 C     diagnostics (e.g., hl, hs, lwflux, sflux). To properly
b4e48588dd Mart*0116 C     diagnose them, one has to save them again as different (SI-)fields.
1ce2a5cdfd Dimi*0117 # ifdef ALLOW_DOWNWARD_RADIATION
362c253f5c Mart*0118 C     net upward short wave heat flux
8377b8ee87 Mart*0119         SWHeatFlux(i,j) = (SEAICE_waterAlbedo - 1. _d 0)
                0120      &       *swdown(i,j,bi,bj)
d778130a13 Mart*0121 C     lwup = emissivity*stefanBoltzmann*Tsrf^4 + (1-emissivity)*lwdown
                0122 C     the second terms is the reflected incoming long wave radiation
                0123 C     so that the net upward long wave heat flux is:
8377b8ee87 Mart*0124         lwflux(i,j,bi,bj) = - lwdownLoc(i,j)*SEAICE_emissivity
                0125      &       + D3*tsurfLoc(i,j)**4
                0126         sstdegC = tsurfLoc(i,j) - TMELT
362c253f5c Mart*0127 C     downward sensible heat
8377b8ee87 Mart*0128         hs(i,j,bi,bj) = D1*UG(i,j)*(atempLoc(i,j)-tsurfLoc(i,j))
362c253f5c Mart*0129 C     saturation humidity
4dbf9a1125 Jean*0130         ssq = QS1*6.11 _d 0 *EXP( 17.2694 _d 0
                0131      &                           *sstdegC/(sstdegC+237.3 _d 0) )
362c253f5c Mart*0132 C     downward latent heat
8377b8ee87 Mart*0133         hl(i,j,bi,bj) = D1W*UG(i,j)*(AQH(i,j,bi,bj)-ssq)
362c253f5c Mart*0134 C     net heat is positive upward
8377b8ee87 Mart*0135         netHeatFlux(i,j)=SWHeatFlux(i,j)
                0136      &       + lwflux(i,j,bi,bj)
                0137      &       - hs(i,j,bi,bj) - hl(i,j,bi,bj)
4dbf9a1125 Jean*0138 C     compute evaporation here again because latent heat is different
362c253f5c Mart*0139 C     from its previous value
8377b8ee87 Mart*0140         evap(i,j,bi,bj) = -hl(i,j,bi,bj)
b4e48588dd Mart*0141      &       *recip_lhEvap*recip_rhoConstFresh
                0142 C     Salt flux from Precipitation and Evaporation.
                0143         sflux(i,j,bi,bj) = evap(i,j,bi,bj) - precip(i,j,bi,bj)
                0144 #  ifdef ALLOW_RUNOFF
                0145         sflux(i,j,bi,bj) = sflux(i,j,bi,bj) - runoff(i,j,bi,bj)
                0146 #  endif
ec0d7df165 Mart*0147         sflux(i,j,bi,bj) = sflux(i,j,bi,bj)!*HEFFM(i,j,bi,bj)
b4e48588dd Mart*0148         empmr(i,j,bi,bj) = sflux(i,j,bi,bj)*rhoConstFresh
1ce2a5cdfd Dimi*0149 # endif /* ALLOW_DOWNWARD_RADIATION */
500c623734 Mart*0150 #endif /* SEAICE_EXTERNAL_FLUXES */
                0151        ENDDO
                0152       ENDDO
                0153
                0154       RETURN
                0155       END