Back to home page

MITgcm
 
 

    

File indexing completed on 2022-01-06 06:13:27 UTC

view on githubraw file Latest commit 9f5240b5 on 2022-01-05 15:24:45 UTC
fcd60511e1 Jean*0001 #include "THSICE_OPTIONS.h"
                0002 
87ea84cac6 Jean*0003 CBOP
7269783f6f Jean*0004 C     !ROUTINE: THSICE_ALBEDO
87ea84cac6 Jean*0005 C     !INTERFACE:
                0006       SUBROUTINE THSICE_ALBEDO(
7269783f6f Jean*0007      I                  bi, bj, siLo, siHi, sjLo, sjHi,
                0008      I                  iMin,iMax, jMin,jMax,
                0009      I                  iceMask, hIce, hSnow, tSrf, ageSnw,
ce354ad541 Jean*0010      O                  sAlb, sAlbNIR,
7269783f6f Jean*0011      I                  myTime, myIter, myThid )
87ea84cac6 Jean*0012 C     !DESCRIPTION: \bv
fcd60511e1 Jean*0013 C     *==========================================================*
                0014 C     | S/R THSICE_ALBEDO
                0015 C     *==========================================================*
7269783f6f Jean*0016 C     | Compute surface albedo over sea-ice
fcd60511e1 Jean*0017 C     *==========================================================*
87ea84cac6 Jean*0018 C     \ev
                0019 
                0020 C     !USES:
fcd60511e1 Jean*0021       IMPLICIT NONE
                0022 
                0023 C     == Global data ==
dbce8fc2d4 Jean*0024 #include "EEPARAMS.h"
fcd60511e1 Jean*0025 #include "THSICE_PARAMS.h"
                0026 
87ea84cac6 Jean*0027 C     !INPUT/OUTPUT PARAMETERS:
fcd60511e1 Jean*0028 C     == Routine Arguments ==
7269783f6f Jean*0029 C     siLo,siHi   :: size of input/output array: 1rst dim. lower,higher bounds
                0030 C     sjLo,sjHi   :: size of input/output array: 2nd  dim. lower,higher bounds
                0031 C     bi,bj       :: tile indices
                0032 C     iMin,iMax   :: computation domain: 1rst index range
                0033 C     jMin,jMax   :: computation domain: 2nd  index range
                0034 C---  Input:
                0035 C         iceMask :: sea-ice fractional mask [0-1]
                0036 C  hIce    (hi)   :: ice height [m]
                0037 C  hSnow   (hs)   :: snow height [m]
                0038 C  tSrf    (Tsf)  :: surface (ice or snow) temperature [oC]
                0039 C  ageSnw  (age)  :: snow age [s]
                0040 C---  Output
                0041 C  sAlb  (albedo) :: surface albedo [0-1]
ce354ad541 Jean*0042 C  sAlbNIR(albedo):: near IR surface albedo [0-1]
7269783f6f Jean*0043 C---  Input:
                0044 C     myTime      :: current Time of simulation [s]
                0045 C     myIter      :: current Iteration number in simulation
                0046 C     myThid      :: my Thread Id number
                0047       INTEGER siLo, siHi, sjLo, sjHi
                0048       INTEGER bi,bj
                0049       INTEGER iMin, iMax
                0050       INTEGER jMin, jMax
                0051       _RL iceMask(siLo:siHi,sjLo:sjHi)
                0052       _RL hIce   (siLo:siHi,sjLo:sjHi)
                0053       _RL hSnow  (siLo:siHi,sjLo:sjHi)
                0054       _RL tSrf   (siLo:siHi,sjLo:sjHi)
                0055       _RL ageSnw (siLo:siHi,sjLo:sjHi)
                0056       _RL sAlb   (siLo:siHi,sjLo:sjHi)
ce354ad541 Jean*0057       _RL sAlbNIR(siLo:siHi,sjLo:sjHi)
7269783f6f Jean*0058       _RL  myTime
                0059       INTEGER myIter
                0060       INTEGER myThid
                0061 CEOP
                0062 
                0063 #ifdef ALLOW_THSICE
                0064 C     !LOCAL VARIABLES:
                0065 C---  local copy of input/output argument list variables (see description above)
fcd60511e1 Jean*0066       _RL  hi                  ! ice height
                0067       _RL  hs                  ! snow height
                0068       _RL  Tsf                 ! surface temperature
                0069       _RL  age                 ! snow age
                0070       _RL  albedo              ! surface albedo
                0071 C     == Local variables ==
7269783f6f Jean*0072 C     frsnow     :: fractional snow cover
fcd60511e1 Jean*0073 C     albsno     :: albedo of snow
                0074 C     albice     :: albedo of ice
                0075 C     albNewSnow :: albedo of new (fresh) snow
7269783f6f Jean*0076 C     albNewSnow :: albedo of new (fresh) snow
9f5240b52a Jean*0077 C     msgBuf     :: Informational/error message buffer
87ea84cac6 Jean*0078 c     _RL  frsnow
247dc4774e Mart*0079       _RL albsno
                0080       _RL albice
fcd60511e1 Jean*0081       _RL albNewSnow
ce354ad541 Jean*0082       _RL albNIR_ocean, albNIR_thick, albNIR_dsnow
                0083       _RL albNIR_ice, albNIR_fHice, recFac_albNIR
7269783f6f Jean*0084       INTEGER i,j
247dc4774e Mart*0085       INTEGER ii,jj,icount
9f5240b52a Jean*0086 #ifndef ALLOW_AUTODIFF
7269783f6f Jean*0087       CHARACTER*(MAX_LEN_MBUF) msgBuf
9f5240b52a Jean*0088 #endif
7269783f6f Jean*0089 
                0090 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
fcd60511e1 Jean*0091 
ce354ad541 Jean*0092       IF ( thSIce_calc_albNIR ) THEN
                0093 C     Near-InfraRed albedo
                0094         albNIR_ocean = 0.06 _d 0
                0095         albNIR_thick = 0.33 _d 0
                0096         albNIR_dsnow = 0.68 _d 0
                0097         albNIR_fHice = 4. _d 0
                0098         recFac_albNIR = 1. _d 0 / ATAN(albNIR_fHice*0.5 _d 0)
                0099       ENDIF
                0100 
247dc4774e Mart*0101       icount = 0
7269783f6f Jean*0102       DO j = jMin, jMax
                0103        DO i = iMin, iMax
                0104         IF ( iceMask(i,j).GT.0. _d 0 ) THEN
247dc4774e Mart*0105          hi  = hIce(i,j)
                0106          hs  = hSnow(i,j)
                0107          Tsf = tSrf(i,j)
                0108          age = ageSnw(i,j)
9f5240b52a Jean*0109 
7269783f6f Jean*0110 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
fcd60511e1 Jean*0111 C--   Albedo of Bare Sea-Ice
247dc4774e Mart*0112          albice = albIceMax + (albIceMin-albIceMax)*EXP(-hi/hAlbIce)
fcd60511e1 Jean*0113 
                0114 C--   LANL albedo calculation
                0115 c     frsnow = 0.
                0116 c     if (hs .gt. 0.) frsnow = 1.
                0117 c     if (Tsf .lt. 0.) then
                0118 c        albedo = frsnow*albColdSnow + (1.-frsnow)*albice
                0119 c     else
                0120 c        albedo = frsnow*albWarmSnow + (1.-frsnow)*albice
                0121 c     endif
7269783f6f Jean*0122 C-end LANL albedo calculation
fcd60511e1 Jean*0123 
                0124 C--   GISS model albedo calculation
                0125 c     albice = 0.7 _d 0
                0126 
c854f591d1 Jean*0127 C-    New snow: (linear) transition between tempSnowAlb (oC) and 0.oC
fcd60511e1 Jean*0128 C      from cold/dry snow albedo to warm/wet snow albedo
247dc4774e Mart*0129          IF ( tempSnowAlb.LT.0. _d 0 ) THEN
                0130           albNewSnow = albColdSnow
                0131      &         + (albWarmSnow - albColdSnow)
                0132      &         *MAX( 0. _d 0, MIN(1. _d 0 - Tsf/tempSnowAlb, 1. _d 0) )
                0133          ELSE
                0134           albNewSnow = albColdSnow
                0135          ENDIF
fcd60511e1 Jean*0136 C-    albedo of snow is function of snow-age (make age units into days):
247dc4774e Mart*0137          albsno = albOldSnow
                0138      &        +(albNewSnow-albOldSnow)*EXP(-0.2 _d 0*age/86400. _d 0)
fcd60511e1 Jean*0139 C-    layer of snow over the ice:
247dc4774e Mart*0140          albedo = albsno + (albice-albsno)*EXP(-hs/hAlbSnow)
fcd60511e1 Jean*0141 
247dc4774e Mart*0142          IF ( thSIce_calc_albNIR ) THEN
ce354ad541 Jean*0143 C--   Compute near-infrared albedo
247dc4774e Mart*0144           albNIR_ice = albNIR_ocean + (albNIR_thick -  albNIR_ocean)*
                0145      &         MIN( recFac_albNIR*ATAN(albNIR_fHice*hi), 1. _d 0 )
                0146      &         + 0.075 _d 0 * MIN( -Tsf - 1. _d 0, 0. _d 0 )
                0147 
                0148           sAlbNIR(i,j) = albNIR_ice * ( 1. _d 0 - hs/(hs + 0.02 _d 0) )
9f5240b52a Jean*0149      &         + ( albNIR_dsnow
247dc4774e Mart*0150      &             + 0.15 _d 0 *MIN( -Tsf - 1. _d 0, 0. _d 0) )
                0151      &         * hs/(hs + 0.02 _d 0)
                0152          ELSE
                0153           sAlbNIR(i,j) = albedo
                0154          ENDIF
7269783f6f Jean*0155 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
247dc4774e Mart*0156          IF (albedo.GT.1. _d 0 .OR. albedo.LT. .2 _d 0) THEN
                0157 C     test for potential errors (move print statements out of i,j-loops
                0158 C     for vectorization
                0159           ii=i
                0160           jj=j
                0161           icount=icount+1
                0162          ENDIF
                0163          sAlb(i,j) = albedo
7269783f6f Jean*0164         ELSE
247dc4774e Mart*0165          sAlb(i,j) = 0. _d 0
                0166          sAlbNIR(i,j) = 0. _d 0
7269783f6f Jean*0167         ENDIF
                0168        ENDDO
                0169       ENDDO
c1c3d0f9d7 Patr*0170 C
                0171 #ifndef ALLOW_AUTODIFF
247dc4774e Mart*0172 C     catch potential errors
                0173       IF (icount .gt. 0) THEN
                0174 c       print*,'QQ - albedo problem', albedo, age, hs, albsno
                0175        WRITE(msgBuf,'(A,I10,4I6)')
                0176      &      'THSICE_ALBEDO: Problem, e.g., at:', myIter,ii,jj,bi,bj
                0177        CALL PRINT_ERROR( msgBuf , myThid)
                0178        WRITE(msgBuf,'(A,1P3E17.9)')
9f5240b52a Jean*0179      &      'THSICE_ALBEDO: albedo=', sAlb(ii,jj),ageSnw(ii,jj),
247dc4774e Mart*0180      &      hsnow(ii,jj)
                0181        CALL PRINT_ERROR( msgBuf , myThid)
                0182        STOP 'THSICE_ALBEDO: albedo out of range'
                0183       ENDIF
c1c3d0f9d7 Patr*0184 #endif
fcd60511e1 Jean*0185 
                0186 #endif  /* ALLOW_THSICE */
                0187 
                0188 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0189 
                0190       RETURN
                0191       END
[ Source navigation ] [ Diff markup ] [ Identifier search ] [ general search ]

This page was automatically generated from https://github.com/MITgcm/MITgcm by the 2.2.1-MITgcm-0.1 LXR engine.

The LXR team
Valid CSS 2.1! Valid HTML 4.01!