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 branches/dev_001_GM/NEMO/TOP_SRC/LOBSTER – NEMO

source: branches/dev_001_GM/NEMO/TOP_SRC/LOBSTER/trcopt.F90 @ 777

Last change on this file since 777 was 777, checked in by gm, 16 years ago

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