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.

trasbc_tam.F90 in branches/2012/dev_r3604_LEGI8_TAM/NEMOGCM/NEMO/OPATAM_SRC/TRA – NEMO

Context Navigation

source: branches/2012/dev_r3604_LEGI8_TAM/NEMOGCM/NEMO/OPATAM_SRC/TRA/trasbc_tam.F90 @ 3611

Last change on this file since 3611 was 3611, checked in by pabouttier, 11 years ago
Add TAM code and ORCA2_TAM configuration - see Ticket #1007
Property svn:executable set to ``*
File size: 38.8 KB

Line
1	MODULE trasbc_tam
2	#if defined key_tam
3	!!==============================================================================
4	!! * MODULE trasbc *
5	!! Ocean active tracers: surface boundary condition
6	!!==============================================================================
7	!! History : OPA ! 1998-10 (G. Madec, G. Roullet, M. Imbard) Original code
8	!! 8.2 ! 2001-02 (D. Ludicone) sea ice and free surface
9	!! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module
10	!! 3.3 ! 2010-04 (M. Leclair, G. Madec) Forcing averaged over 2 time steps
11	!! - ! 2010-09 (C. Ethe, G. Madec) Merge TRA-TRC
12	!!----------------------------------------------------------------------
13
14	!!----------------------------------------------------------------------
15	!! tra_sbc : update the tracer trend at ocean surface
16	!!----------------------------------------------------------------------
17	USE oce ! ocean dynamics and active tracers
18	USE oce_tam
19	USE sbc_oce ! surface boundary condition: ocean
20	USE sbc_oce_tam
21	USE dom_oce ! ocean space domain variables
22	USE phycst ! physical constant
23	USE traqsr ! solar radiation penetration
24	USE traqsr_tam
25	USE trdmod_oce ! ocean trends
26	USE trdtra ! ocean trends
27	USE in_out_manager ! I/O manager
28	USE prtctl ! Print control
29	USE restart ! ocean restart
30	USE sbcrnf ! River runoff
31	USE sbcrnf_tam ! River runoff
32	USE sbcmod ! ln_rnf
33	USE iom
34	USE lbclnk ! ocean lateral boundary conditions (or mpp link)
35	USE lbclnk_tam ! ocean lateral boundary conditions (or mpp link)
36	USE wrk_nemo ! Memory Allocation
37	USE timing ! Timing
38	USE tstool_tam
39	USE paresp
40	USE dotprodfld
41	USE gridrandom
42
43	IMPLICIT NONE
44	PRIVATE
45
46	PUBLIC tra_sbc_tan ! routine called by step.F90
47	PUBLIC tra_sbc_adj ! routine called by step.F90
48	PUBLIC tra_sbc_adj_tst
49
50	!! * Substitutions
51	# include "domzgr_substitute.h90"
52	# include "vectopt_loop_substitute.h90"
53	!!----------------------------------------------------------------------
54	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
55	!! $Id$
56	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
57	!!----------------------------------------------------------------------
58	CONTAINS
59
60	SUBROUTINE tra_sbc_tan ( kt )
61	!!----------------------------------------------------------------------
62	!! * ROUTINE tra_sbc_tan *
63	!!
64	!! ** Purpose : Compute the tracer surface boundary condition trend of
65	!! (flux through the interface, concentration/dilution effect)
66	!! and add it to the general trend of tracer equations.
67	!!
68	!! ** Method :
69	!! Following Roullet and Madec (2000), the air-sea flux can be divided
70	!! into three effects: (1) Fext, external forcing;
71	!! (2) Fwi, concentration/dilution effect due to water exchanged
72	!! at the surface by evaporation, precipitations and runoff (E-P-R);
73	!! (3) Fwe, tracer carried with the water that is exchanged.
74	!!
75	!! Fext, flux through the air-sea interface for temperature and salt:
76	!! - temperature : heat flux q (w/m2). If penetrative solar
77	!! radiation q is only the non solar part of the heat flux, the
78	!! solar part is added in traqsr.F routine.
79	!! ta = ta + q /(rau0 rcp e3t) for k=1
80	!! - salinity : no salt flux
81	!!
82	!! The formulation for Fwb and Fwi vary according to the free
83	!! surface formulation (linear or variable volume).
84	!! * Linear free surface
85	!! The surface freshwater flux modifies the ocean volume
86	!! and thus the concentration of a tracer and the temperature.
87	!! First order of the effect of surface freshwater exchange
88	!! for salinity, it can be neglected on temperature (especially
89	!! as the temperature of precipitations and runoffs is usually
90	!! unknown).
91	!! - temperature : we assume that the temperature of both
92	!! precipitations and runoffs is equal to the SST, thus there
93	!! is no additional flux since in this case, the concentration
94	!! dilution effect is balanced by the net heat flux associated
95	!! to the freshwater exchange (Fwe+Fwi=0):
96	!! (Tp P - Te E) + SST (P-E) = 0 when Tp=Te=SST
97	!! - salinity : evaporation, precipitation and runoff
98	!! water has a zero salinity (Fwe=0), thus only Fwi remains:
99	!! sa = sa + emp * sn / e3t for k=1
100	!! where emp, the surface freshwater budget (evaporation minus
101	!! precipitation minus runoff) given in kg/m2/s is divided
102	!! by 1035 kg/m3 (density of ocena water) to obtain m/s.
103	!! Note: even though Fwe does not appear explicitly for
104	!! temperature in this routine, the heat carried by the water
105	!! exchanged through the surface is part of the total heat flux
106	!! forcing and must be taken into account in the global heat
107	!! balance).
108	!! * nonlinear free surface (variable volume, lk_vvl)
109	!! contrary to the linear free surface case, Fwi is properly
110	!! taken into account by using the true layer thicknesses to
111	!! calculate tracer content and advection. There is no need to
112	!! deal with it in this routine.
113	!! - temperature: Fwe=SST (P-E+R) is added to Fext.
114	!! - salinity: Fwe = 0, there is no surface flux of salt.
115	!!
116	!! ** Action : - Update the 1st level of (ta,sa) with the trend associated
117	!! with the tracer surface boundary condition
118	!! - save the trend it in ttrd ('key_trdtra')
119	!!----------------------------------------------------------------------
120	INTEGER, INTENT(in) :: kt ! ocean time-step index
121	!!
122	INTEGER :: ji, jj, jk, jn ! dummy loop indices
123	REAL(wp) :: zfact, z1_e3t, zsrau, zdep
124	!!----------------------------------------------------------------------
125	!
126	IF( nn_timing == 1 ) CALL timing_start('tra_sbc_tan')
127	!
128	IF( kt == nit000 ) THEN
129	IF(lwp) WRITE(numout,*)
130	IF(lwp) WRITE(numout,*) 'tra_sbc_tan : TRAcer Surface Boundary Condition'
131	IF(lwp) WRITE(numout,*) '~~~~~~~ '
132	ENDIF
133
134	zsrau = 1. / rau0 ! initialization
135
136	IF( .NOT.ln_traqsr ) THEN ! no solar radiation penetration
137	qns_tl(:,:) = qns_tl(:,:) + qsr_tl(:,:) ! total heat flux in qns
138	qsr_tl(:,:) = 0.e0 ! qsr set to zero
139	ENDIF
140	!
141	!----------------------------------------
142	! EMP, EMPS and QNS effects
143	!----------------------------------------
144	! Set before sbc tracer content fields
145	! ************************************
146	IF( kt == nit000 ) THEN ! Set the forcing field at nit000 - 1
147	! ! -----------------------------------
148	IF( ln_rstart ) THEN
149	zfact = 0.5e0
150	sbc_tsc_b_tl(:,:,:) = 0.0_wp
151	ELSE ! No restart or restart not found: Euler forward time stepping
152	zfact = 1.e0
153	sbc_tsc_b_tl(:,:,:) = 0.0_wp
154	ENDIF
155	ELSE ! Swap of forcing fields
156	! ! ----------------------
157	zfact = 0.5e0
158	sbc_tsc_b_tl(:,:,:) = sbc_tsc_tl(:,:,:)
159	ENDIF
160	! Compute now sbc tracer content fields
161	! *************************************
162
163	! Concentration dilution effect on (t,s) due to
164	! evaporation, precipitation and qns, but not river runoff
165
166	IF( lk_vvl ) THEN ! Variable Volume case
167	!DO jj = 1, jpj
168	!DO ji = 1, jpi
169	!! temperature : heat flux + cooling/heating effet of EMP flux
170	!sbc_tsc(ji,jj,jp_tem) = ro0cpr * qns(ji,jj) - zsrau * emp(ji,jj) * tsn(ji,jj,1,jp_tem)
171	!! concent./dilut. effect due to sea-ice melt/formation and (possibly) SSS restoration
172	!sbc_tsc(ji,jj,jp_sal) = ( emps(ji,jj) - emp(ji,jj) ) * zsrau * tsn(ji,jj,1,jp_sal)
173	!END DO
174	!END DO
175	CALL ctl_stop('key_vvl not implemented in TAM yet')
176	ELSE ! Constant Volume case
177	DO jj = 2, jpj
178	DO ji = fs_2, fs_jpim1 ! vector opt.
179	! temperature : heat flux
180	sbc_tsc_tl(ji,jj,jp_tem) = ro0cpr * qns_tl(ji,jj)
181	! salinity : salt flux + concent./dilut. effect (both in emps)
182	sbc_tsc_tl(ji,jj,jp_sal) = zsrau * ( emps_tl(ji,jj) * tsn(ji,jj,1,jp_sal) &
183	& + emps(ji,jj) * tsn_tl(ji,jj,1,jp_sal) )
184	END DO
185	END DO
186	ENDIF
187	! Concentration dilution effect on (t,s) due to evapouration, precipitation and qns, but not river runoff
188	DO jn = 1, jpts
189	DO jj = 2, jpj
190	DO ji = fs_2, fs_jpim1 ! vector opt.
191	z1_e3t = zfact / fse3t(ji,jj,1)
192	tsa_tl(ji,jj,1,jn) = tsa_tl(ji,jj,1,jn) + ( sbc_tsc_b_tl(ji,jj,jn) + sbc_tsc_tl(ji,jj,jn) ) * z1_e3t
193	END DO
194	END DO
195	END DO
196	!
197	!----------------------------------------
198	! River Runoff effects
199	!----------------------------------------
200	!
201	zfact = 0.5e0
202	!
203	! Effect on (t,s) due to river runoff (dilution effect automatically applied via vertical tracer advection)
204	IF( ln_rnf ) THEN
205	DO jj = 2, jpj
206	DO ji = fs_2, fs_jpim1
207	zdep = 1. / h_rnf(ji,jj)
208	zdep = zfact * zdep
209	IF ( rnf(ji,jj) /= 0._wp ) THEN
210	DO jk = 1, nk_rnf(ji,jj)
211	tsa_tl(ji,jj,jk,jp_tem) = tsa_tl(ji,jj,jk,jp_tem) &
212	& + ( rnf_tsc_b_tl(ji,jj,jp_tem) + rnf_tsc_tl(ji,jj,jp_tem) ) * zdep
213	IF( ln_rnf_sal ) tsa_tl(ji,jj,jk,jp_sal) = tsa_tl(ji,jj,jk,jp_sal) &
214	& + ( rnf_tsc_b_tl(ji,jj,jp_sal) + rnf_tsc_tl(ji,jj,jp_sal) ) * zdep
215	END DO
216	ENDIF
217	END DO
218	END DO
219	ENDIF
220	!!gm It should be useless
221	CALL lbc_lnk( tsa(:,:,:,jp_tem), 'T', 1. ) ; CALL lbc_lnk( tsa_tl(:,:,:,jp_sal), 'T', 1. )
222	!
223	IF( nn_timing == 1 ) CALL timing_stop('tra_sbc_tan')
224	!
225	END SUBROUTINE tra_sbc_tan
226
227	SUBROUTINE tra_sbc_adj ( kt )
228	!!----------------------------------------------------------------------
229	!! * ROUTINE tra_sbc_adj *
230	!!
231	!! ** Purpose : Compute the tracer surface boundary condition trend of
232	!! (flux through the interface, concentration/dilution effect)
233	!! and add it to the general trend of tracer equations.
234	!!
235	!! ** Method :
236	!! Following Roullet and Madec (2000), the air-sea flux can be divided
237	!! into three effects: (1) Fext, external forcing;
238	!! (2) Fwi, concentration/dilution effect due to water exchanged
239	!! at the surface by evaporation, precipitations and runoff (E-P-R);
240	!! (3) Fwe, tracer carried with the water that is exchanged.
241	!!
242	!! Fext, flux through the air-sea interface for temperature and salt:
243	!! - temperature : heat flux q (w/m2). If penetrative solar
244	!! radiation q is only the non solar part of the heat flux, the
245	!! solar part is added in traqsr.F routine.
246	!! ta = ta + q /(rau0 rcp e3t) for k=1
247	!! - salinity : no salt flux
248	!!
249	!! The formulation for Fwb and Fwi vary according to the free
250	!! surface formulation (linear or variable volume).
251	!! * Linear free surface
252	!! The surface freshwater flux modifies the ocean volume
253	!! and thus the concentration of a tracer and the temperature.
254	!! First order of the effect of surface freshwater exchange
255	!! for salinity, it can be neglected on temperature (especially
256	!! as the temperature of precipitations and runoffs is usually
257	!! unknown).
258	!! - temperature : we assume that the temperature of both
259	!! precipitations and runoffs is equal to the SST, thus there
260	!! is no additional flux since in this case, the concentration
261	!! dilution effect is balanced by the net heat flux associated
262	!! to the freshwater exchange (Fwe+Fwi=0):
263	!! (Tp P - Te E) + SST (P-E) = 0 when Tp=Te=SST
264	!! - salinity : evaporation, precipitation and runoff
265	!! water has a zero salinity (Fwe=0), thus only Fwi remains:
266	!! sa = sa + emp * sn / e3t for k=1
267	!! where emp, the surface freshwater budget (evaporation minus
268	!! precipitation minus runoff) given in kg/m2/s is divided
269	!! by 1035 kg/m3 (density of ocena water) to obtain m/s.
270	!! Note: even though Fwe does not appear explicitly for
271	!! temperature in this routine, the heat carried by the water
272	!! exchanged through the surface is part of the total heat flux
273	!! forcing and must be taken into account in the global heat
274	!! balance).
275	!! * nonlinear free surface (variable volume, lk_vvl)
276	!! contrary to the linear free surface case, Fwi is properly
277	!! taken into account by using the true layer thicknesses to
278	!! calculate tracer content and advection. There is no need to
279	!! deal with it in this routine.
280	!! - temperature: Fwe=SST (P-E+R) is added to Fext.
281	!! - salinity: Fwe = 0, there is no surface flux of salt.
282	!!
283	!! ** Action : - Update the 1st level of (ta,sa) with the trend associated
284	!! with the tracer surface boundary condition
285	!! - save the trend it in ttrd ('key_trdtra')
286	!!----------------------------------------------------------------------
287	INTEGER, INTENT(in) :: kt ! ocean time-step index
288	!!
289	INTEGER :: ji, jj, jk, jn ! dummy loop indices
290	REAL(wp) :: zfact, z1_e3t, zsrau, zdep
291	!!----------------------------------------------------------------------
292	!
293	IF( nn_timing == 1 ) CALL timing_start('tra_sbc_adj')
294	!
295	IF( kt == nitend ) THEN
296	IF(lwp) WRITE(numout,*)
297	IF(lwp) WRITE(numout,*) 'tra_sbc_adj : TRAcer Surface Boundary Condition'
298	IF(lwp) WRITE(numout,*) '~~~~~~~ '
299	ENDIF
300
301	zsrau = 1. / rau0 ! initialization
302	!!gm It should be useless
303	CALL lbc_lnk_adj( tsa_ad(:,:,:,jp_tem), 'T', 1. ) ; CALL lbc_lnk_adj( tsa_ad(:,:,:,jp_sal), 'T', 1. )
304	!
305	!----------------------------------------
306	! River Runoff effects
307	!----------------------------------------
308	!
309	zfact = 0.5e0
310
311	! Effect on (t,s) due to river runoff (dilution effect automatically applied via vertical tracer advection)
312	IF( ln_rnf ) THEN
313	DO jj = 2, jpj
314	DO ji = fs_2, fs_jpim1
315	zdep = 1. / h_rnf(ji,jj)
316	zdep = zfact * zdep
317	IF ( rnf(ji,jj) /= 0._wp ) THEN
318	DO jk = 1, nk_rnf(ji,jj)
319	rnf_tsc_b_ad(ji,jj,jp_tem) = rnf_tsc_b_ad(ji,jj,jp_tem) + tsa_ad(ji,jj,jk,jp_tem) * zdep
320	rnf_tsc_ad(ji,jj,jp_tem) = rnf_tsc_ad(ji,jj,jp_tem) + tsa_ad(ji,jj,jk,jp_tem) * zdep
321	IF( ln_rnf_sal ) THEN
322	rnf_tsc_b_ad(ji,jj,jp_sal) = rnf_tsc_b_ad(ji,jj,jp_sal) + tsa_ad(ji,jj,jk,jp_sal) * zdep
323	rnf_tsc_ad(ji,jj,jp_sal) = rnf_tsc_ad(ji,jj,jp_sal) + tsa_ad(ji,jj,jk,jp_sal) * zdep
324	ENDIF
325	END DO
326	ENDIF
327	END DO
328	END DO
329	ENDIF
330	!
331	IF( kt == nit000 ) THEN ! Set the forcing field at nit000 - 1
332	! ! -----------------------------------
333	IF( ln_rstart ) THEN
334	zfact = 0.5e0
335	ELSE ! No restart or restart not found: Euler forward time stepping
336	zfact = 1.e0
337	ENDIF
338	ENDIF
339	! Set before sbc tracer content fields
340	! ************************************
341	! Concentration dilution effect on (t,s) due to evapouration, precipitation and qns, but not river runoff
342	DO jn = 1, jpts
343	DO jj = 2, jpj
344	DO ji = fs_2, fs_jpim1 ! vector opt.
345	z1_e3t = zfact / fse3t(ji,jj,1)
346	sbc_tsc_b_ad(ji,jj,jn) = sbc_tsc_b_ad(ji,jj,jn) + tsa_ad(ji,jj,1,jn) * z1_e3t
347	sbc_tsc_ad(ji,jj,jn) = sbc_tsc_ad(ji,jj,jn) + tsa_ad(ji,jj,1,jn) * z1_e3t
348	END DO
349	END DO
350	END DO
351	!
352	! Compute now sbc tracer content fields
353	! *************************************
354
355	! Concentration dilution effect on (t,s) due to
356	! evaporation, precipitation and qns, but not river runoff
357
358	IF( lk_vvl ) THEN ! Variable Volume case
359	!DO jj = 1, jpj
360	!DO ji = 1, jpi
361	!! temperature : heat flux + cooling/heating effet of EMP flux
362	!sbc_tsc(ji,jj,jp_tem) = ro0cpr * qns(ji,jj) - zsrau * emp(ji,jj) * tsn(ji,jj,1,jp_tem)
363	!! concent./dilut. effect due to sea-ice melt/formation and (possibly) SSS restoration
364	!sbc_tsc(ji,jj,jp_sal) = ( emps(ji,jj) - emp(ji,jj) ) * zsrau * tsn(ji,jj,1,jp_sal)
365	!END DO
366	!END DO
367	CALL ctl_stop('key_vvl not implemented in TAM yet')
368	ELSE ! Constant Volume case
369	DO jj = 2, jpj
370	DO ji = fs_2, fs_jpim1 ! vector opt.
371	! salinity : salt flux + concent./dilut. effect (both in emps)
372	emps_ad(ji,jj) = emps_ad(ji,jj) + zsrau * (sbc_tsc_ad(ji,jj,jp_sal) * tsn(ji,jj,1,jp_sal))
373	tsn_ad(ji,jj,1,jp_sal) = tsn_ad(ji,jj,1,jp_sal) + zsrau * (sbc_tsc_ad(ji,jj,jp_sal) * emps(ji,jj))
374	! temperature : heat flux
375	qns_ad(ji,jj) = qns_ad(ji,jj) + ro0cpr * sbc_tsc_ad(ji,jj,jp_tem)
376	sbc_tsc_ad(ji,jj,jp_sal) = 0._wp
377	sbc_tsc_ad(ji,jj,jp_tem) = 0._wp
378	END DO
379	END DO
380	ENDIF
381
382	IF (kt /= nit000 ) THEN ! Swap of forcing fields
383	! ! ----------------------
384	sbc_tsc_ad(:,:,:) = sbc_tsc_ad(:,:,:) + sbc_tsc_b_ad(:,:,:)
385	sbc_tsc_b_ad(:,:,:) = 0._wp
386	ELSE
387	sbc_tsc_b_ad(:,:,:) = 0._wp
388	ENDIF
389	!
390	!----------------------------------------
391	! EMP, EMPS and QNS effects
392	!----------------------------------------
393	!
394	IF( .NOT.ln_traqsr ) THEN ! no solar radiation penetration
395	qsr_ad(:,:) = qsr_ad(:,:) + qns_ad(:,:)
396	qns_ad(:,:) = 0._wp
397	ENDIF
398	!
399	IF( nn_timing == 1 ) CALL timing_stop('tra_sbc_adj')
400	!
401	END SUBROUTINE tra_sbc_adj
402	SUBROUTINE tra_sbc_adj_tst ( kumadt )
403	!!-----------------------------------------------------------------------
404	!!
405	!! * ROUTINE tra_sbc_adj_tst : TEST OF tra_sbc_adj *
406	!!
407	!! ** Purpose : Test the adjoint routine.
408	!!
409	!! ** Method : Verify the scalar product
410	!!
411	!! ( L dx )^T W dy = dx^T L^T W dy
412	!!
413	!! where L = tangent routine
414	!! L^T = adjoint routine
415	!! W = diagonal matrix of scale factors
416	!! dx = input perturbation (random field)
417	!! dy = L dx
418	!!
419	!! History :
420	!! ! 08-08 (A. Vidard)
421	!!-----------------------------------------------------------------------
422	!! * Modules used
423	USE trj_tam
424	!! * Arguments
425	INTEGER, INTENT(IN) :: &
426	& kumadt ! Output unit
427
428	INTEGER :: &
429	& ji, & ! dummy loop indices
430	& jj, &
431	& jk
432
433	!! * Local declarations
434	REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: &
435	& zsn_tlin, &! Tangent input : now salinity
436	& zsa_tlin, &! Tangent input : after salinity
437	& zta_tlin, &! Tangent input : after temperature
438	& zqns_tlin, &! Tangent input : solar radiation (w/m2)
439	& zqsr_tlin, &! Tangent input : evaporation - precipitation (free surface)
440	& zemps_tlin, &! Tangent input : evaporation - precipitation (free surface)
441	& zsbc_tc_tlin, &! Tangent input : evaporation - precipitation (free surface)
442	& zsbc_sc_tlin, &! Tangent input : evaporation - precipitation (free surface)
443	& zrnf_tc_tlin, &! Tangent input : evaporation - precipitation (free surface)
444	& zrnf_sc_tlin, &! Tangent input : evaporation - precipitation (free surface)
445	& zrnf_tc_b_tlin, &! Tangent input : evaporation - precipitation (free surface)
446	& zrnf_sc_b_tlin, &! Tangent input : evaporation - precipitation (free surface)
447	& zsa_tlout, &! Tangent output: after salinity
448	& zta_tlout, &! Tangent output: after temperature
449	& zqns_tlout, &! Tangent output: after temperature
450	& zqsr_tlout, &! Tangent output: after temperature
451	& zsbc_tc_tlout, &! Tangent output: after temperature
452	& zsbc_sc_tlout, &! Tangent output: after temperature
453	& zsbc_tc_b_tlout,&! Tangent output: after temperature
454	& zsbc_sc_b_tlout,&! Tangent output: after temperature
455	& zsa_adin, &! Adjoint input : after salinity
456	& zta_adin, &! Adjoint input : after temperature
457	& zqns_adin, &! Tangent output: after temperature
458	& zqsr_adin, &! Tangent output: after temperature
459	& zsbc_tc_adin, &! Tangent output: after temperature
460	& zsbc_sc_adin, &! Tangent output: after temperature
461	& zsbc_tc_b_adin,&! Tangent output: after temperature
462	& zsbc_sc_b_adin,&! Tangent output: after temperature
463	& zsn_adout, &! Adjoint output: now salinity
464	& zsa_adout, &! Adjoint output: after salinity
465	& zta_adout, &! Adjoint output: after temperature
466	& zqns_adout, &! Adjoint output: solar radiation (w/m2)
467	& zqsr_adout, &! Tangent input : evaporation - precipitation (free surface)
468	& zemps_adout, &! Tangent input : evaporation - precipitation (free surface)
469	& zsbc_tc_adout, &! Tangent input : evaporation - precipitation (free surface)
470	& zsbc_sc_adout, &! Tangent input : evaporation - precipitation (free surface)
471	& zrnf_tc_adout, &! Tangent input : evaporation - precipitation (free surface)
472	& zrnf_sc_adout, &! Tangent input : evaporation - precipitation (free surface)
473	& zrnf_tc_b_adout, &! Tangent input : evaporation - precipitation (free surface)
474	& zrnf_sc_b_adout, &! Tangent input : evaporation - precipitation (free surface)
475	& zsn, &! temporary now salinity
476	& zsa, &! temporary after salinity
477	& zta, &! temporary after temperature
478	& zqns, &! temporary solar radiation (w/m2)
479	& zemps ! temporary evaporation - precipitation (free surface)
480	REAL(KIND=wp) :: &
481	& zsp1, & ! scalar product involving the tangent routine
482	& zsp1_1, & ! scalar product involving the tangent routine
483	& zsp1_2, & ! scalar product involving the tangent routine
484	& zsp1_3, & ! scalar product involving the tangent routine
485	& zsp1_4, & ! scalar product involving the tangent routine
486	& zsp1_5, & ! scalar product involving the tangent routine
487	& zsp1_6, & ! scalar product involving the tangent routine
488	& zsp1_7, & ! scalar product involving the tangent routine
489	& zsp1_8, & ! scalar product involving the tangent routine
490	& zsp2, & ! scalar product involving the adjoint routine
491	& zsp2_1, & ! scalar product involving the adjoint routine
492	& zsp2_2, & ! scalar product involving the adjoint routine
493	& zsp2_3, & ! scalar product involving the adjoint routine
494	& zsp2_4, & ! scalar product involving the adjoint routine
495	& zsp2_5, & ! scalar product involving the adjoint routine
496	& zsp2_6, & ! scalar product involving the adjoint routine
497	& zsp2_7, & ! scalar product involving the adjoint routine
498	& zsp2_8, & ! scalar product involving the adjoint routine
499	& zsp2_9, & ! scalar product involving the adjoint routine
500	& zsp2_10, & ! scalar product involving the adjoint routine
501	& zsp2_11, & ! scalar product involving the adjoint routine
502	& zsp2_12, & ! scalar product involving the adjoint routine
503	& z2dt, & ! temporary scalars
504	& zraur
505	CHARACTER (LEN=14) :: &
506	& cl_name
507
508	ALLOCATE( &
509	& zsn_tlin(jpi,jpj), &
510	& zsa_tlin(jpi,jpj), &
511	& zta_tlin(jpi,jpj), &
512	& zqns_tlin(jpi,jpj), &
513	& zqsr_tlin(jpi,jpj), &
514	& zemps_tlin(jpi,jpj), &
515	& zsbc_tc_tlin(jpi,jpj), &
516	& zsbc_sc_tlin(jpi,jpj), &
517	& zrnf_tc_tlin(jpi,jpj), &
518	& zrnf_sc_tlin(jpi,jpj), &
519	& zrnf_tc_b_tlin(jpi,jpj), &
520	& zrnf_sc_b_tlin(jpi,jpj), &
521	& zsa_tlout(jpi,jpj), &
522	& zta_tlout(jpi,jpj), &
523	& zqns_tlout(jpi,jpj), &
524	& zqsr_tlout(jpi,jpj), &
525	& zsbc_tc_tlout(jpi,jpj), &
526	& zsbc_sc_tlout(jpi,jpj), &
527	& zsbc_tc_b_tlout(jpi,jpj), &
528	& zsbc_sc_b_tlout(jpi,jpj), &
529	& zsn_adout(jpi,jpj), &
530	& zsa_adout(jpi,jpj), &
531	& zta_adout(jpi,jpj), &
532	& zqns_adout(jpi,jpj), &
533	& zqsr_adout(jpi,jpj), &
534	& zemps_adout(jpi,jpj), &
535	& zsbc_tc_adout(jpi,jpj), &
536	& zsbc_sc_adout(jpi,jpj), &
537	& zrnf_tc_adout(jpi,jpj), &
538	& zrnf_sc_adout(jpi,jpj), &
539	& zrnf_tc_b_adout(jpi,jpj), &
540	& zrnf_sc_b_adout(jpi,jpj), &
541	& zsa_adin(jpi,jpj), &
542	& zta_adin(jpi,jpj), &
543	& zqns_adin(jpi,jpj), &
544	& zqsr_adin(jpi,jpj), &
545	& zsbc_tc_adin(jpi,jpj), &
546	& zsbc_sc_adin(jpi,jpj), &
547	& zsbc_tc_b_adin(jpi,jpj), &
548	& zsbc_sc_b_adin(jpi,jpj), &
549	& zsn(jpi,jpj), &
550	& zsa(jpi,jpj), &
551	& zta(jpi,jpj), &
552	& zqns(jpi,jpj), &
553	& zemps(jpi,jpj) &
554	& )
555
556
557	! Initialize constants
558	z2dt = 2.0_wp * rdt ! time step: leap-frog
559	zraur = 1.0_wp / rau0 ! inverse density of pure water (m3/kg)
560
561	! Initialize the reference state
562
563	!===========================================================================
564	! 1) dx = ( qns_tl, sn_tl, emps_tl, ta_tl, sa_tl ) and dy = ( ta_tl, sa_tl )
565	!===========================================================================
566
567	!--------------------------------------------------------------------
568	! Reset the tangent and adjoint variables
569	!--------------------------------------------------------------------
570
571	tsn_tl (:,:,:,:) = 0.0_wp
572	tsa_tl (:,:,:,:) = 0.0_wp
573	emps_tl(:,:) = 0.0_wp
574	qns_tl (:,:) = 0.0_wp
575	qsr_tl (:,:) = 0.0_wp
576	sbc_tsc_tl (:,:,:) = 0.0_wp
577	sbc_tsc_b_tl (:,:,:) = 0.0_wp
578	rnf_tsc_tl (:,:,:) = 0.0_wp
579	rnf_tsc_b_tl (:,:,:) = 0.0_wp
580	tsn_ad (:,:,:,:) = 0.0_wp
581	tsa_ad (:,:,:,:) = 0.0_wp
582	emps_ad(:,:) = 0.0_wp
583	qns_ad (:,:) = 0.0_wp
584	qsr_ad (:,:) = 0.0_wp
585	sbc_tsc_ad (:,:,:) = 0.0_wp
586	sbc_tsc_b_ad (:,:,:) = 0.0_wp
587	rnf_tsc_ad (:,:,:) = 0.0_wp
588	rnf_tsc_b_ad (:,:,:) = 0.0_wp
589
590	zsn_tlin (:,:) = 0.0_wp
591	zsa_tlin (:,:) = 0.0_wp
592	zta_tlin (:,:) = 0.0_wp
593	zqsr_tlin (:,:) = 0.0_wp
594	zqns_tlin (:,:) = 0.0_wp
595	zemps_tlin (:,:) = 0.0_wp
596	zsbc_tc_tlin (:,:) = 0.0_wp
597	zsbc_sc_tlin (:,:) = 0.0_wp
598	zrnf_tc_tlin (:,:) = 0.0_wp
599	zrnf_sc_tlin (:,:) = 0.0_wp
600	zrnf_tc_b_tlin (:,:) = 0.0_wp
601	zrnf_sc_b_tlin (:,:) = 0.0_wp
602	zsa_tlout (:,:) = 0.0_wp
603	zta_tlout (:,:) = 0.0_wp
604	zqns_tlout (:,:) = 0.0_wp
605	zqsr_tlout (:,:) = 0.0_wp
606	zsbc_tc_tlout (:,:) = 0.0_wp
607	zsbc_sc_tlout (:,:) = 0.0_wp
608	zsbc_tc_b_tlout (:,:) = 0.0_wp
609	zsbc_sc_b_tlout (:,:) = 0.0_wp
610	zsn_adout (:,:) = 0.0_wp
611	zsa_adout (:,:) = 0.0_wp
612	zta_adout (:,:) = 0.0_wp
613	zqsr_adout (:,:) = 0.0_wp
614	zqns_adout (:,:) = 0.0_wp
615	zemps_adout (:,:) = 0.0_wp
616	zsbc_tc_adout (:,:) = 0.0_wp
617	zsbc_sc_adout (:,:) = 0.0_wp
618	zrnf_tc_adout (:,:) = 0.0_wp
619	zrnf_sc_adout (:,:) = 0.0_wp
620	zrnf_tc_b_adout (:,:) = 0.0_wp
621	zrnf_sc_b_adout (:,:) = 0.0_wp
622	zsa_adin (:,:) = 0.0_wp
623	zta_adin (:,:) = 0.0_wp
624	zqns_adin (:,:) = 0.0_wp
625	zqsr_adin (:,:) = 0.0_wp
626	zsbc_tc_adin (:,:) = 0.0_wp
627	zsbc_sc_adin (:,:) = 0.0_wp
628	zsbc_tc_b_adin (:,:) = 0.0_wp
629	zsbc_sc_b_adin (:,:) = 0.0_wp
630
631	CALL grid_random( zemps, 'T', 0.0_wp, stdemp )
632	CALL grid_random( zqns, 'T', 0.0_wp, stdqns )
633	CALL grid_random( zsn, 'T', 0.0_wp, stds )
634	CALL grid_random( zsa, 'T', 0.0_wp, stds )
635	CALL grid_random( zta, 'T', 0.0_wp, stdt )
636
637	DO jj = nldj, nlej
638	DO ji = nldi, nlei
639	zsn_tlin (ji,jj) = zsn (ji,jj)
640	zsa_tlin (ji,jj) = zsa (ji,jj)
641	zta_tlin (ji,jj) = zta (ji,jj)
642	zemps_tlin(ji,jj) = zemps(ji,jj) / ( z2dt * zraur )
643	zqns_tlin (ji,jj) = zqns (ji,jj)
644	zqsr_tlin (ji,jj) = zqns (ji,jj)
645	zsbc_tc_tlin (ji,jj) = zqns (ji,jj)
646	zsbc_sc_tlin (ji,jj) = zqns (ji,jj)
647	zrnf_tc_tlin (ji,jj) = zqns (ji,jj)
648	zrnf_sc_tlin (ji,jj) = zqns (ji,jj)
649	zrnf_tc_b_tlin (ji,jj) = zqns (ji,jj)
650	zrnf_sc_b_tlin (ji,jj) = zqns (ji,jj)
651	END DO
652	END DO
653
654	!--------------------------------------------------------------------
655	! Call the tangent routine: dy = L dx
656	!--------------------------------------------------------------------
657
658	tsn_tl (:,:,1,jp_sal) = zsn_tlin (:,:)
659	tsa_tl (:,:,1,jp_sal) = zsa_tlin (:,:)
660	tsa_tl (:,:,1,jp_tem) = zta_tlin (:,:)
661	emps_tl(:,:) = zemps_tlin(:,:)
662	qns_tl (:,:) = zqns_tlin (:,:)
663	qsr_tl (:,:) = zqsr_tlin (:,:)
664	sbc_tsc_tl (:,:,jp_tem) = zsbc_tc_tlin (:,:)
665	sbc_tsc_tl (:,:,jp_sal) = zsbc_sc_tlin (:,:)
666	rnf_tsc_tl (:,:,jp_tem) = zrnf_tc_tlin (:,:)
667	rnf_tsc_tl (:,:,jp_sal) = zrnf_sc_tlin (:,:)
668	rnf_tsc_b_tl (:,:,jp_tem) = zrnf_tc_b_tlin (:,:)
669	rnf_tsc_b_tl (:,:,jp_sal) = zrnf_sc_b_tlin (:,:)
670
671	CALL tra_sbc_tan( nit000 )
672
673	zsa_tlout(:,:) = tsa_tl(:,:,1,jp_sal)
674	zta_tlout(:,:) = tsa_tl(:,:,1,jp_tem)
675	zqns_tlout(:,:) = qns_tl(:,:)
676	zqsr_tlout(:,:) = qsr_tl(:,:)
677	zsbc_tc_tlout(:,:) = sbc_tsc_tl(:,:,jp_tem)
678	zsbc_sc_tlout(:,:) = sbc_tsc_tl(:,:,jp_sal)
679	zsbc_tc_b_tlout(:,:) = sbc_tsc_b_tl(:,:,jp_tem)
680	zsbc_sc_b_tlout(:,:) = sbc_tsc_b_tl(:,:,jp_sal)
681
682	!--------------------------------------------------------------------
683	! Initialize the adjoint variables: dy^* = W dy
684	!--------------------------------------------------------------------
685
686	DO jj = nldj, nlej
687	DO ji = nldi, nlei
688	zsa_adin(ji,jj) = zsa_tlout(ji,jj) &
689	& * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,1) &
690	& * tmask(ji,jj,1) * wesp_s(1)
691	zta_adin(ji,jj) = zta_tlout(ji,jj) &
692	& * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,1) &
693	& * tmask(ji,jj,1) * wesp_t(1)
694	zqns_adin(ji,jj) = zqns_tlout(ji,jj) &
695	& * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,1) &
696	& * tmask(ji,jj,1) * wesp_t(1)
697	zqsr_adin(ji,jj) = zqsr_tlout(ji,jj) &
698	& * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,1) &
699	& * tmask(ji,jj,1) * wesp_t(1)
700	zsbc_tc_adin(ji,jj) = zsbc_tc_tlout(ji,jj) &
701	& * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,1) &
702	& * tmask(ji,jj,1) * wesp_t(1)
703	zsbc_sc_adin(ji,jj) = zsbc_sc_tlout(ji,jj) &
704	& * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,1) &
705	& * tmask(ji,jj,1) * wesp_t(1)
706	zsbc_tc_b_adin(ji,jj) = zsbc_tc_b_tlout(ji,jj) &
707	& * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,1) &
708	& * tmask(ji,jj,1) * wesp_t(1)
709	zsbc_sc_b_adin(ji,jj) = zsbc_sc_b_tlout(ji,jj) &
710	& * e1t(ji,jj) * e2t(ji,jj) * fse3t(ji,jj,1) &
711	& * tmask(ji,jj,1) * wesp_t(1)
712	END DO
713	END DO
714
715	!--------------------------------------------------------------------
716	! Compute the scalar product: ( L dx )^T W dy
717	!--------------------------------------------------------------------
718
719	zsp1_1 = DOT_PRODUCT( zsa_tlout, zsa_adin )
720	zsp1_2 = DOT_PRODUCT( zta_tlout, zta_adin )
721	zsp1_3 = DOT_PRODUCT( zqns_tlout, zqns_adin )
722	zsp1_4 = DOT_PRODUCT( zqsr_tlout, zqsr_adin )
723	zsp1_5 = DOT_PRODUCT( zsbc_tc_tlout, zsbc_tc_adin )
724	zsp1_6 = DOT_PRODUCT( zsbc_sc_tlout, zsbc_sc_adin )
725	zsp1_7 = DOT_PRODUCT( zsbc_tc_b_tlout, zsbc_tc_b_adin )
726	zsp1_8 = DOT_PRODUCT( zsbc_sc_b_tlout, zsbc_sc_b_adin )
727	zsp1 = zsp1_1 + zsp1_2 + zsp1_3 + zsp1_4 + zsp1_5 + zsp1_6 + zsp1_7 + zsp1_8
728
729	!--------------------------------------------------------------------
730	! Call the adjoint routine: dx^* = L^T dy^*
731	!--------------------------------------------------------------------
732
733	tsa_ad(:,:,1,jp_sal) = zsa_adin(:,:)
734	tsa_ad(:,:,1,jp_tem) = zta_adin(:,:)
735	qns_ad(:,:) = zqns_adin(:,:)
736	qsr_ad(:,:) = zqsr_adin(:,:)
737	sbc_tsc_ad(:,:,jp_tem) = zsbc_tc_adin(:,:)
738	sbc_tsc_ad(:,:,jp_sal) = zsbc_sc_adin(:,:)
739	sbc_tsc_b_ad(:,:,jp_tem) = zsbc_tc_b_adin(:,:)
740	sbc_tsc_b_ad(:,:,jp_sal) = zsbc_sc_b_adin(:,:)
741
742
743	CALL tra_sbc_adj( nit000 )
744
745	zsn_adout (:,:) = tsn_ad(:,:,1,jp_sal)
746	zsa_adout (:,:) = tsa_ad(:,:,1,jp_sal)
747	zta_adout (:,:) = tsa_ad(:,:,1,jp_tem)
748	zqns_adout (:,:) = qns_ad(:,: )
749	zqsr_adout (:,:) = qsr_ad(:,: )
750	zemps_adout(:,:) = emps_ad(:,:)
751	zsbc_tc_adout(:,:) = sbc_tsc_ad(:,:,jp_tem)
752	zsbc_sc_adout(:,:) = sbc_tsc_ad(:,:,jp_sal)
753	zrnf_tc_adout(:,:) = rnf_tsc_ad(:,:,jp_tem)
754	zrnf_sc_adout(:,:) = rnf_tsc_ad(:,:,jp_sal)
755	zrnf_tc_b_adout(:,:) = rnf_tsc_b_ad(:,:,jp_tem)
756	zrnf_sc_b_adout(:,:) = rnf_tsc_b_ad(:,:,jp_sal)
757
758	!--------------------------------------------------------------------
759	! Compute the scalar product: dx^T L^T W dy
760	!--------------------------------------------------------------------
761
762	zsp2_1 = DOT_PRODUCT( zsn_tlin , zsn_adout )
763	zsp2_2 = DOT_PRODUCT( zsa_tlin , zsa_adout )
764	zsp2_3 = DOT_PRODUCT( zta_tlin , zta_adout )
765	zsp2_4 = DOT_PRODUCT( zqns_tlin , zqns_adout )
766	zsp2_5 = DOT_PRODUCT( zemps_tlin, zemps_adout )
767	zsp2_6 = DOT_PRODUCT( zqsr_tlin, zqsr_adout )
768	zsp2_7 = DOT_PRODUCT( zsbc_tc_tlin, zsbc_tc_adout )
769	zsp2_8 = DOT_PRODUCT( zsbc_sc_tlin, zsbc_sc_adout )
770	zsp2_9 = DOT_PRODUCT( zrnf_tc_tlin, zrnf_tc_adout )
771	zsp2_10 = DOT_PRODUCT( zrnf_sc_tlin, zrnf_sc_adout )
772	zsp2_11 = DOT_PRODUCT( zrnf_tc_b_tlin, zrnf_tc_b_adout )
773	zsp2_12 = DOT_PRODUCT( zrnf_sc_b_tlin, zrnf_sc_b_adout )
774
775	zsp2 = zsp2_1 + zsp2_2 + zsp2_3 + zsp2_4 + zsp2_5 + zsp2_6 + zsp2_7 + zsp2_8 + zsp2_9 + zsp2_10 + zsp2_11 + zsp2_12
776
777	! Compare the scalar products
778
779	! 14 char:'12345678901234'
780	cl_name = 'tra_sbc_adj '
781	CALL prntst_adj( cl_name, kumadt, zsp1, zsp2 )
782
783	DEALLOCATE( &
784	& zsn_tlin, &
785	& zsa_tlin, &
786	& zta_tlin, &
787	& zqns_tlin, &
788	& zqsr_tlin, &
789	& zemps_tlin, &
790	& zsbc_tc_tlin, &
791	& zsbc_sc_tlin, &
792	& zrnf_tc_tlin, &
793	& zrnf_sc_tlin, &
794	& zrnf_tc_b_tlin, &
795	& zrnf_sc_b_tlin, &
796	& zsa_tlout, &
797	& zta_tlout, &
798	& zqns_tlout, &
799	& zqsr_tlout, &
800	& zsbc_tc_tlout, &
801	& zsbc_sc_tlout, &
802	& zsbc_tc_b_tlout, &
803	& zsbc_sc_b_tlout, &
804	& zsn_adout, &
805	& zsa_adout, &
806	& zta_adout, &
807	& zqns_adout, &
808	& zqsr_adout, &
809	& zemps_adout, &
810	& zsbc_tc_adout, &
811	& zsbc_sc_adout, &
812	& zrnf_tc_adout, &
813	& zrnf_sc_adout, &
814	& zrnf_tc_b_adout, &
815	& zrnf_sc_b_adout, &
816	& zsa_adin, &
817	& zta_adin, &
818	& zqns_adin, &
819	& zqsr_adin, &
820	& zsbc_tc_adin, &
821	& zsbc_sc_adin, &
822	& zsbc_tc_b_adin, &
823	& zsbc_sc_b_adin, &
824	& zsn, &
825	& zsa, &
826	& zta, &
827	& zqns, &
828	& zemps &
829	& )
830	END SUBROUTINE tra_sbc_adj_tst
831	#endif
832	!!======================================================================
833	END MODULE trasbc_tam

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

Download in other formats: