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.
p2zopt.F90 in branches/2017/dev_r7881_no_wrk_alloc/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z – NEMO

source: branches/2017/dev_r7881_no_wrk_alloc/NEMOGCM/NEMO/TOP_SRC/PISCES/P2Z/p2zopt.F90 @ 7910

Last change on this file since 7910 was 7910, checked in by timgraham, 7 years ago

All wrk_alloc removed
  • Property svn:keywords set to Id
File size: 9.5 KB
Line 
1MODULE p2zopt
2   !!======================================================================
3   !!                         ***  MODULE p2zopt  ***
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   !!   NEMO      2.0  !  2007-12  (C. Deltel, G. Madec)  F90
11   !!             3.2  !  2009-04  (C. Ethe, G. Madec)  minor optimisation + style
12   !!----------------------------------------------------------------------
13   !!   p2z_opt        :   Compute the light availability in the water column
14   !!----------------------------------------------------------------------
15   USE oce_trc         !
16   USE trc
17   USE sms_pisces
18   USE prtctl_trc      ! Print control for debbuging
19
20   IMPLICIT NONE
21   PRIVATE
22
23   PUBLIC   p2z_opt   !
24   PUBLIC   p2z_opt_init   !
25
26   REAL(wp), PUBLIC ::  xkr0      !: water coefficient absorption in red     
27   REAL(wp), PUBLIC ::  xkg0      !: water coefficient absorption in green   
28   REAL(wp), PUBLIC ::  xkrp      !: pigment coefficient absorption in red   
29   REAL(wp), PUBLIC ::  xkgp      !: pigment coefficient absorption in green 
30   REAL(wp), PUBLIC ::  xlr       !: exposant for pigment absorption in red 
31   REAL(wp), PUBLIC ::  xlg       !: exposant for pigment absorption in green
32   REAL(wp), PUBLIC ::  rpig      !: chla/chla+phea ratio   
33   !                 
34   REAL(wp), PUBLIC ::  rcchl     ! Carbone/Chlorophyl ratio [mgC.mgChla-1]
35   REAL(wp), PUBLIC ::  redf      ! redfield ratio (C:N) for phyto
36   REAL(wp), PUBLIC ::  reddom    ! redfield ratio (C:N) for DOM
37
38   !!----------------------------------------------------------------------
39   !! NEMO/TOP 3.3 , NEMO Consortium (2010)
40   !! $Id$
41   !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
42   !!----------------------------------------------------------------------
43CONTAINS
44
45   SUBROUTINE p2z_opt( kt )
46      !!---------------------------------------------------------------------
47      !!                     ***  ROUTINE p2z_opt  ***
48      !!
49      !! ** Purpose :   computes the light propagation in the water column
50      !!              and the euphotic layer depth
51      !!
52      !! ** Method  :   local par is computed in w layers using light propagation
53      !!              mean par in t layers are computed by integration
54      !!
55!!gm please remplace the '???' by true comments
56      !! ** Action  :   etot   ???
57      !!                neln   ???
58      !!---------------------------------------------------------------------
59      !!
60      INTEGER, INTENT( in ) ::   kt   ! index of the time stepping
61      !!
62      INTEGER  ::   ji, jj, jk          ! dummy loop indices
63      CHARACTER (len=25) ::   charout   ! temporary character
64      REAL(wp) ::   zpig                ! log of the total pigment
65      REAL(wp) ::   zkr, zkg            ! total absorption coefficient in red and green
66      REAL(wp) ::   zcoef               ! temporary scalar
67      REAL(wp), DIMENSION(jpi,jpj) :: zpar100, zpar0m
68      REAL(wp), DIMENSION(jpi,jpj,jpk) :: zparr, zparg
69      !!---------------------------------------------------------------------
70      !
71      IF( nn_timing == 1 )  CALL timing_start('p2z_opt')
72      !
73      ! Allocate temporary workspace
74
75      IF( kt == nittrc000 ) THEN
76         IF(lwp) WRITE(numout,*)
77         IF(lwp) WRITE(numout,*) ' p2z_opt : LOBSTER optic-model'
78         IF(lwp) WRITE(numout,*) ' ~~~~~~~ '
79      ENDIF
80
81      !                                          ! surface irradiance
82      !                                          ! ------------------
83      IF( ln_dm2dc ) THEN   ;   zpar0m(:,:) = qsr_mean(:,:) * 0.43
84      ELSE                  ;   zpar0m(:,:) = qsr     (:,:) * 0.43
85      ENDIF
86      zpar100(:,:)   = zpar0m(:,:) * 0.01
87      zparr  (:,:,1) = zpar0m(:,:) * 0.5
88      zparg  (:,:,1) = zpar0m(:,:) * 0.5
89
90      !                                          ! Photosynthetically Available Radiation (PAR)
91      zcoef = 12 * redf / rcchl / rpig           ! --------------------------------------
92      DO jk = 2, jpk                                  ! local par at w-levels
93         DO jj = 1, jpj
94            DO ji = 1, jpi
95               zpig = LOG(  MAX( TINY(0.), trn(ji,jj,jk-1,jpphy) ) * zcoef  )
96               zkr  = xkr0 + xkrp * EXP( xlr * zpig )
97               zkg  = xkg0 + xkgp * EXP( xlg * zpig )
98               zparr(ji,jj,jk) = zparr(ji,jj,jk-1) * EXP( -zkr * e3t_n(ji,jj,jk-1) )
99               zparg(ji,jj,jk) = zparg(ji,jj,jk-1) * EXP( -zkg * e3t_n(ji,jj,jk-1) )
100            END DO
101        END DO
102      END DO
103      DO jk = 1, jpkm1                                ! mean par at t-levels
104         DO jj = 1, jpj
105            DO ji = 1, jpi
106               zpig = LOG(  MAX( TINY(0.), trn(ji,jj,jk,jpphy) ) * zcoef  )
107               zkr  = xkr0 + xkrp * EXP( xlr * zpig )
108               zkg  = xkg0 + xkgp * EXP( xlg * zpig )
109               zparr(ji,jj,jk) = zparr(ji,jj,jk) / ( zkr * e3t_n(ji,jj,jk) ) * ( 1 - EXP( -zkr * e3t_n(ji,jj,jk) ) )
110               zparg(ji,jj,jk) = zparg(ji,jj,jk) / ( zkg * e3t_n(ji,jj,jk) ) * ( 1 - EXP( -zkg * e3t_n(ji,jj,jk) ) )
111               etot (ji,jj,jk) = MAX( zparr(ji,jj,jk) + zparg(ji,jj,jk), 1.e-15 )
112            END DO
113         END DO
114      END DO
115
116      !                                          ! Euphotic layer
117      !                                          ! --------------
118      neln(:,:) = 1                                   ! euphotic layer level
119      DO jk = 1, jpk                                  ! (i.e. 1rst T-level strictly below EL bottom)
120         DO jj = 1, jpj
121           DO ji = 1, jpi
122              IF( etot(ji,jj,jk) >= zpar100(ji,jj) )   neln(ji,jj) = jk + 1 
123           END DO
124         END DO
125      END DO
126      !                                               ! Euphotic layer depth
127      DO jj = 1, jpj
128         DO ji = 1, jpi
129            heup(ji,jj) = gdepw_n(ji,jj,neln(ji,jj))
130         END DO
131      END DO
132
133
134      IF(ln_ctl) THEN      ! print mean trends (used for debugging)
135         WRITE(charout, FMT="('opt')")
136         CALL prt_ctl_trc_info( charout )
137         CALL prt_ctl_trc( tab4d=trn, mask=tmask, clinfo=ctrcnm )
138      ENDIF
139      !
140      !
141      IF( nn_timing == 1 )  CALL timing_stop('p2z_opt')
142      !
143   END SUBROUTINE p2z_opt
144
145   SUBROUTINE p2z_opt_init
146      !!----------------------------------------------------------------------
147      !!                  ***  ROUTINE p2z_opt_init  ***
148      !!
149      !! ** Purpose :  optical parameters
150      !!
151      !! ** Method  :   Read the namlobopt namelist and check the parameters
152      !!
153      !!----------------------------------------------------------------------
154      NAMELIST/namlobopt/ xkg0, xkr0, xkgp, xkrp, xlg, xlr, rpig
155      NAMELIST/namlobrat/ rcchl, redf, reddom
156      INTEGER :: ios                 ! Local integer output status for namelist read
157      !!----------------------------------------------------------------------
158
159      REWIND( numnatp_ref )              ! Namelist namlobopt in reference namelist : Lobster options
160      READ  ( numnatp_ref, namlobopt, IOSTAT = ios, ERR = 901)
161901   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlobopt in reference namelist', lwp )
162
163      REWIND( numnatp_cfg )              ! Namelist namlobopt in configuration namelist : Lobster options
164      READ  ( numnatp_cfg, namlobopt, IOSTAT = ios, ERR = 902 )
165902   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlobopt in configuration namelist', lwp )
166      IF(lwm) WRITE ( numonp, namlobopt )
167
168      IF(lwp) THEN
169         WRITE(numout,*)
170         WRITE(numout,*) ' Namelist namlobopt'
171         WRITE(numout,*) '    green   water absorption coeff                       xkg0  = ', xkg0
172         WRITE(numout,*) '    red water absorption coeff                           xkr0  = ', xkr0
173         WRITE(numout,*) '    pigment red absorption coeff                         xkrp  = ', xkrp
174         WRITE(numout,*) '    pigment green absorption coeff                       xkgp  = ', xkgp
175         WRITE(numout,*) '    green chl exposant                                   xlg   = ', xlg
176         WRITE(numout,*) '    red   chl exposant                                   xlr   = ', xlr
177         WRITE(numout,*) '    chla/chla+phea ratio                                 rpig  = ', rpig
178         WRITE(numout,*) ' '
179      ENDIF
180      !
181      REWIND( numnatp_ref )              ! Namelist namlobrat in reference namelist : Lobster ratios
182      READ  ( numnatp_ref, namlobrat, IOSTAT = ios, ERR = 903)
183903   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlobrat in reference namelist', lwp )
184
185      REWIND( numnatp_cfg )              ! Namelist namlobrat in configuration namelist : Lobster ratios
186      READ  ( numnatp_cfg, namlobrat, IOSTAT = ios, ERR = 904 )
187904   IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlobrat in configuration namelist', lwp )
188      IF(lwm) WRITE ( numonp, namlobrat )
189
190      IF(lwp) THEN
191          WRITE(numout,*) ' Namelist namlobrat'
192         WRITE(numout,*) '     carbone/chlorophyl ratio                             rcchl = ', rcchl
193          WRITE(numout,*) '    redfield ratio  c:n for phyto                        redf      =', redf
194          WRITE(numout,*) '    redfield ratio  c:n for DOM                          reddom    =', reddom
195          WRITE(numout,*) ' '
196      ENDIF
197      !
198   END SUBROUTINE p2z_opt_init
199
200   !!======================================================================
201END MODULE  p2zopt
Note: See TracBrowser for help on using the repository browser.