Context Navigation

traqsr.F90 @ 15540

Last change on this file since 15540 was 15540, checked in by sparonuz, 3 years ago
Mixed precision version, tested up to 30 years on ORCA2.
Property svn:keywords set to `Id`
File size: 23.7 KB

Line
1	MODULE traqsr
2	!!======================================================================
3	!! * MODULE traqsr *
4	!! Ocean physics: solar radiation penetration in the top ocean levels
5	!!======================================================================
6	!! History : OPA ! 1990-10 (B. Blanke) Original code
7	!! 7.0 ! 1991-11 (G. Madec)
8	!! ! 1996-01 (G. Madec) s-coordinates
9	!! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module
10	!! - ! 2005-11 (G. Madec) zco, zps, sco coordinate
11	!! 3.2 ! 2009-04 (G. Madec & NEMO team)
12	!! 3.6 ! 2012-05 (C. Rousset) store attenuation coef for use in ice model
13	!! 3.6 ! 2015-12 (O. Aumont, J. Jouanno, C. Ethe) use vertical profile of chlorophyll
14	!! 3.7 ! 2015-11 (G. Madec, A. Coward) remove optimisation for fix volume
15	!!----------------------------------------------------------------------
16
17	!!----------------------------------------------------------------------
18	!! tra_qsr : temperature trend due to the penetration of solar radiation
19	!! tra_qsr_init : initialization of the qsr penetration
20	!!----------------------------------------------------------------------
21	USE oce ! ocean dynamics and active tracers
22	USE phycst ! physical constants
23	USE dom_oce ! ocean space and time domain
24	USE domtile
25	USE sbc_oce ! surface boundary condition: ocean
26	USE trc_oce ! share SMS/Ocean variables
27	USE trd_oce ! trends: ocean variables
28	USE trdtra ! trends manager: tracers
29	!
30	USE in_out_manager ! I/O manager
31	USE prtctl ! Print control
32	USE iom ! I/O library
33	USE fldread ! read input fields
34	USE restart ! ocean restart
35	USE lib_mpp ! MPP library
36	USE lbclnk ! ocean lateral boundary conditions (or mpp link)
37	USE timing ! Timing
38
39	IMPLICIT NONE
40	PRIVATE
41
42	PUBLIC tra_qsr ! routine called by step.F90 (ln_traqsr=T)
43	PUBLIC tra_qsr_init ! routine called by nemogcm.F90
44
45	! !!* Namelist namtra_qsr: penetrative solar radiation
46	LOGICAL , PUBLIC :: ln_traqsr !: light absorption (qsr) flag
47	LOGICAL , PUBLIC :: ln_qsr_rgb !: Red-Green-Blue light absorption flag
48	LOGICAL , PUBLIC :: ln_qsr_2bd !: 2 band light absorption flag
49	LOGICAL , PUBLIC :: ln_qsr_bio !: bio-model light absorption flag
50	INTEGER , PUBLIC :: nn_chldta !: use Chlorophyll data (=1) or not (=0)
51	REAL(wp), PUBLIC :: rn_abs !: fraction absorbed in the very near surface (RGB & 2 bands)
52	REAL(wp), PUBLIC :: rn_si0 !: very near surface depth of extinction (RGB & 2 bands)
53	REAL(wp), PUBLIC :: rn_si1 !: deepest depth of extinction (water type I) (2 bands)
54	!
55	INTEGER , PUBLIC :: nksr !: levels below which the light cannot penetrate (depth larger than 391 m)
56
57	INTEGER, PARAMETER :: np_RGB = 1 ! R-G-B light penetration with constant Chlorophyll
58	INTEGER, PARAMETER :: np_RGBc = 2 ! R-G-B light penetration with Chlorophyll data
59	INTEGER, PARAMETER :: np_2BD = 3 ! 2 bands light penetration
60	INTEGER, PARAMETER :: np_BIO = 4 ! bio-model light penetration
61	!
62	INTEGER :: nqsr ! user choice of the type of light penetration
63	REAL(dp) :: xsi0r ! inverse of rn_si0
64	REAL(dp) :: xsi1r ! inverse of rn_si1
65	!
66	REAL(dp) , PUBLIC, DIMENSION(3,61) :: rkrgb ! tabulated attenuation coefficients for RGB absorption
67	TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_chl ! structure of input Chl (file informations, fields read)
68
69	!! * Substitutions
70	# include "do_loop_substitute.h90"
71	# include "domzgr_substitute.h90"
72	# include "single_precision_substitute.h90"
73	!!----------------------------------------------------------------------
74	!! NEMO/OCE 4.0 , NEMO Consortium (2018)
75	!! $Id$
76	!! Software governed by the CeCILL license (see ./LICENSE)
77	!!----------------------------------------------------------------------
78	CONTAINS
79
80	SUBROUTINE tra_qsr( kt, Kmm, pts, Krhs )
81	!!----------------------------------------------------------------------
82	!! * ROUTINE tra_qsr *
83	!!
84	!! ** Purpose : Compute the temperature trend due to the solar radiation
85	!! penetration and add it to the general temperature trend.
86	!!
87	!! ** Method : The profile of the solar radiation within the ocean is defined
88	!! through 2 wavebands (rn_si0,rn_si1) or 3 wavebands (RGB) and a ratio rn_abs
89	!! Considering the 2 wavebands case:
90	!! I(k) = Qsr( rn_absEXP(z(k)/rn_si0) + (1.-rn_abs)*EXP(z(k)/rn_si1) )
91	!! The temperature trend associated with the solar radiation penetration
92	!! is given by : zta = 1/e3t dk[ I ] / (rho0*Cp)
93	!! At the bottom, boudary condition for the radiation is no flux :
94	!! all heat which has not been absorbed in the above levels is put
95	!! in the last ocean level.
96	!! The computation is only done down to the level where
97	!! I(k) < 1.e-15 W/m2 (i.e. over the top nksr levels) .
98	!!
99	!! ** Action : - update ta with the penetrative solar radiation trend
100	!! - send trend for further diagnostics (l_trdtra=T)
101	!!
102	!! Reference : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp.
103	!! Lengaigne et al. 2007, Clim. Dyn., V28, 5, 503-516.
104	!! Morel, A. et Berthon, JF, 1989, Limnol Oceanogr 34(8), 1545-1562
105	!!----------------------------------------------------------------------
106	INTEGER, INTENT(in ) :: kt ! ocean time-step
107	INTEGER, INTENT(in ) :: Kmm, Krhs ! time level indices
108	REAL(dp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation
109	!
110	INTEGER :: ji, jj, jk ! dummy loop indices
111	INTEGER :: irgb ! local integers
112	REAL(wp) :: zchl, zcoef, z1_2 ! local scalars
113	REAL(wp) :: zc0 , zc1 , zc2 , zc3 ! - -
114	REAL(dp) :: zzc0, zzc1, zzc2, zzc3 ! - -
115	REAL(wp) :: zz0 , zz1 , ze3t, zlui ! - -
116	REAL(wp) :: zCb, zCmax, zpsi, zpsimax, zrdpsi, zCze
117	REAL(wp) :: zlogc
118	REAL(dp) :: zlogze, zlogCtot, zlogCze
119	REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ze0, ze1, ze2, ze3
120	REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztmp3d
121	REAL(dp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdt, zetot
122	!!----------------------------------------------------------------------
123	!
124	IF( ln_timing ) CALL timing_start('tra_qsr')
125	!
126	IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
127	IF( kt == nit000 ) THEN
128	IF(lwp) WRITE(numout,*)
129	IF(lwp) WRITE(numout,*) 'tra_qsr : penetration of the surface solar radiation'
130	IF(lwp) WRITE(numout,*) '~~~~~~~'
131	ENDIF
132	ENDIF
133	!
134	IF( l_trdtra ) THEN ! trends diagnostic: save the input temperature trend
135	ALLOCATE( ztrdt(jpi,jpj,jpk) )
136	ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs)
137	ENDIF
138	!
139	! !-----------------------------------!
140	! ! before qsr induced heat content !
141	! !-----------------------------------!
142	IF( kt == nit000 ) THEN !== 1st time step ==!
143	IF( ln_rstart .AND. .NOT.l_1st_euler ) THEN ! read in restart
144	z1_2 = 0.5_wp
145	IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
146	IF(lwp) WRITE(numout,*) ' nit000-1 qsr tracer content forcing field read in the restart file'
147	CALL iom_get( numror, jpdom_auto, 'qsr_hc_b', qsr_hc_b ) ! before heat content trend due to Qsr flux
148	ENDIF
149	ELSE ! No restart or Euler forward at 1st time step
150	z1_2 = 1._wp
151	DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
152	qsr_hc_b(ji,jj,jk) = 0._wp
153	END_3D
154	ENDIF
155	ELSE !== Swap of qsr heat content ==!
156	z1_2 = 0.5_wp
157	DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 1, jpk )
158	qsr_hc_b(ji,jj,jk) = qsr_hc(ji,jj,jk)
159	END_3D
160	ENDIF
161	!
162	! !--------------------------------!
163	SELECT CASE( nqsr ) ! now qsr induced heat content !
164	! !--------------------------------!
165	!
166	CASE( np_BIO ) !== bio-model fluxes ==!
167	!
168	DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksr )
169	qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( etot3(ji,jj,jk) - etot3(ji,jj,jk+1) )
170	END_3D
171	!
172	CASE( np_RGB , np_RGBc ) !== R-G-B fluxes ==!
173	!
174	ALLOCATE( ze0 (A2D(nn_hls)) , ze1 (A2D(nn_hls)) , &
175	& ze2 (A2D(nn_hls)) , ze3 (A2D(nn_hls)) , &
176	& ztmp3d(A2D(nn_hls),nksr + 1) )
177	!
178	IF( nqsr == np_RGBc ) THEN !* Variable Chlorophyll
179	IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only for the full domain
180	IF( ln_tile ) CALL dom_tile_stop( ldhold=.TRUE. ) ! Use full domain
181	CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step
182	IF( ln_tile ) CALL dom_tile_start( ldhold=.TRUE. ) ! Revert to tile domain
183	ENDIF
184	!
185	! Separation in R-G-B depending on the surface Chl
186	! perform and store as many of the 2D calculations as possible
187	! before the 3D loop (use the temporary 2D arrays to replace the
188	! most expensive calculations)
189	!
190	DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls )
191	! zlogc = log(zchl)
192	zlogc = LOG ( MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) )
193	! zc1 : log(zCze) = log (1.12 * zchl**0.803)
194	zc1 = 0.113328685307 + 0.803 * zlogc
195	! zc2 : log(zCtot) = log(40.6 * zchl**0.459)
196	zc2 = 3.703768066608 + 0.459 * zlogc
197	! zc3 : log(zze) = log(568.2 * zCtot**(-0.746))
198	zc3 = 6.34247346942 - 0.746 * zc2
199	! IF( log(zze) > log(102.) ) log(zze) = log(200.0 * zCtot**(-0.293))
200	IF( zc3 > 4.62497281328 ) zc3 = 5.298317366548 - 0.293 * zc2
201	!
202	ze0(ji,jj) = zlogc ! ze0 = log(zchl)
203	ze1(ji,jj) = EXP( zc1 ) ! ze1 = zCze
204	ze2(ji,jj) = 1._wp / ( 0.710 + zlogc * ( 0.159 + zlogc * 0.021 ) ) ! ze2 = 1/zdelpsi
205	ze3(ji,jj) = EXP( - zc3 ) ! ze3 = 1/zze
206	END_2D
207
208	!
209	DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksr + 1 )
210	! zchl = ALOG( ze0(ji,jj) )
211	zlogc = ze0(ji,jj)
212	!
213	zCb = 0.768 + zlogc * ( 0.087 - zlogc * ( 0.179 + zlogc * 0.025 ) )
214	zCmax = 0.299 - zlogc * ( 0.289 - zlogc * 0.579 )
215	zpsimax = 0.6 - zlogc * ( 0.640 - zlogc * ( 0.021 + zlogc * 0.115 ) )
216	! zdelpsi = 0.710 + zlogc * ( 0.159 + zlogc * 0.021 )
217	!
218	zCze = ze1(ji,jj)
219	zrdpsi = ze2(ji,jj) ! 1/zdelpsi
220	zpsi = ze3(ji,jj) * gdepw(ji,jj,jk,Kmm) ! gdepw/zze
221	!
222	! NB. make sure zchl value is such that: zchl = MIN( 10. , MAX( 0.03, zchl ) )
223	zchl = MIN( 10. , MAX( 0.03, zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) * zrdpsi )**2 ) ) ) )
224	! Convert chlorophyll value to attenuation coefficient look-up table index
225	ztmp3d(ji,jj,jk) = 41 + 20.*LOG10(zchl) + 1.e-15
226	END_3D
227	ELSE !* constant chlorophyll
228	zchl = 0.05
229	! NB. make sure constant value is such that:
230	zchl = MIN( 10. , MAX( 0.03, zchl ) )
231	! Convert chlorophyll value to attenuation coefficient look-up table index
232	zlui = 41 + 20.*LOG10(zchl) + 1.e-15
233	DO jk = 1, nksr + 1
234	ztmp3d(:,:,jk) = zlui
235	END DO
236	ENDIF
237	!
238	zcoef = ( 1. - rn_abs ) / 3._wp !* surface equi-partition in R-G-B
239	DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls )
240	ze0(ji,jj) = rn_abs * qsr(ji,jj)
241	ze1(ji,jj) = zcoef * qsr(ji,jj)
242	ze2(ji,jj) = zcoef * qsr(ji,jj)
243	ze3(ji,jj) = zcoef * qsr(ji,jj)
244	! store the surface SW radiation; re-use the surface ztmp3d array
245	! since the surface attenuation coefficient is not used
246	ztmp3d(ji,jj,1) = qsr(ji,jj)
247	END_2D
248	!
249	! !* interior equi-partition in R-G-B depending on vertical profile of Chl
250	DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 2, nksr + 1 )
251	ze3t = e3t(ji,jj,jk-1,Kmm)
252	irgb = NINT( ztmp3d(ji,jj,jk) )
253	zc0 = ze0(ji,jj) * EXP( - ze3t * xsi0r )
254	zc1 = ze1(ji,jj) * EXP( - ze3t * rkrgb(1,irgb) )
255	zc2 = ze2(ji,jj) * EXP( - ze3t * rkrgb(2,irgb) )
256	zc3 = ze3(ji,jj) * EXP( - ze3t * rkrgb(3,irgb) )
257	ze0(ji,jj) = zc0
258	ze1(ji,jj) = zc1
259	ze2(ji,jj) = zc2
260	ze3(ji,jj) = zc3
261	ztmp3d(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * wmask(ji,jj,jk)
262	END_3D
263	!
264	DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksr ) !* now qsr induced heat content
265	qsr_hc(ji,jj,jk) = r1_rho0_rcp * ( ztmp3d(ji,jj,jk) - ztmp3d(ji,jj,jk+1) )
266	END_3D
267	!
268	DEALLOCATE( ze0 , ze1 , ze2 , ze3 , ztmp3d )
269	!
270	CASE( np_2BD ) !== 2-bands fluxes ==!
271	!
272	zz0 = rn_abs * r1_rho0_rcp ! surface equi-partition in 2-bands
273	zz1 = ( 1. - rn_abs ) * r1_rho0_rcp
274	DO_3D_OVR( nn_hls, nn_hls, nn_hls, nn_hls, 1, nksr ) !* now qsr induced heat content
275	zc0 = zz0 * EXP( -gdepw(ji,jj,jk ,Kmm)xsi0r ) + zz1 EXP( -gdepw(ji,jj,jk ,Kmm)*xsi1r )
276	zc1 = zz0 * EXP( -gdepw(ji,jj,jk+1,Kmm)xsi0r ) + zz1 EXP( -gdepw(ji,jj,jk+1,Kmm)*xsi1r )
277	qsr_hc(ji,jj,jk) = qsr(ji,jj) * ( zc0 * wmask(ji,jj,jk) - zc1 * wmask(ji,jj,jk+1) )
278	END_3D
279	!
280	END SELECT
281	!
282	! !-----------------------------!
283	! ! update to the temp. trend !
284	! !-----------------------------!
285	DO_3D( 0, 0, 0, 0, 1, nksr )
286	pts(ji,jj,jk,jp_tem,Krhs) = pts(ji,jj,jk,jp_tem,Krhs) &
287	& + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) &
288	& / e3t(ji,jj,jk,Kmm)
289	END_3D
290	!
291	! sea-ice: store the 1st ocean level attenuation coefficient
292	DO_2D_OVR( nn_hls, nn_hls, nn_hls, nn_hls )
293	IF( qsr(ji,jj) /= 0._wp ) THEN ; fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rho0_rcp * qsr(ji,jj) )
294	ELSE ; fraqsr_1lev(ji,jj) = 1._wp
295	ENDIF
296	END_2D
297	!
298	IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution
299	ALLOCATE( zetot(A2D(nn_hls),jpk) )
300	zetot(:,:,nksr+1:jpk) = 0._wp ! below ~400m set to zero
301	DO_3DS(0, 0, 0, 0, nksr, 1, -1)
302	zetot(ji,jj,jk) = zetot(ji,jj,jk+1) + qsr_hc(ji,jj,jk) * rho0_rcp
303	END_3D
304	CALL iom_put( 'qsr3d', zetot ) ! 3D distribution of shortwave Radiation
305	DEALLOCATE( zetot )
306	ENDIF
307	!
308	IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile
309	IF( lrst_oce ) THEN ! write in the ocean restart file
310	CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b' , qsr_hc )
311	CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev )
312	ENDIF
313	ENDIF
314	!
315	IF( l_trdtra ) THEN ! qsr tracers trends saved for diagnostics
316	ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs) - ztrdt(:,:,:)
317	CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_qsr, ztrdt )
318	DEALLOCATE( ztrdt )
319	ENDIF
320	! ! print mean trends (used for debugging)
321	IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' qsr - Ta: ', mask1=tmask, clinfo3='tra-ta' )
322	!
323	IF( ln_timing ) CALL timing_stop('tra_qsr')
324	!
325	END SUBROUTINE tra_qsr
326
327
328	SUBROUTINE tra_qsr_init
329	!!----------------------------------------------------------------------
330	!! * ROUTINE tra_qsr_init *
331	!!
332	!! ** Purpose : Initialization for the penetrative solar radiation
333	!!
334	!! ** Method : The profile of solar radiation within the ocean is set
335	!! from two length scale of penetration (rn_si0,rn_si1) and a ratio
336	!! (rn_abs). These parameters are read in the namtra_qsr namelist. The
337	!! default values correspond to clear water (type I in Jerlov'
338	!! (1968) classification.
339	!! called by tra_qsr at the first timestep (nit000)
340	!!
341	!! ** Action : - initialize rn_si0, rn_si1 and rn_abs
342	!!
343	!! Reference : Jerlov, N. G., 1968 Optical Oceanography, Elsevier, 194pp.
344	!!----------------------------------------------------------------------
345	INTEGER :: ji, jj, jk ! dummy loop indices
346	INTEGER :: ios, irgb, ierror, ioptio ! local integer
347	REAL(dp) :: zz0, zc0 , zc1, zcoef ! local scalars
348	REAL(dp) :: zz1, zc2 , zc3, zchl ! - -
349	!
350	CHARACTER(len=100) :: cn_dir ! Root directory for location of ssr files
351	TYPE(FLD_N) :: sn_chl ! informations about the chlorofyl field to be read
352	!!
353	NAMELIST/namtra_qsr/ sn_chl, cn_dir, ln_qsr_rgb, ln_qsr_2bd, ln_qsr_bio, &
354	& nn_chldta, rn_abs, rn_si0, rn_si1
355	!!----------------------------------------------------------------------
356	!
357	READ ( numnam_ref, namtra_qsr, IOSTAT = ios, ERR = 901)
358	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_qsr in reference namelist' )
359	!
360	READ ( numnam_cfg, namtra_qsr, IOSTAT = ios, ERR = 902 )
361	902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_qsr in configuration namelist' )
362	IF(lwm) WRITE ( numond, namtra_qsr )
363	!
364	IF(lwp) THEN ! control print
365	WRITE(numout,*)
366	WRITE(numout,*) 'tra_qsr_init : penetration of the surface solar radiation'
367	WRITE(numout,*) '~~~~~~~~~~~~'
368	WRITE(numout,*) ' Namelist namtra_qsr : set the parameter of penetration'
369	WRITE(numout,*) ' RGB (Red-Green-Blue) light penetration ln_qsr_rgb = ', ln_qsr_rgb
370	WRITE(numout,*) ' 2 band light penetration ln_qsr_2bd = ', ln_qsr_2bd
371	WRITE(numout,*) ' bio-model light penetration ln_qsr_bio = ', ln_qsr_bio
372	WRITE(numout,*) ' RGB : Chl data (=1) or cst value (=0) nn_chldta = ', nn_chldta
373	WRITE(numout,*) ' RGB & 2 bands: fraction of light (rn_si1) rn_abs = ', rn_abs
374	WRITE(numout,*) ' RGB & 2 bands: shortess depth of extinction rn_si0 = ', rn_si0
375	WRITE(numout,*) ' 2 bands: longest depth of extinction rn_si1 = ', rn_si1
376	WRITE(numout,*)
377	ENDIF
378	!
379	ioptio = 0 ! Parameter control
380	IF( ln_qsr_rgb ) ioptio = ioptio + 1
381	IF( ln_qsr_2bd ) ioptio = ioptio + 1
382	IF( ln_qsr_bio ) ioptio = ioptio + 1
383	!
384	IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE type of light penetration in namelist namtra_qsr', &
385	& ' 2 bands, 3 RGB bands or bio-model light penetration' )
386	!
387	IF( ln_qsr_rgb .AND. nn_chldta == 0 ) nqsr = np_RGB
388	IF( ln_qsr_rgb .AND. nn_chldta == 1 ) nqsr = np_RGBc
389	IF( ln_qsr_2bd ) nqsr = np_2BD
390	IF( ln_qsr_bio ) nqsr = np_BIO
391	!
392	! ! Initialisation
393	xsi0r = 1._wp / rn_si0
394	xsi1r = 1._wp / rn_si1
395	!
396	SELECT CASE( nqsr )
397	!
398	CASE( np_RGB , np_RGBc ) !== Red-Green-Blue light penetration ==!
399	!
400	IF(lwp) WRITE(numout,*) ' ==>>> R-G-B light penetration '
401	!
402	CALL trc_oce_rgb( rkrgb ) ! tabulated attenuation coef.
403	!
404	nksr = trc_oce_ext_lev( r_si2, 33._wp ) ! level of light extinction
405	!
406	IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m'
407	!
408	IF( nqsr == np_RGBc ) THEN ! Chl data : set sf_chl structure
409	IF(lwp) WRITE(numout,*) ' ==>>> Chlorophyll read in a file'
410	ALLOCATE( sf_chl(1), STAT=ierror )
411	IF( ierror > 0 ) THEN
412	CALL ctl_stop( 'tra_qsr_init: unable to allocate sf_chl structure' ) ; RETURN
413	ENDIF
414	ALLOCATE( sf_chl(1)%fnow(jpi,jpj,1) )
415	IF( sn_chl%ln_tint ) ALLOCATE( sf_chl(1)%fdta(jpi,jpj,1,2) )
416	! ! fill sf_chl with sn_chl and control print
417	CALL fld_fill( sf_chl, (/ sn_chl /), cn_dir, 'tra_qsr_init', &
418	& 'Solar penetration function of read chlorophyll', 'namtra_qsr' , no_print )
419	ENDIF
420	IF( nqsr == np_RGB ) THEN ! constant Chl
421	IF(lwp) WRITE(numout,*) ' ==>>> Constant Chlorophyll concentration = 0.05'
422	ENDIF
423	!
424	CASE( np_2BD ) !== 2 bands light penetration ==!
425	!
426	IF(lwp) WRITE(numout,*) ' ==>>> 2 bands light penetration'
427	!
428	nksr =trc_oce_ext_lev( CASTDP(rn_si1), 100._wp ) ! level of light extinction
429	IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m'
430	!
431	CASE( np_BIO ) !== BIO light penetration ==!
432	!
433	IF(lwp) WRITE(numout,*) ' ==>>> bio-model light penetration'
434	IF( .NOT.lk_top ) CALL ctl_stop( 'No bio model : ln_qsr_bio = true impossible ' )
435	!
436	CALL trc_oce_rgb( rkrgb ) ! tabulated attenuation coef.
437	!
438	nksr = trc_oce_ext_lev( r_si2, 33._wp ) ! level of light extinction
439	!
440	IF(lwp) WRITE(numout,*) ' level of light extinction = ', nksr, ' ref depth = ', gdepw_1d(nksr+1), ' m'
441	!
442	END SELECT
443	!
444	qsr_hc(:,:,:) = 0._wp ! now qsr heat content set to zero where it will not be computed
445	!
446	! 1st ocean level attenuation coefficient (used in sbcssm)
447	IF( iom_varid( numror, 'fraqsr_1lev', ldstop = .FALSE. ) > 0 ) THEN
448	CALL iom_get( numror, jpdom_auto, 'fraqsr_1lev' , fraqsr_1lev )
449	ELSE
450	fraqsr_1lev(:,:) = 1._wp ! default : no penetration
451	ENDIF
452	!
453	END SUBROUTINE tra_qsr_init
454
455	!!======================================================================
456	END MODULE traqsr

Note: See TracBrowser for help on using the repository browser.

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

Context Navigation

source: NEMO/branches/2021/dev_r14116_HPC-10_mcastril_Mixed_Precision_implementation/src/OCE/TRA/traqsr.F90 @ 15540

Download in other formats: