pkg/aim_v23/phy_suflux_post.F

b3097ed02d Jean*0001 #include "AIM_OPTIONS.h"
                0002
                0003 CBOP
                0004 C     !ROUTINE: SUFLUX_POST
                0005 C     !INTERFACE:
                0006       SUBROUTINE SUFLUX_POST(
                0007      I                   FMASK, EMISloc,
                0008      I                   TLAND, TSEA, TSICE, dTskin, SLRD,
e749d70ece Jean*0009      I                   T0, Q0, DENVV,
b3097ed02d Jean*0010      U                   DRAG, SHF, EVAP, SLRup,
                0011      O                   SLRU, TSFC, TSKIN,
                0012      I                   bi,bj,myThid)
                0013
                0014 C     !DESCRIPTION: \bv
                0015 C     *==========================================================*
                0016 C     | S/R SUFLUX_POST
                0017 C     | o finish surface flux calculation
                0018 C     *==========================================================*
                0019 C     | o contain 2nd part of original S/R SUFLUX (Speedy code)
                0020 C     *==========================================================*
                0021 C--
                0022 C--   SUBROUTINE SUFLUX (PSA,UA,VA,TA,QA,RH,PHI,
                0023 C--  &                   PHI0,FMASK,TLAND,TSEA,SWAV,SSR,SLRD,
                0024 C--  &                   USTR,VSTR,SHF,EVAP,SLRU,
                0025 C--  &                   TSFC,TSKIN,U0,V0,T0,Q0)
                0026 C--
                0027 C--   Purpose: Compute surface fluxes of momentum, energy and moisture,
                0028 C--            and define surface skin temperature from energy balance
                0029 C     *==========================================================*
                0030 C     \ev
                0031
                0032 C     !USES:
                0033       IMPLICIT NONE
                0034
                0035 C     Resolution parameters
                0036
                0037 C-- size for MITgcm & Physics package :
                0038 #include "AIM_SIZE.h"
                0039
                0040 #include "EEPARAMS.h"
cdcb187d4c Jean*0041 #include "GRID.h"
b3097ed02d Jean*0042
                0043 C     Physical constants + functions of sigma and latitude
                0044 #include "com_physcon.h"
                0045
                0046 C     Surface flux constants
                0047 #include "com_sflcon.h"
                0048
                0049 C     !INPUT/OUTPUT PARAMETERS:
                0050 C     == Routine Arguments ==
                0051 C--   Input:
                0052 C    FMASK  :: fraction land - sea - sea-ice (2.5-dim)
                0053 C    EMISloc:: longwave surface emissivity
                0054 C    TLAND  :: land-surface temperature        (2-dim)
                0055 C    TSEA   ::  sea-surface temperature        (2-dim)
                0056 C    TSICE  ::  sea-ice surface temperature    (2-dim)
                0057 C    dTskin :: temp. correction for daily-cycle heating [K]
                0058 C    SLRD   :: sfc lw radiation (downward flux)(2-dim)
                0059 C    SSR    :: sfc sw radiation (net flux)     (2-dim)
                0060 C    T0     :: near-surface air temperature    (2-dim)
                0061 C    Q0     :: near-surface sp. humidity [g/kg](2-dim)
e749d70ece Jean*0062 C    DENVV  :: surface flux (sens,lat.) coeff. (=Rho*|V|) [kg/m2/s]
b3097ed02d Jean*0063 C--   Output:
                0064 C    DRAG   :: surface Drag term (= Cd*Rho*|V|)(2-dim)
                0065 C    SHF    :: sensible heat flux              (2-dim)
                0066 C    EVAP   :: evaporation [g/(m^2 s)]         (2-dim)
                0067 C    SLRU   :: sfc lw radiation (upward flux)  (2-dim)
                0068 C    SLRup  :: same, for each surface type     (2-dim)
                0069 C    TSFC   :: surface temperature (clim.)     (2-dim)
                0070 C    TSKIN  :: skin surface temperature        (2-dim)
                0071 C--   Input:
                0072 C    bi,bj  :: tile index
                0073 C    myThid :: Thread number for this instance of the routine
                0074 C--
                0075       _RL  FMASK(NGP,3), EMISloc
                0076       _RL  TLAND(NGP), TSEA(NGP), TSICE(NGP), dTskin(NGP), SLRD(NGP)
e749d70ece Jean*0077       _RL  T0(NGP), Q0(NGP), DENVV(NGP)
b3097ed02d Jean*0078
                0079       _RL  DRAG(NGP,0:3), SHF(NGP,0:3), EVAP(NGP,0:3), SLRup(NGP,3)
                0080       _RL  SLRU(NGP), TSFC(NGP), TSKIN(NGP)
                0081
                0082       INTEGER bi,bj,myThid
                0083 CEOP
                0084
                0085 #ifdef ALLOW_AIM
                0086
                0087 C-- Local variables:
cdcb187d4c Jean*0088 C     J,i1,j1 :: Loop counters
                0089 C     msgBuf  :: Informational/error message buffer
                0090       INTEGER J,i1,j1
                0091       CHARACTER*(MAX_LEN_MBUF) msgBuf
b3097ed02d Jean*0092
                0093 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0094
                0095 C--   1. Extrapolation of wind, temp, hum. and density to the surface
                0096
                0097 C--   2. Computation of fluxes over land and sea
                0098
                0099 C--   3. Adjustment of skin temperature and fluxes over land
                0100 C--      based on energy balance (to be implemented)
                0101
                0102
                0103 C--   4. Weighted average of surface fluxes and temperatures
                0104 C--      according to land-sea mask
                0105
                0106       DO J=1,NGP
                0107 c       USTR(J,3) = USTR(J,2)+FMASK(J,1)*(USTR(J,1)-USTR(J,2))
                0108 c       VSTR(J,3) = VSTR(J,2)+FMASK(J,1)*(VSTR(J,1)-VSTR(J,2))
                0109 c       DRAG(J,0) = DRAG(J,2)+FMASK(J,1)*(DRAG(J,1)-DRAG(J,2))
                0110 c        SHF(J,0) =  SHF(J,2)+FMASK(J,1)*( SHF(J,1)- SHF(J,2))
                0111 c       EVAP(J,0) = EVAP(J,2)+FMASK(J,1)*(EVAP(J,1)-EVAP(J,2))
                0112 c       SLRU(J)  = SLRup(J,2)+FMASK(J,1)*(SLRup(J,1)-SLRup(J,2))
                0113         DRAG(J,0) = (FMASK(J,1)*DRAG(J,1)+FMASK(J,2)*DRAG(J,2)
                0114      &                                   +FMASK(J,3)*DRAG(J,3))
                0115         SHF (J,0) = (FMASK(J,1)*SHF(J,1) +FMASK(J,2)*SHF(J,2)
                0116      &                                   +FMASK(J,3)*SHF(J,3) )
                0117         EVAP(J,0) = (FMASK(J,1)*EVAP(J,1)+FMASK(J,2)*EVAP(J,2)
                0118      &                                   +FMASK(J,3)*EVAP(J,3))
                0119         SLRU(J)  = (FMASK(J,1)*SLRup(J,1)+FMASK(J,2)*SLRup(J,2)
                0120      &                                   +FMASK(J,3)*SLRup(J,3))
                0121       ENDDO
                0122
                0123       DO J=1,NGP
                0124 c       TSFC(J)  = TSEA(J)+FMASK(J,1)*(TLAND(J)-TSEA(J))
                0125         TSFC(J)  = (FMASK(J,1)*TLAND(J) + FMASK(J,2)*TSEA(J)
                0126      &                                  + FMASK(J,3)*TSICE(J))
                0127         TSKIN(J) = TSFC(J)+FMASK(J,1)*dTskin(J)
                0128       ENDDO
                0129
                0130 C-    Compute Net LW surf flux (+=upward) for each surface type:
                0131 C      (for diagnostic only)
                0132       DO J=1,NGP
                0133         SLRup(J,1)=EMISloc*SLRup(J,1)-SLRD(J)
                0134         SLRup(J,2)=EMISloc*SLRup(J,2)-SLRD(J)
                0135         SLRup(J,3)=EMISloc*SLRup(J,3)-SLRD(J)
e749d70ece Jean*0136         SLRU(J)   =EMISloc*SLRU(J)
b3097ed02d Jean*0137       ENDDO
                0138
cdcb187d4c Jean*0139 C-    Check that Temp is OK for LW Radiation scheme :
                0140        DO J=1,NGP
                0141         IF (  TSFC(J).LT.lwTemp1 .OR.
                0142      &        TSFC(J).GT.lwTemp2 ) THEN
                0143          i1 = 1 + mod((J-1),sNx)
                0144          j1 = 1 + int((J-1)/sNx)
                0145          WRITE(msgBuf,'(A,1PE20.13,A,2I4)')
                0146      &    'SUFLUX_POST: TS=', TSFC(J),
                0147      &    ' out of range ',lwTemp1,lwTemp2
                0148          CALL PRINT_ERROR( msgBuf , myThid)
                0149          WRITE(msgBuf,'(A,1P3E10.3,A,0P3F8.5)')
                0150      &    'SUFLUX_POST: T_Lnd,Sea,Sic=',TLAND(J),TSEA(J),TSICE(J),
                0151      &                ' Mask:',FMASK(J,1),FMASK(J,2),FMASK(J,3)
                0152          CALL PRINT_ERROR( msgBuf , myThid)
                0153          WRITE(msgBuf,'(A,2I4,3I3,I6,2F9.3)')
                0154      &    'SUFLUX_POST: Pb in i,j,bi,bj,myThid,IJ,X,Y=',
                0155      &        i1,j1,bi,bj,myThid,J,xC(i1,j1,bi,bj),yC(i1,j1,bi,bj)
                0156          CALL PRINT_ERROR( msgBuf , myThid)
                0157          STOP 'ABNORMAL END: S/R SUFLUX_POST'
                0158         ENDIF
                0159        ENDDO
                0160
b3097ed02d Jean*0161 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0162 #endif /* ALLOW_AIM */
                0163
                0164       RETURN
                0165       END