New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
trcopt.F90 in trunk/NEMO/TOP_SRC/LOBSTER – NEMO

source: trunk/NEMO/TOP_SRC/LOBSTER/trcopt.F90 @ 1119

Last change on this file since 1119 was 1119, checked in by cetlod, 16 years ago

style of all top namelist has been modified ; update modules to take it into account, see ticket:196
File size: 6.6 KB
Line 
1MODULE trcopt
2   !!======================================================================
3   !!                         ***  MODULE trcopt  ***
4   !! TOP :   LOBSTER 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   !!----------------------------------------------------------------------
12#if defined key_lobster
13   !!----------------------------------------------------------------------
14   !!   'key_lobster'                                     LOBSTER bio-model
15   !!----------------------------------------------------------------------
16   !!   trc_opt        :   Compute the light availability in the water column
17   !!----------------------------------------------------------------------
18   USE oce_trc         !
19   USE trc
20   USE sms_lobster
21   USE prtctl_trc      ! Print control for debbuging
22
23   IMPLICIT NONE
24   PRIVATE
25
26   PUBLIC   trc_opt   ! called in trcprg.F90
27
28   !!* Substitution
29#  include "domzgr_substitute.h90"
30   !!----------------------------------------------------------------------
31   !! NEMO/TOP 2.0 , LOCEAN-IPSL (2007)
32   !! $Id: trcopt.F90 777 2007-12-19 18:40:57Z gm $
33   !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
34   !!----------------------------------------------------------------------
35
36CONTAINS
37
38   SUBROUTINE trc_opt( kt )
39      !!---------------------------------------------------------------------
40      !!                     ***  ROUTINE trc_opt  ***
41      !!
42      !! ** Purpose :   computes the light propagation in the water column
43      !!              and the euphotic layer depth
44      !!
45      !! ** Method  :   local par is computed in w layers using light propagation
46      !!              mean par in t layers are computed by integration
47      !!---------------------------------------------------------------------
48      INTEGER, INTENT( in ) ::   kt   ! index of the time stepping
49      INTEGER  ::   ji, jj, jk
50      INTEGER , DIMENSION(jpi,jpj)     ::   itabe           ! euphotic layer last k index
51      INTEGER , DIMENSION(jpi,jpj,jpk) ::   imaske          ! euphotic layer mask
52      REAL(wp) ::   zpig                                    ! total pigment
53      REAL(wp) ::   zkr                                     ! total absorption coefficient in red
54      REAL(wp) ::   zkg                                     ! total absorption coefficient in green
55      REAL(wp), DIMENSION(jpi,jpj)     ::   zpar100         ! irradiance at euphotic layer depth
56      REAL(wp), DIMENSION(jpi,jpj)     ::   zpar0m          ! irradiance just below the surface
57      REAL(wp), DIMENSION(jpi,jpj,jpk) ::   zparr, zparg    ! red and green compound of par
58
59      CHARACTER (len=25) :: charout
60      !!---------------------------------------------------------------------
61
62      IF( kt == nit000 ) THEN
63         IF(lwp) WRITE(numout,*)
64         IF(lwp) WRITE(numout,*) ' trc_opt: LOBSTER optic-model'
65         IF(lwp) WRITE(numout,*) ' ~~~~~~~'
66      ENDIF
67
68      ! determination of surface irradiance
69      ! -----------------------------------
70      zpar0m (:,:)   = qsr   (:,:) * 0.43
71      zpar100(:,:)   = zpar0m(:,:) * 0.01
72      xpar   (:,:,1) = zpar0m(:,:)
73      zparr  (:,:,1) = 0.5 * zpar0m(:,:)
74      zparg  (:,:,1) = 0.5 * zpar0m(:,:)
75
76
77      ! determination of xpar
78      ! ---------------------
79
80      DO jk = 2, jpk                     ! determination of local par in w levels
81         DO jj = 1, jpj
82            DO ji = 1, jpi
83               zpig = MAX( TINY(0.), trn(ji,jj,jk-1,jpphy) ) * 12 * redf / rcchl / rpig
84               zkr  = xkr0 + xkrp * EXP( xlr * LOG( zpig ) )
85               zkg  = xkg0 + xkgp * EXP( xlg * LOG( zpig ) )
86               zparr(ji,jj,jk) = zparr(ji,jj,jk-1) * EXP( -zkr * fse3t(ji,jj,jk-1) )
87               zparg(ji,jj,jk) = zparg(ji,jj,jk-1) * EXP( -zkg * fse3t(ji,jj,jk-1) )
88            END DO
89        END DO
90      END DO
91
92      DO jk = 1, jpkm1                   ! mean par in t levels
93         DO jj = 1, jpj
94            DO ji = 1, jpi
95               zpig = MAX( TINY(0.), trn(ji,jj,jk,jpphy) ) * 12 * redf / rcchl / rpig
96               zkr  = xkr0 + xkrp * EXP( xlr * LOG( zpig ) )
97               zkg  = xkg0 + xkgp * EXP( xlg * LOG( zpig ) )
98               zparr(ji,jj,jk)    = zparr(ji,jj,jk) / zkr / fse3t(ji,jj,jk) * ( 1 - EXP( -zkr*fse3t(ji,jj,jk) ) )
99               zparg(ji,jj,jk)    = zparg(ji,jj,jk) / zkg / fse3t(ji,jj,jk) * ( 1 - EXP( -zkg*fse3t(ji,jj,jk) ) )
100               xpar (ji,jj,jk) = MAX( zparr(ji,jj,jk) + zparg(ji,jj,jk), 1.e-15 )
101            END DO
102         END DO
103      END DO
104
105      ! determination of euphotic layer depth (xze)
106      ! -------------------------------------
107
108      DO jk = 1, jpk                   ! imaske equal 1 in the euphotic layer, and 0 without
109         DO jj = 1, jpj
110            DO ji = 1,jpi
111               IF( xpar(ji,jj,jk) >= zpar100(ji,jj) ) THEN
112                  imaske(ji,jj,jk) = 1
113               ELSE
114                  imaske(ji,jj,jk) = 0
115               ENDIF
116            END DO
117         END DO
118      END DO
119      !                                ! sum of imaske Cover the vertical with a minimim value of 1
120      itabe(:,:) = 1                   !   surface value setto 1 <=> set a ninimum value to 1
121      DO jk = 2, jpk
122         DO jj = 1, jpj
123            DO ji = 1,jpi
124               itabe(ji,jj) = itabe(ji,jj) + imaske(ji,jj,jk)
125            END DO
126         END DO
127      END DO
128      DO jj = 1, jpj                  ! converte the number of level into depth
129         DO ji = 1,jpi
130            xze(ji,jj) = fsdepw(ji,jj,itabe(ji,jj)+1)
131         END DO
132      END DO
133      !
134
135      IF(ln_ctl)   THEN  ! print mean trends (used for debugging)
136         WRITE(charout, FMT="('opt')")
137         CALL prt_ctl_trc_info(charout)
138         CALL prt_ctl_trc( tab4d=trn, mask=tmask, clinfo=ctrcnm )
139      ENDIF
140
141   END SUBROUTINE trc_opt
142
143#else
144   !!======================================================================
145   !!  Dummy module :                                   No PISCES bio-model
146   !!======================================================================
147CONTAINS
148   SUBROUTINE trc_opt( kt )                   ! Empty routine
149      INTEGER, INTENT( in ) ::   kt
150      WRITE(*,*) 'trc_opt: You should not have seen this print! error?', kt
151   END SUBROUTINE trc_opt
152#endif 
153
154   !!======================================================================
155END MODULE  trcopt
Note: See TracBrowser for help on using the repository browser.