pkg/thsice/thsice_albedo.F

C $Header: /u/gcmpack/MITgcm/pkg/thsice/thsice_albedo.F,v 1.3 2004/12/17 03:44:52 jmc Exp $
C $Name:  $

#include "THSICE_OPTIONS.h"

CBOP
C     !ROUTINE: THSICE_ALBEDO
C     !INTERFACE:
      SUBROUTINE THSICE_ALBEDO(
     I                  bi, bj, siLo, siHi, sjLo, sjHi,
     I                  iMin,iMax, jMin,jMax,
     I                  iceMask, hIce, hSnow, tSrf, ageSnw,
     O                  sAlb,
     I                  myTime, myIter, myThid )
C     !DESCRIPTION: \bv
C     *==========================================================*
C     | S/R THSICE_ALBEDO
C     *==========================================================*
C     | Compute surface albedo over sea-ice
C     *==========================================================*
C     \ev

C     !USES:
      IMPLICIT NONE

C     == Global data ==
#include "EEPARAMS.h"
#include "THSICE_PARAMS.h"

C     !INPUT/OUTPUT PARAMETERS:
C     == Routine Arguments ==
C     siLo,siHi   :: size of input/output array: 1rst dim. lower,higher bounds
C     sjLo,sjHi   :: size of input/output array: 2nd  dim. lower,higher bounds
C     bi,bj       :: tile indices
C     iMin,iMax   :: computation domain: 1rst index range
C     jMin,jMax   :: computation domain: 2nd  index range
C---  Input:
C         iceMask :: sea-ice fractional mask [0-1]
C  hIce    (hi)   :: ice height [m]
C  hSnow   (hs)   :: snow height [m]
C  tSrf    (Tsf)  :: surface (ice or snow) temperature [oC]
C  ageSnw  (age)  :: snow age [s]
C---  Output
C  sAlb  (albedo) :: surface albedo [0-1]
C---  Input:
C     myTime      :: current Time of simulation [s]
C     myIter      :: current Iteration number in simulation
C     myThid      :: my Thread Id number
      INTEGER siLo, siHi, sjLo, sjHi
      INTEGER bi,bj
      INTEGER iMin, iMax
      INTEGER jMin, jMax
      _RL iceMask(siLo:siHi,sjLo:sjHi)
      _RL hIce   (siLo:siHi,sjLo:sjHi)
      _RL hSnow  (siLo:siHi,sjLo:sjHi)
      _RL tSrf   (siLo:siHi,sjLo:sjHi)
      _RL ageSnw (siLo:siHi,sjLo:sjHi)
      _RL sAlb   (siLo:siHi,sjLo:sjHi)
      _RL  myTime
      INTEGER myIter
      INTEGER myThid
CEOP

#ifdef ALLOW_THSICE
C     !LOCAL VARIABLES:
C---  local copy of input/output argument list variables (see description above)
      _RL  hi                  ! ice height
      _RL  hs                  ! snow height
      _RL  Tsf                 ! surface temperature
      _RL  age                 ! snow age
      _RL  albedo              ! surface albedo
C     == Local variables ==
C     frsnow     :: fractional snow cover
C     albsno     :: albedo of snow
C     albice     :: albedo of ice
C     albNewSnow :: albedo of new (fresh) snow
C     albNewSnow :: albedo of new (fresh) snow
C     msgBuf     :: Informational/error meesage buffer
c     _RL  frsnow
      _RL albsno, albice
      _RL albNewSnow
      INTEGER i,j
      CHARACTER*(MAX_LEN_MBUF) msgBuf

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      DO j = jMin, jMax
       DO i = iMin, iMax
        IF ( iceMask(i,j).GT.0. _d 0 ) THEN
          hi  = hIce(i,j)
          hs  = hSnow(i,j)
          Tsf = tSrf(i,j)
          age = ageSnw(i,j)

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
C--   Albedo of Bare Sea-Ice
      albice = albIceMax + (albIceMin-albIceMax)*EXP(-hi/hAlbIce)

C--   LANL albedo calculation
c     frsnow = 0.
c     if (hs .gt. 0.) frsnow = 1.
c     if (Tsf .lt. 0.) then
c        albedo = frsnow*albColdSnow + (1.-frsnow)*albice
c     else
c        albedo = frsnow*albWarmSnow + (1.-frsnow)*albice
c     endif
C-end LANL albedo calculation

C--   GISS model albedo calculation
c     albice = 0.7 _d 0

C-    New snow: (linear) transition between -10.oC and 0.oC
C      from cold/dry snow albedo to warm/wet snow albedo
      albNewSnow = albColdSnow
     &      + (albWarmSnow - albColdSnow)
     &       *MAX( 0. _d 0, 1. _d 0 + MIN(Tsf/10. _d 0, 0. _d 0) )
C-    albedo of snow is function of snow-age (make age units into days):
      albsno = albOldSnow
     &       +(albNewSnow-albOldSnow)*EXP(-0.2 _d 0*age/86400. _d 0)
C-    layer of snow over the ice:
      albedo = albsno + (albice-albsno)*EXP(-hs/hAlbSnow)

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
          IF (albedo.GT.1. _d 0 .OR. albedo.LT. .2 _d 0) THEN
c       print*,'QQ - albedo problem', albedo, age, hs, albsno
            WRITE(msgBuf,'(A,I10,4I6)')
     &       'THSICE_ALBEDO: Problem at:', myIter,i,j,bi,bj
            CALL PRINT_ERROR( msgBuf , myThid)
            WRITE(msgBuf,'(A,1P4E17.9)')
     &       'THSICE_ALBEDO: albedo=', albedo, age, hs, albsno
            CALL PRINT_ERROR( msgBuf , myThid)
            STOP 'THSICE_ALBEDO: albedo out of range'
          ENDIF
          sAlb(i,j) = albedo
        ELSE
          sAlb(i,j) = 0. _d 0
        ENDIF
       ENDDO
      ENDDO

#endif  /* ALLOW_THSICE */

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      RETURN
      END
1	jmc	1.4	C $Header: /u/gcmpack/MITgcm/pkg/thsice/thsice_albedo.F,v 1.3 2004/12/17 03:44:52 jmc Exp $
2	jmc	1.1	C $Name: $
3
4			#include "THSICE_OPTIONS.h"
5
6	jmc	1.2	CBOP
7	jmc	1.4	C !ROUTINE: THSICE_ALBEDO
8	jmc	1.2	C !INTERFACE:
9			SUBROUTINE THSICE_ALBEDO(
10	jmc	1.4	I bi, bj, siLo, siHi, sjLo, sjHi,
11			I iMin,iMax, jMin,jMax,
12			I iceMask, hIce, hSnow, tSrf, ageSnw,
13			O sAlb,
14			I myTime, myIter, myThid )
15	jmc	1.2	C !DESCRIPTION: \bv
16	jmc	1.1	C ==========================================================
17			C \| S/R THSICE_ALBEDO
18			C ==========================================================
19	jmc	1.4	C \| Compute surface albedo over sea-ice
20	jmc	1.1	C ==========================================================
21	jmc	1.2	C \ev
22
23			C !USES:
24	jmc	1.1	IMPLICIT NONE
25
26			C == Global data ==
27	jmc	1.3	#include "EEPARAMS.h"
28	jmc	1.1	#include "THSICE_PARAMS.h"
29
30	jmc	1.2	C !INPUT/OUTPUT PARAMETERS:
31	jmc	1.1	C == Routine Arguments ==
32	jmc	1.4	C siLo,siHi :: size of input/output array: 1rst dim. lower,higher bounds
33			C sjLo,sjHi :: size of input/output array: 2nd dim. lower,higher bounds
34			C bi,bj :: tile indices
35			C iMin,iMax :: computation domain: 1rst index range
36			C jMin,jMax :: computation domain: 2nd index range
37			C--- Input:
38			C iceMask :: sea-ice fractional mask [0-1]
39			C hIce (hi) :: ice height [m]
40			C hSnow (hs) :: snow height [m]
41			C tSrf (Tsf) :: surface (ice or snow) temperature [oC]
42			C ageSnw (age) :: snow age [s]
43			C--- Output
44			C sAlb (albedo) :: surface albedo [0-1]
45			C--- Input:
46			C myTime :: current Time of simulation [s]
47			C myIter :: current Iteration number in simulation
48			C myThid :: my Thread Id number
49			INTEGER siLo, siHi, sjLo, sjHi
50			INTEGER bi,bj
51			INTEGER iMin, iMax
52			INTEGER jMin, jMax
53			_RL iceMask(siLo:siHi,sjLo:sjHi)
54			_RL hIce (siLo:siHi,sjLo:sjHi)
55			_RL hSnow (siLo:siHi,sjLo:sjHi)
56			_RL tSrf (siLo:siHi,sjLo:sjHi)
57			_RL ageSnw (siLo:siHi,sjLo:sjHi)
58			_RL sAlb (siLo:siHi,sjLo:sjHi)
59			_RL myTime
60			INTEGER myIter
61			INTEGER myThid
62			CEOP
63
64			#ifdef ALLOW_THSICE
65			C !LOCAL VARIABLES:
66			C--- local copy of input/output argument list variables (see description above)
67	jmc	1.1	_RL hi ! ice height
68			_RL hs ! snow height
69			_RL Tsf ! surface temperature
70			_RL age ! snow age
71			_RL albedo ! surface albedo
72			C == Local variables ==
73	jmc	1.4	C frsnow :: fractional snow cover
74	jmc	1.1	C albsno :: albedo of snow
75			C albice :: albedo of ice
76			C albNewSnow :: albedo of new (fresh) snow
77	jmc	1.4	C albNewSnow :: albedo of new (fresh) snow
78			C msgBuf :: Informational/error meesage buffer
79	jmc	1.2	c _RL frsnow
80	jmc	1.1	_RL albsno, albice
81			_RL albNewSnow
82	jmc	1.4	INTEGER i,j
83			CHARACTER*(MAX_LEN_MBUF) msgBuf
84
85			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
86	jmc	1.1
87	jmc	1.4	DO j = jMin, jMax
88			DO i = iMin, iMax
89			IF ( iceMask(i,j).GT.0. _d 0 ) THEN
90			hi = hIce(i,j)
91			hs = hSnow(i,j)
92			Tsf = tSrf(i,j)
93			age = ageSnw(i,j)
94
95			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
96	jmc	1.1	C-- Albedo of Bare Sea-Ice
97	jmc	1.4	albice = albIceMax + (albIceMin-albIceMax)*EXP(-hi/hAlbIce)
98	jmc	1.1
99			C-- LANL albedo calculation
100			c frsnow = 0.
101			c if (hs .gt. 0.) frsnow = 1.
102			c if (Tsf .lt. 0.) then
103			c albedo = frsnowalbColdSnow + (1.-frsnow)albice
104			c else
105			c albedo = frsnowalbWarmSnow + (1.-frsnow)albice
106			c endif
107	jmc	1.4	C-end LANL albedo calculation
108	jmc	1.1
109			C-- GISS model albedo calculation
110			c albice = 0.7 _d 0
111
112			C- New snow: (linear) transition between -10.oC and 0.oC
113			C from cold/dry snow albedo to warm/wet snow albedo
114			albNewSnow = albColdSnow
115			& + (albWarmSnow - albColdSnow)
116			& *MAX( 0. _d 0, 1. _d 0 + MIN(Tsf/10. _d 0, 0. _d 0) )
117			C- albedo of snow is function of snow-age (make age units into days):
118			albsno = albOldSnow
119	jmc	1.4	& +(albNewSnow-albOldSnow)EXP(-0.2 _d 0age/86400. _d 0)
120	jmc	1.1	C- layer of snow over the ice:
121	jmc	1.4	albedo = albsno + (albice-albsno)*EXP(-hs/hAlbSnow)
122	jmc	1.1
123	jmc	1.4	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
124			IF (albedo.GT.1. _d 0 .OR. albedo.LT. .2 _d 0) THEN
125			c print*,'QQ - albedo problem', albedo, age, hs, albsno
126			WRITE(msgBuf,'(A,I10,4I6)')
127			& 'THSICE_ALBEDO: Problem at:', myIter,i,j,bi,bj
128			CALL PRINT_ERROR( msgBuf , myThid)
129			WRITE(msgBuf,'(A,1P4E17.9)')
130			& 'THSICE_ALBEDO: albedo=', albedo, age, hs, albsno
131			CALL PRINT_ERROR( msgBuf , myThid)
132			STOP 'THSICE_ALBEDO: albedo out of range'
133			ENDIF
134			sAlb(i,j) = albedo
135			ELSE
136			sAlb(i,j) = 0. _d 0
137			ENDIF
138			ENDDO
139			ENDDO
140	jmc	1.1
141			#endif /* ALLOW_THSICE */
142
143			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
144
145			RETURN
146			END