Context Navigation

traqsr.F90 @ 12340

Last change on this file since 12340 was 12340, checked in by acc, 4 years ago

Branch 2019/dev_r11943_MERGE_2019. This commit introduces basic do loop macro
substitution to the 2019 option 1, merge branch. These changes have been SETTE
tested. The only addition is the do_loop_substitute.h90 file in the OCE directory but
the macros defined therein are used throughout the code to replace identifiable, 2D-
and 3D- nested loop opening and closing statements with single-line alternatives. Code
indents are also adjusted accordingly.

The following explanation is taken from comments in the new header file:

This header file contains preprocessor definitions and macros used in the do-loop
substitutions introduced between version 4.0 and 4.2. The primary aim of these macros
is to assist in future applications of tiling to improve performance. This is expected
to be achieved by alternative versions of these macros in selected locations. The
initial introduction of these macros simply replaces all identifiable nested 2D- and
3D-loops with single line statements (and adjusts indenting accordingly). Do loops
are identifiable if they comform to either:

DO jk = ....

DO jj = .... DO jj = ...

DO ji = .... DO ji = ...
. OR .
. .

END DO END DO

END DO END DO

END DO

and white-space variants thereof.

Additionally, only loops with recognised jj and ji loops limits are treated; these are:
Lower limits of 1, 2 or fs_2
Upper limits of jpi, jpim1 or fs_jpim1 (for ji) or jpj, jpjm1 or fs_jpjm1 (for jj)

The macro naming convention takes the form: DO_2D_BT_LR where:

B is the Bottom offset from the PE's inner domain;
T is the Top offset from the PE's inner domain;
L is the Left offset from the PE's inner domain;
R is the Right offset from the PE's inner domain

So, given an inner domain of 2,jpim1 and 2,jpjm1, a typical example would replace:

DO jj = 2, jpj

DO ji = 1, jpim1
.
.

END DO

END DO

with:

DO_2D_01_10
.
.
END_2D

similar conventions apply to the 3D loops macros. jk loop limits are retained
through macro arguments and are not restricted. This includes the possibility of
strides for which an extra set of DO_3DS macros are defined.

In the example definition below the inner PE domain is defined by start indices of
(kIs, kJs) and end indices of (kIe, KJe)

#define DO_2D_00_00 DO jj = kJs, kJe ; DO ji = kIs, kIe
#define END_2D END DO ; END DO

TO DO:

Only conventional nested loops have been identified and replaced by this step. There are constructs such as:

DO jk = 2, jpkm1

z2d(:,:) = z2d(:,:) + e3w(:,:,jk,Kmm) * z3d(:,:,jk) * wmask(:,:,jk)

END DO

which may need to be considered.

Property svn:keywords set to Id

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

Download in other formats: