source: branches/NERC/dev_r5107_NOC_MEDUSA/NEMOGCM/NEMO/TOP_SRC/MEDUSA/trcopt_medusa.F90 @ 5707

Last change on this file since 5707 was 5707, checked in by acc, 5 years ago

JPALM —25-08-2015 — add MEDUSA in the branch. MEDUSA version already up-to-date with this trunk revision

File size: 7.7 KB
Line 
1MODULE trcopt_medusa
2   !!======================================================================
3   !!                         ***  MODULE trcopt_medusa  ***
4   !! TOP :   MEDUSA Compute the light availability in the water column
5   !!======================================================================
6   !! History :    -   !  1995-05  (M. Levy) Original code
7   !!              -   !  1999-09  (J.-M. Andre, M. Levy)
8   !!              -   !  1999-11  (C. Menkes, M.-A. Foujols) itabe initial
9   !!              -   !  2000-02  (M.A. Foujols) change x**y par exp(y*log(x))
10   !!             2.0  !  2007-12  (C. Deltel, G. Madec)  F90
11   !!              -   !  2008-08  (K. Popova) adaptation for MEDUSA
12   !!              -   !  2008-11  (A. Yool) continuing adaptation for MEDUSA
13   !!              -   !  2010-03  (A. Yool) updated for branch inclusion
14   !!----------------------------------------------------------------------
15#if defined key_medusa
16   !!----------------------------------------------------------------------
17   !!   'key_medusa'                                      MEDUSA bio-model
18   !!----------------------------------------------------------------------
19   !!   trc_opt_medusa        :   Compute the light availability in the water column
20   !!----------------------------------------------------------------------
21   USE oce_trc         !
22   USE trc
23   USE prtctl_trc      ! Print control for debbuging
24   USE sms_medusa
25
26   IMPLICIT NONE
27   PRIVATE
28
29   PUBLIC   trc_opt_medusa   ! called in trcprg.F90
30
31   !!* Substitution
32#  include "domzgr_substitute.h90"
33   !!----------------------------------------------------------------------
34   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
35   !! $Id: trcopt_medusa.F90 1146 2008-06-25 11:42:56Z rblod $
36   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
37   !!----------------------------------------------------------------------
38
39CONTAINS
40
41   SUBROUTINE trc_opt_medusa( kt )
42      !!---------------------------------------------------------------------
43      !!                     ***  ROUTINE trc_opt_medusa  ***
44      !!
45      !! ** Purpose :   computes the light propagation in the water column
46      !!              and the euphotic layer depth
47      !!
48      !! ** Method  :   local par is computed in w layers using light propagation
49      !!              mean par in t layers are computed by integration
50      !!---------------------------------------------------------------------
51      INTEGER, INTENT( in ) ::   kt   ! index of the time stepping
52      INTEGER  ::   ji, jj, jk
53      REAL(wp) ::   zpig                                    ! total pigment
54      REAL(wp) ::   zkr                                     ! total absorption coefficient in red
55      REAL(wp) ::   zkg                                     ! total absorption coefficient in green
56      REAL(wp) ::   totchl                                  ! total Chl concentreation
57      REAL(wp), DIMENSION(jpi,jpj)     ::   zpar100         ! irradiance at euphotic layer depth
58      REAL(wp), DIMENSION(jpi,jpj)     ::   zpar0m          ! irradiance just below the surface
59      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zparr, zparg    ! red and green compound of par
60
61      CHARACTER (len=25) :: charout
62      !!---------------------------------------------------------------------
63
64      !! AXY (20/11/14): alter this to report on first MEDUSA call
65      !! IF( kt == nit000 ) THEN
66      IF( kt == nittrc000 ) THEN
67         IF(lwp) WRITE(numout,*)
68         IF(lwp) WRITE(numout,*) ' trc_opt_medusa: MEDUSA optic-model'
69         IF(lwp) WRITE(numout,*) ' ~~~~~~~'
70    IF(lwp) WRITE(numout,*) ' kt =',kt
71      ENDIF
72
73      ! determination of surface irradiance
74      ! -----------------------------------
75      zpar0m (:,:)   = qsr   (:,:) * 0.43
76      ! AXY (22/08/14): when zpar0m = 0, zpar100 is also zero and calculating
77      !                 euphotic depth is not possible (cf. the Arctic Octopus);
78      !                 a "solution" to this is to set zpar0m to some minimal
79      !                 value such that zpar100 also has a non-zero value and
80      !                 euphotic depth can be calculated properly; note that,
81      !                 in older, non-diurnal versions of NEMO, this was much
82      !                 less of a problem; note also that, if pushed, I will
83      !                 claim that my minimal value of zpar0m refers to light
84      !                 from stars
85      DO jj = 1, jpj
86         DO ji = 1, jpi
87            IF( zpar0m(ji,jj) <= 0.0 ) zpar0m(ji,jj) = 0.001  ! = 1 mW/m2
88         ENDDO
89      ENDDO
90      zpar100(:,:)   = zpar0m(:,:) * 0.01
91      xpar   (:,:,1) = zpar0m(:,:)
92      zparr  (:,:,1) = 0.5 * zpar0m(:,:)
93      zparg  (:,:,1) = 0.5 * zpar0m(:,:)
94
95
96      ! determination of xpar
97      ! ---------------------
98
99      DO jk = 2, jpk                     ! determination of local par in w levels
100         DO jj = 1, jpj
101            DO ji = 1, jpi
102               totchl =trn(ji,jj,jk-1,jpchn)+trn(ji,jj,jk-1,jpchd)
103               zpig = MAX( TINY(0.), totchl/rpig) 
104               zkr  = xkr0 + xkrp * EXP( xlr * LOG( zpig ) )
105               zkg  = xkg0 + xkgp * EXP( xlg * LOG( zpig ) )
106               zparr(ji,jj,jk) = zparr(ji,jj,jk-1) * EXP( -zkr * fse3t(ji,jj,jk-1) )
107               zparg(ji,jj,jk) = zparg(ji,jj,jk-1) * EXP( -zkg * fse3t(ji,jj,jk-1) )
108            END DO
109        END DO
110      END DO
111
112      DO jk = 1, jpkm1                   ! mean par in t levels
113         DO jj = 1, jpj
114            DO ji = 1, jpi
115               totchl =trn(ji,jj,jk  ,jpchn)+trn(ji,jj,jk  ,jpchd)
116               zpig = MAX( TINY(0.), totchl/rpig) 
117               zkr  = xkr0 + xkrp * EXP( xlr * LOG( zpig ) )
118               zkg  = xkg0 + xkgp * EXP( xlg * LOG( zpig ) )
119               zparr(ji,jj,jk)    = zparr(ji,jj,jk) / zkr / fse3t(ji,jj,jk) * ( 1 - EXP( -zkr*fse3t(ji,jj,jk) ) )
120               zparg(ji,jj,jk)    = zparg(ji,jj,jk) / zkg / fse3t(ji,jj,jk) * ( 1 - EXP( -zkg*fse3t(ji,jj,jk) ) )
121               xpar (ji,jj,jk) = MAX( zparr(ji,jj,jk) + zparg(ji,jj,jk), 1.e-15 )
122            END DO
123         END DO
124      END DO
125
126      ! 3. Determination of euphotic layer depth
127      ! ----------------------------------------
128
129      ! Euphotic layer bottom level
130      neln(:,:) = 1                                           ! initialisation of EL level
131      DO jk = 1, jpkm1
132         DO jj = 1, jpj
133           DO ji = 1, jpi
134              IF( xpar(ji,jj,jk) >= zpar100(ji,jj) )   neln(ji,jj) = jk+1 ! 1rst T-level strictly below EL bottom
135              !                                                  ! nb. this is to ensure compatibility with
136              !                                                  ! nmld_trc definition in trd_mld_trc_zint
137           END DO
138         END DO
139      ENDDO
140
141      ! Euphotic layer depth
142      DO jj = 1, jpj
143         DO ji = 1, jpi
144            xze(ji,jj) = fsdepw( ji, jj, neln(ji,jj) )            ! exact EL depth
145         END DO
146      ENDDO 
147
148
149      IF(ln_ctl)   THEN  ! print mean trends (used for debugging)
150         WRITE(charout, FMT="('opt')")
151         CALL prt_ctl_trc_info(charout)
152         CALL prt_ctl_trc( tab4d=trn, mask=tmask, clinfo=ctrcnm )
153      ENDIF
154
155   END SUBROUTINE trc_opt_medusa
156
157#else
158   !!======================================================================
159   !!  Dummy module :                                   No MEDUSA bio-model
160   !!======================================================================
161CONTAINS
162   SUBROUTINE trc_opt_medusa( kt )                   ! Empty routine
163      INTEGER, INTENT( in ) ::   kt
164      WRITE(*,*) 'trc_opt_medusa: You should not have seen this print! error?', kt
165   END SUBROUTINE trc_opt_medusa
166#endif 
167
168   !!======================================================================
169END MODULE  trcopt_medusa
Note: See TracBrowser for help on using the repository browser.