model/src/swfrac.F

C $Header: /u/gcmpack/MITgcm/model/src/swfrac.F,v 1.10 2003/10/09 04:19:18 edhill Exp $
C $Name:  $

#include "PACKAGES_CONFIG.h"
#include "CPP_OPTIONS.h"

CBOP
C     !ROUTINE: SWFRAC
C     !INTERFACE:
      SUBROUTINE SWFRAC(
     I     imax, fact,
     I     mytime, mythid,
     U     swdk )
C     !DESCRIPTION: \bv
C     *==========================================================*
C     | SUBROUTINE SWFRAC                                         
C     | o Compute solar short-wave flux penetration.
C     *==========================================================*
C     | Compute fraction of solar short-wave flux penetrating to  
C     | specified depth, swdk, due to exponential decay in        
C     | Jerlov water type jwtype.                                 
C     | Reference : Two band solar absorption model of Paulson    
C     |             and Simpson (1977, JPO, 7, 952-956)           
C     | Notes                                                     
C     | =====                                                     
C     | Parameter jwtype is hardcoded to 3 for time being.        
C     | Below 200m the solar penetration gets set to zero,        
C     | otherwise the limit for the exponent (+/- 5678) needs to   
C     | be taken care of.                                         
C     | Written by   : Jan Morzel                                 
C     | Date         : July 12, 1995                              
C     *==========================================================*
C     \ev

C     !USES:
      IMPLICIT NONE

C     !INPUT/OUTPUT PARAMETERS:
C     === Routine arguments ===
C     input arguments
C     imax    :: number of vertical grid points
C     fact    :: scale  factor to apply to depth array
C     myTime  :: current time in simulation
C     myThid  :: thread number for this instance of the routine.
      INTEGER imax
      _RL     fact
      _RL     mytime
      integer mythid
C     input/output arguments
C     swdk    :: on input: vertical depth for desired sw fraction
C               (fact*swdk) is negative distance (m) from surface
C     swdk    :: on output: short wave (radiation) fractional decay
      _RL     swdk(imax)

C     !LOCAL VARIABLES:
C     === Local variables ===
C     max number of different water types 
      integer   nwtype  , jwtype
      PARAMETER(nwtype=5)
      _RL facz
      _RL rfac(nwtype),a1(nwtype),a2(nwtype)
      INTEGER i
#ifdef ALLOW_CAL
      _RL     fac
      logical first, changed
      integer count0, count1
      integer myiter
      integer jerl(12)
      data jerl / 2 , 2 , 2 , 3 , 3 , 3 , 4 , 4 , 4 , 4 , 3 , 2 /
#endif /* ALLOW_CAL */
C
C     Jerlov water type :  I       IA      IB      II      III
C                jwtype    1       2       3       4       5
C
      DATA rfac         /  0.58 ,  0.62 ,  0.67 ,  0.77 ,  0.78 /
      DATA a1           /  0.35 ,  0.6  ,  1.0  ,  1.5  ,  1.4  /
      DATA a2           / 23.0  , 20.0  , 17.0  , 14.0  ,  7.9  /
CEOP

#ifdef ALLOW_CAL
ceh3 this should have an IF ( useCALENDAR ) THEN
      myiter=0
      call  cal_GetMonthsRec(
     O     fac, first, changed, count0, count1,
     I     mytime, myiter, mythid )
      jwtype=jerl(count0)
#else /* ALLOW_CAL undef */
      jwtype=2
#endif /* ALLOW_CAL */

      DO i = 1,imax
         facz = fact*swdk(i)
         IF (facz .LT. (-200.)) THEN
            swdk(i) = 0.
         ELSE
            swdk(i) =       rfac(jwtype)  * exp(facz/a1(jwtype))
     $                + (1.-rfac(jwtype)) * exp(facz/a2(jwtype))
         ENDIF
      ENDDO

      RETURN
      END
1	heimbach	1.11	C $Header: /u/gcmpack/MITgcm/model/src/swfrac.F,v 1.10 2003/10/09 04:19:18 edhill Exp $
2	cnh	1.9	C $Name: $
3	adcroft	1.1
4	edhill	1.10	#include "PACKAGES_CONFIG.h"
5	adcroft	1.1	#include "CPP_OPTIONS.h"
6
7	cnh	1.9	CBOP
8			C !ROUTINE: SWFRAC
9			C !INTERFACE:
10	adcroft	1.1	SUBROUTINE SWFRAC(
11	heimbach	1.6	I imax, fact,
12			I mytime, mythid,
13			U swdk )
14	cnh	1.9	C !DESCRIPTION: \bv
15			C ==========================================================
16			C \| SUBROUTINE SWFRAC
17			C \| o Compute solar short-wave flux penetration.
18			C ==========================================================
19			C \| Compute fraction of solar short-wave flux penetrating to
20			C \| specified depth, swdk, due to exponential decay in
21			C \| Jerlov water type jwtype.
22			C \| Reference : Two band solar absorption model of Paulson
23			C \| and Simpson (1977, JPO, 7, 952-956)
24			C \| Notes
25			C \| =====
26			C \| Parameter jwtype is hardcoded to 3 for time being.
27			C \| Below 200m the solar penetration gets set to zero,
28			C \| otherwise the limit for the exponent (+/- 5678) needs to
29			C \| be taken care of.
30			C \| Written by : Jan Morzel
31			C \| Date : July 12, 1995
32			C ==========================================================
33			C \ev
34	adcroft	1.1
35	cnh	1.9	C !USES:
36	adcroft	1.1	IMPLICIT NONE
37
38	cnh	1.9	C !INPUT/OUTPUT PARAMETERS:
39	adcroft	1.1	C === Routine arguments ===
40			C input arguments
41	cnh	1.9	C imax :: number of vertical grid points
42			C fact :: scale factor to apply to depth array
43			C myTime :: current time in simulation
44			C myThid :: thread number for this instance of the routine.
45	adcroft	1.5	INTEGER imax
46	heimbach	1.6	_RL fact
47			_RL mytime
48			integer mythid
49			C input/output arguments
50	cnh	1.9	C swdk :: on input: vertical depth for desired sw fraction
51			C (fact*swdk) is negative distance (m) from surface
52			C swdk :: on output: short wave (radiation) fractional decay
53	heimbach	1.6	_RL swdk(imax)
54	adcroft	1.5
55	cnh	1.9	C !LOCAL VARIABLES:
56	adcroft	1.5	C === Local variables ===
57			C max number of different water types
58	heimbach	1.6	integer nwtype , jwtype
59			PARAMETER(nwtype=5)
60			_RL facz
61	adcroft	1.5	_RL rfac(nwtype),a1(nwtype),a2(nwtype)
62	adcroft	1.1	INTEGER i
63	heimbach	1.11	#ifdef ALLOW_CAL
64	heimbach	1.6	_RL fac
65			logical first, changed
66			integer count0, count1
67			integer myiter
68			integer jerl(12)
69			data jerl / 2 , 2 , 2 , 3 , 3 , 3 , 4 , 4 , 4 , 4 , 3 , 2 /
70	heimbach	1.11	#endif /* ALLOW_CAL */
71	adcroft	1.1	C
72			C Jerlov water type : I IA IB II III
73			C jwtype 1 2 3 4 5
74			C
75			DATA rfac / 0.58 , 0.62 , 0.67 , 0.77 , 0.78 /
76			DATA a1 / 0.35 , 0.6 , 1.0 , 1.5 , 1.4 /
77			DATA a2 / 23.0 , 20.0 , 17.0 , 14.0 , 7.9 /
78	cnh	1.9	CEOP
79
80	heimbach	1.11	#ifdef ALLOW_CAL
81	edhill	1.10	ceh3 this should have an IF ( useCALENDAR ) THEN
82	heimbach	1.6	myiter=0
83			call cal_GetMonthsRec(
84			O fac, first, changed, count0, count1,
85			I mytime, myiter, mythid )
86			jwtype=jerl(count0)
87	heimbach	1.11	#else /* ALLOW_CAL undef */
88	heimbach	1.7	jwtype=2
89	heimbach	1.11	#endif /* ALLOW_CAL */
90	heimbach	1.6
91	adcroft	1.1	DO i = 1,imax
92	heimbach	1.6	facz = fact*swdk(i)
93	adcroft	1.1	IF (facz .LT. (-200.)) THEN
94			swdk(i) = 0.
95			ELSE
96			swdk(i) = rfac(jwtype) * exp(facz/a1(jwtype))
97			$ + (1.-rfac(jwtype)) * exp(facz/a2(jwtype))
98			ENDIF
99			ENDDO
100	adcroft	1.4
101	adcroft	1.1	RETURN
102			END