Context Navigation

diaptr.F90 @ 10870

Last change on this file since 10870 was 9830, checked in by frrh, 6 years ago

Merge revisions 9607:9721 of/branches/UKMO/dev_r5518_GO6_diag_bitcomp
into GO6 package branch.

This change ensures most 2D and 3D diagnostics produced by NEMO and MEDUSA
are bit reproducible on different PE decompositions.

Command used:
svn merge -r 9607:9721 svn+ssh://forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/branches/UKMO/dev_r5518_GO6_diag_bitcomp

Met Office GMED ticket 389 refers.

This change applies a mask to all duplicate grid points
output on diagnistic grids for T, U and V points. i.e. it masks
any wrap columns and duplicated grid points across the N-fold.
Fields affected are all "standard" NEMO diagnostics (scalar and
diaptr diagnostics are not on "normal" grids).

It also introduces some corrections/initialisations to achieve
PE decomposition bit comparison.

Most 2D or 3D fields are now bit comparable on different PE decompositions.
Only diaptr diagnostics can not be guaranteed bit reproducible
(due to their method of computation).

This change does nothing to CICE output.

Model evolution is unaffected.

File size: 33.8 KB

Line
1	MODULE diaptr
2	!!======================================================================
3	!! * MODULE diaptr *
4	!! Ocean physics: Computes meridonal transports and zonal means
5	!!=====================================================================
6	!! History : 1.0 ! 2003-09 (C. Talandier, G. Madec) Original code
7	!! 2.0 ! 2006-01 (A. Biastoch) Allow sub-basins computation
8	!! 3.2 ! 2010-03 (O. Marti, S. Flavoni) Add fields
9	!! 3.3 ! 2010-10 (G. Madec) dynamical allocation
10	!! 3.6 ! 2014-12 (C. Ethe) use of IOM
11	!! 3.6 ! 2016-06 (T. Graham) Addition of diagnostics for CMIP6
12	!!----------------------------------------------------------------------
13
14	!!----------------------------------------------------------------------
15	!! dia_ptr : Poleward Transport Diagnostics module
16	!! dia_ptr_init : Initialization, namelist read
17	!! ptr_sjk : "zonal" mean computation of a field - tracer or flux array
18	!! ptr_sj : "zonal" and vertical sum computation of a "meridional" flux array
19	!! (Generic interface to ptr_sj_3d, ptr_sj_2d)
20	!!----------------------------------------------------------------------
21	USE oce ! ocean dynamics and active tracers
22	USE dom_oce ! ocean space and time domain
23	USE phycst ! physical constants
24	USE ldftra_oce
25	!
26	USE iom ! IOM library
27	USE in_out_manager ! I/O manager
28	USE lib_mpp ! MPP library
29	USE timing ! preformance summary
30
31	IMPLICIT NONE
32	PRIVATE
33
34	INTERFACE ptr_sj
35	MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d
36	END INTERFACE
37
38	PUBLIC ptr_sj ! call by tra_ldf & tra_adv routines
39	PUBLIC ptr_sjk !
40	PUBLIC dia_ptr_init ! call in step module
41	PUBLIC dia_ptr ! call in step module
42	PUBLIC dia_ptr_ohst_components ! called from tra_ldf/tra_adv routines
43
44	! !! namelist namptr
45	REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_adv, htr_ldf, htr_eiv, htr_vt !: Heat TRansports (adv, diff, Bolus.)
46	REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: str_adv, str_ldf, str_eiv, str_vs !: Salt TRansports (adv, diff, Bolus.)
47	REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_ove, str_ove !: heat Salt TRansports ( overturn.)
48	REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_btr, str_btr !: heat Salt TRansports ( barotropic )
49
50	LOGICAL, PUBLIC :: ln_diaptr ! Poleward transport flag (T) or not (F)
51	LOGICAL, PUBLIC :: ln_subbas ! Atlantic/Pacific/Indian basins calculation
52	INTEGER, PUBLIC :: nptr ! = 1 (l_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (l_subbas=T)
53
54	REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup
55	REAL(wp) :: rc_pwatt = 1.e-15_wp ! conversion from W to PW (further x rau0 x Cp)
56	REAL(wp) :: rc_ggram = 1.e-6_wp ! conversion from g to Pg
57
58	CHARACTER(len=3), ALLOCATABLE, SAVE, DIMENSION(:) :: clsubb
59	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks
60	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: btm30 ! mask out Southern Ocean (=0 south of 30°S)
61
62	REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:) :: p_fval1d
63	REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d
64
65
66	!! * Substitutions
67	# include "domzgr_substitute.h90"
68	# include "vectopt_loop_substitute.h90"
69	!!----------------------------------------------------------------------
70	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
71	!! $Id$
72	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
73	!!----------------------------------------------------------------------
74	CONTAINS
75
76	SUBROUTINE dia_ptr( pvtr )
77	!!----------------------------------------------------------------------
78	!! * ROUTINE dia_ptr *
79	!!----------------------------------------------------------------------
80	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport
81	!
82	INTEGER :: ji, jj, jk, jn ! dummy loop indices
83	REAL(wp) :: zsfc,zvfc ! local scalar
84	REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace
85	REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace
86	REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvn ! 3D workspace
87	REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask ! 3D workspace
88	REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace
89	REAL(wp), DIMENSION(jpj) :: vsum ! 1D workspace
90	REAL(wp), DIMENSION(jpj,jpts) :: tssum ! 1D workspace
91
92	!
93	!overturning calculation
94	REAL(wp), DIMENSION(jpj,jpk,nptr) :: sjk , r1_sjk ! i-mean i-k-surface and its inverse
95	REAL(wp), DIMENSION(jpj,jpk,nptr) :: v_msf, sn_jk , tn_jk ! i-mean T and S, j-Stream-Function
96
97
98	CHARACTER( len = 12 ) :: cl1
99	!!----------------------------------------------------------------------
100	!
101	IF( nn_timing == 1 ) CALL timing_start('dia_ptr')
102
103	!
104	z2d(:,:) = 0._wp
105	z3d(:,:,:) = 0._wp
106	IF( PRESENT( pvtr ) ) THEN
107	IF( iom_use("zomsfglo") ) THEN ! effective MSF
108	z3d(1,:,:) = ptr_sjk( pvtr(:,:,:) ) ! zonal cumulative effective transport
109	DO jk = jpkm1,1,-1 !Integrate from bottom up to get
110	z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk) ! effective j-Stream-Function (MSF)
111	END DO
112	DO ji = 1, jpi
113	z3d(ji,:,:) = z3d(1,:,:)
114	ENDDO
115	cl1 = TRIM('zomsf'//clsubb(1) )
116	CALL iom_put( cl1, z3d * rc_sv )
117	DO jn = 2, nptr ! by sub-basins
118	z3d(1,:,:) = ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn) )
119	DO jk = jpkm1,1,-1
120	z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk) ! effective j-Stream-Function (MSF)
121	END DO
122	DO ji = 1, jpi
123	z3d(ji,:,:) = z3d(1,:,:)
124	ENDDO
125	cl1 = TRIM('zomsf'//clsubb(jn) )
126	CALL iom_put( cl1, z3d * rc_sv )
127	END DO
128	ENDIF
129	IF( iom_use("sopstove") .OR. iom_use("sophtove") .OR. iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN
130	! define fields multiplied by scalar
131	zmask(:,:,:) = 0._wp
132	zts(:,:,:,:) = 0._wp
133	DO jk = 1, jpkm1
134	DO jj = 1, jpjm1
135	DO ji = 1, jpi
136	zvfc = e1v(ji,jj) * fse3v(ji,jj,jk)
137	zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc
138	zts(ji,jj,jk,jp_tem) = (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * 0.5 * zvfc !Tracers averaged onto V grid
139	zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc
140	ENDDO
141	ENDDO
142	ENDDO
143	ENDIF
144	IF( iom_use("sopstove") .OR. iom_use("sophtove") ) THEN
145	sjk(:,:,1) = ptr_sjk( zmask(:,:,:), btmsk(:,:,1) )
146	r1_sjk(:,:,1) = 0._wp
147	WHERE( sjk(:,:,1) /= 0._wp ) r1_sjk(:,:,1) = 1._wp / sjk(:,:,1)
148
149	! i-mean T and S, j-Stream-Function, global
150	tn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_tem) ) * r1_sjk(:,:,1)
151	sn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_sal) ) * r1_sjk(:,:,1)
152	v_msf(:,:,1) = ptr_sjk( pvtr(:,:,:) )
153
154	htr_ove(:,1) = SUM( v_msf(:,:,1)*tn_jk(:,:,1) ,2 )
155	str_ove(:,1) = SUM( v_msf(:,:,1)*sn_jk(:,:,1) ,2 )
156
157	z2d(1,:) = htr_ove(:,1) * rc_pwatt ! (conversion in PW)
158	DO ji = 1, jpi
159	z2d(ji,:) = z2d(1,:)
160	ENDDO
161	cl1 = 'sophtove'
162	CALL iom_put( TRIM(cl1), z2d )
163	z2d(1,:) = str_ove(:,1) * rc_ggram ! (conversion in Gg)
164	DO ji = 1, jpi
165	z2d(ji,:) = z2d(1,:)
166	ENDDO
167	cl1 = 'sopstove'
168	CALL iom_put( TRIM(cl1), z2d )
169	IF( ln_subbas ) THEN
170	DO jn = 2, nptr
171	sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
172	r1_sjk(:,:,jn) = 0._wp
173	WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn)
174
175	! i-mean T and S, j-Stream-Function, basin
176	tn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
177	sn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
178	v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn) )
179	htr_ove(:,jn) = SUM( v_msf(:,:,jn)*tn_jk(:,:,jn) ,2 )
180	str_ove(:,jn) = SUM( v_msf(:,:,jn)*sn_jk(:,:,jn) ,2 )
181
182	z2d(1,:) = htr_ove(:,jn) * rc_pwatt ! (conversion in PW)
183	DO ji = 1, jpi
184	z2d(ji,:) = z2d(1,:)
185	ENDDO
186	cl1 = TRIM('sophtove_'//clsubb(jn))
187	CALL iom_put( cl1, z2d )
188	z2d(1,:) = str_ove(:,jn) * rc_ggram ! (conversion in Gg)
189	DO ji = 1, jpi
190	z2d(ji,:) = z2d(1,:)
191	ENDDO
192	cl1 = TRIM('sopstove_'//clsubb(jn))
193	CALL iom_put( cl1, z2d )
194	END DO
195	ENDIF
196	ENDIF
197	IF( iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN
198	! Calculate barotropic heat and salt transport here
199	sjk(:,1,1) = ptr_sj( zmask(:,:,:), btmsk(:,:,1) )
200	r1_sjk(:,1,1) = 0._wp
201	WHERE( sjk(:,1,1) /= 0._wp ) r1_sjk(:,1,1) = 1._wp / sjk(:,1,1)
202
203	vsum = ptr_sj( pvtr(:,:,:), btmsk(:,:,1))
204	tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,1) )
205	tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,1) )
206	htr_btr(:,1) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,1)
207	str_btr(:,1) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,1)
208	z2d(1,:) = htr_btr(:,1) * rc_pwatt ! (conversion in PW)
209	DO ji = 2, jpi
210	z2d(ji,:) = z2d(1,:)
211	ENDDO
212	cl1 = 'sophtbtr'
213	CALL iom_put( TRIM(cl1), z2d )
214	z2d(1,:) = str_btr(:,1) * rc_ggram ! (conversion in Gg)
215	DO ji = 2, jpi
216	z2d(ji,:) = z2d(1,:)
217	ENDDO
218	cl1 = 'sopstbtr'
219	CALL iom_put( TRIM(cl1), z2d )
220	IF( ln_subbas ) THEN
221	DO jn = 2, nptr
222	sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) )
223	r1_sjk(:,1,jn) = 0._wp
224	WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn)
225	vsum = ptr_sj( pvtr(:,:,:), btmsk(:,:,jn))
226	tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) )
227	tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) )
228	htr_btr(:,jn) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,jn)
229	str_btr(:,jn) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,jn)
230	z2d(1,:) = htr_btr(:,jn) * rc_pwatt ! (conversion in PW)
231	DO ji = 1, jpi
232	z2d(ji,:) = z2d(1,:)
233	ENDDO
234	cl1 = TRIM('sophtbtr_'//clsubb(jn))
235	CALL iom_put( cl1, z2d )
236	z2d(1,:) = str_btr(:,jn) * rc_ggram ! (conversion in Gg)
237	DO ji = 1, jpi
238	z2d(ji,:) = z2d(1,:)
239	ENDDO
240	cl1 = TRIM('sopstbtr_'//clsubb(jn))
241	CALL iom_put( cl1, z2d )
242	ENDDO
243	ENDIF !ln_subbas
244	ENDIF !iom_use("sopstbtr....)
245	!
246	ELSE
247	!
248	IF( iom_use("zotemglo") ) THEN ! i-mean i-k-surface
249	zmask(:,:,:) = 0._wp
250	zts(:,:,:,:) = 0._wp
251	DO jk = 1, jpkm1
252	DO jj = 1, jpj
253	DO ji = 1, jpi
254	zsfc = e1t(ji,jj) * fse3t(ji,jj,jk)
255	zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc
256	zts(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * zsfc
257	zts(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * zsfc
258	ENDDO
259	ENDDO
260	ENDDO
261	DO jn = 1, nptr
262	zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
263	cl1 = TRIM('zosrf'//clsubb(jn) )
264	CALL iom_put( cl1, zmask )
265	!
266	z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) &
267	& / MAX( zmask(1,:,:), 10.e-15 )
268	DO ji = 1, jpi
269	z3d(ji,:,:) = z3d(1,:,:)
270	ENDDO
271	cl1 = TRIM('zotem'//clsubb(jn) )
272	CALL iom_put( cl1, z3d )
273	!
274	z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) &
275	& / MAX( zmask(1,:,:), 10.e-15 )
276	DO ji = 1, jpi
277	z3d(ji,:,:) = z3d(1,:,:)
278	ENDDO
279	cl1 = TRIM('zosal'//clsubb(jn) )
280	CALL iom_put( cl1, z3d )
281	END DO
282	ENDIF
283	!
284	! ! Advective and diffusive heat and salt transport
285	IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN
286	z2d(1,:) = htr_adv(:,1) * rc_pwatt ! (conversion in PW)
287	DO ji = 1, jpi
288	z2d(ji,:) = z2d(1,:)
289	ENDDO
290	cl1 = 'sophtadv'
291	CALL iom_put( TRIM(cl1), z2d )
292	z2d(1,:) = str_adv(:,1) * rc_ggram ! (conversion in Gg)
293	DO ji = 1, jpi
294	z2d(ji,:) = z2d(1,:)
295	ENDDO
296	cl1 = 'sopstadv'
297	CALL iom_put( TRIM(cl1), z2d )
298	IF( ln_subbas ) THEN
299	DO jn=2,nptr
300	z2d(1,:) = htr_adv(:,jn) * rc_pwatt ! (conversion in PW)
301	DO ji = 1, jpi
302	z2d(ji,:) = z2d(1,:)
303	ENDDO
304	cl1 = TRIM('sophtadv_'//clsubb(jn))
305	CALL iom_put( cl1, z2d )
306	z2d(1,:) = str_adv(:,jn) * rc_ggram ! (conversion in Gg)
307	DO ji = 1, jpi
308	z2d(ji,:) = z2d(1,:)
309	ENDDO
310	cl1 = TRIM('sopstadv_'//clsubb(jn))
311	CALL iom_put( cl1, z2d )
312	ENDDO
313	ENDIF
314	ENDIF
315	!
316	IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN
317	z2d(1,:) = htr_ldf(:,1) * rc_pwatt ! (conversion in PW)
318	DO ji = 1, jpi
319	z2d(ji,:) = z2d(1,:)
320	ENDDO
321	cl1 = 'sophtldf'
322	CALL iom_put( TRIM(cl1), z2d )
323	z2d(1,:) = str_ldf(:,1) * rc_ggram ! (conversion in Gg)
324	DO ji = 1, jpi
325	z2d(ji,:) = z2d(1,:)
326	ENDDO
327	cl1 = 'sopstldf'
328	CALL iom_put( TRIM(cl1), z2d )
329	IF( ln_subbas ) THEN
330	DO jn=2,nptr
331	z2d(1,:) = htr_ldf(:,jn) * rc_pwatt ! (conversion in PW)
332	DO ji = 1, jpi
333	z2d(ji,:) = z2d(1,:)
334	ENDDO
335	cl1 = TRIM('sophtldf_'//clsubb(jn))
336	CALL iom_put( cl1, z2d )
337	z2d(1,:) = str_ldf(:,jn) * rc_ggram ! (conversion in Gg)
338	DO ji = 1, jpi
339	z2d(ji,:) = z2d(1,:)
340	ENDDO
341	cl1 = TRIM('sopstldf_'//clsubb(jn))
342	CALL iom_put( cl1, z2d )
343	ENDDO
344	ENDIF
345	ENDIF
346
347	IF( iom_use("sopht_vt") .OR. iom_use("sopst_vs") ) THEN
348	z2d(1,:) = htr_vt(:,1) * rc_pwatt ! (conversion in PW)
349	DO ji = 1, jpi
350	z2d(ji,:) = z2d(1,:)
351	ENDDO
352	cl1 = 'sopht_vt'
353	CALL iom_put( TRIM(cl1), z2d )
354	z2d(1,:) = str_vs(:,1) * rc_ggram ! (conversion in Gg)
355	DO ji = 1, jpi
356	z2d(ji,:) = z2d(1,:)
357	ENDDO
358	cl1 = 'sopst_vs'
359	CALL iom_put( TRIM(cl1), z2d )
360	IF( ln_subbas ) THEN
361	DO jn=2,nptr
362	z2d(1,:) = htr_vt(:,jn) * rc_pwatt ! (conversion in PW)
363	DO ji = 1, jpi
364	z2d(ji,:) = z2d(1,:)
365	ENDDO
366	cl1 = TRIM('sopht_vt_'//clsubb(jn))
367	CALL iom_put( cl1, z2d )
368	z2d(1,:) = str_vs(:,jn) * rc_ggram ! (conversion in Gg)
369	DO ji = 1, jpi
370	z2d(ji,:) = z2d(1,:)
371	ENDDO
372	cl1 = TRIM('sopst_vs_'//clsubb(jn))
373	CALL iom_put( cl1, z2d )
374	ENDDO
375	ENDIF
376	ENDIF
377
378	#ifdef key_diaeiv
379	IF(lk_traldf_eiv) THEN
380	IF( iom_use("sophteiv") .OR. iom_use("sopsteiv") ) THEN
381	z2d(1,:) = htr_eiv(:,1) * rc_pwatt ! (conversion in PW)
382	DO ji = 1, jpi
383	z2d(ji,:) = z2d(1,:)
384	ENDDO
385	cl1 = 'sophteiv'
386	CALL iom_put( TRIM(cl1), z2d )
387	z2d(1,:) = str_eiv(:,1) * rc_ggram ! (conversion in Gg)
388	DO ji = 1, jpi
389	z2d(ji,:) = z2d(1,:)
390	ENDDO
391	cl1 = 'sopsteiv'
392	CALL iom_put( TRIM(cl1), z2d )
393	IF( ln_subbas ) THEN
394	DO jn=2,nptr
395	z2d(1,:) = htr_eiv(:,jn) * rc_pwatt ! (conversion in PW)
396	DO ji = 1, jpi
397	z2d(ji,:) = z2d(1,:)
398	ENDDO
399	cl1 = TRIM('sophteiv_'//clsubb(jn))
400	CALL iom_put( cl1, z2d )
401	z2d(1,:) = str_eiv(:,jn) * rc_ggram ! (conversion in Gg)
402	DO ji = 1, jpi
403	z2d(ji,:) = z2d(1,:)
404	ENDDO
405	cl1 = TRIM('sopsteiv_'//clsubb(jn))
406	CALL iom_put( cl1, z2d )
407	ENDDO
408	ENDIF
409	ENDIF
410	IF( iom_use("zomsfeivglo") ) THEN
411	DO jk=1,jpk
412	DO jj=1,jpj
413	DO ji=1,jpi
414	zvn(ji,jj,jk) = v_eiv(ji,jj,jk) * fse3v(ji,jj,jk) * e1v(ji,jj)
415	ENDDO
416	ENDDO
417	ENDDO
418	z3d(1,:,:) = ptr_sjk( zvn(:,:,:) ) ! zonal cumulative effective transport
419	DO jk = jpkm1,1,-1
420	z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk) ! effective j-Stream-Function (MSF)
421	END DO
422	DO ji = 1, jpi
423	z3d(ji,:,:) = z3d(1,:,:)
424	ENDDO
425	cl1 = TRIM('zomsfeiv'//clsubb(1) )
426	CALL iom_put( cl1, z3d * rc_sv )
427	IF( ln_subbas ) THEN
428	DO jn = 2, nptr ! by sub-basins
429	z3d(1,:,:) = ptr_sjk( zvn(:,:,:), btmsk(:,:,jn) )
430	DO jk = jpkm1,1,-1
431	z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk) ! effective j-Stream-Function (MSF)
432	END DO
433	DO ji = 1, jpi
434	z3d(ji,:,:) = z3d(1,:,:)
435	ENDDO
436	cl1 = TRIM('zomsfeiv'//clsubb(jn) )
437	CALL iom_put( cl1, z3d * rc_sv )
438	END DO
439	ENDIF
440	ENDIF
441	ENDIF
442	#endif
443	!
444	ENDIF
445	!
446	IF( nn_timing == 1 ) CALL timing_stop('dia_ptr')
447	!
448	END SUBROUTINE dia_ptr
449
450
451	SUBROUTINE dia_ptr_init
452	!!----------------------------------------------------------------------
453	!! * ROUTINE dia_ptr_init *
454	!!
455	!! ** Purpose : Initialization, namelist read
456	!!----------------------------------------------------------------------
457	INTEGER :: jn ! local integers
458	INTEGER :: inum, ierr ! local integers
459	INTEGER :: ios ! Local integer output status for namelist read
460	!!
461	NAMELIST/namptr/ ln_diaptr, ln_subbas
462	!!----------------------------------------------------------------------
463
464	REWIND( numnam_ref ) ! Namelist namptr in reference namelist : Poleward transport
465	READ ( numnam_ref, namptr, IOSTAT = ios, ERR = 901)
466	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist', lwp )
467
468	REWIND( numnam_cfg ) ! Namelist namptr in configuration namelist : Poleward transport
469	READ ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 )
470	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist', lwp )
471	IF(lwm) WRITE ( numond, namptr )
472
473	IF(lwp) THEN ! Control print
474	WRITE(numout,*)
475	WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
476	WRITE(numout,*) '~~~~~~~~~~~~'
477	WRITE(numout,*) ' Namelist namptr : set ptr parameters'
478	WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) ln_diaptr = ', ln_diaptr
479	WRITE(numout,*) ' Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins ln_subbas = ', ln_subbas
480	ENDIF
481
482	IF( ln_diaptr ) THEN
483	!
484	IF( ln_subbas ) THEN
485	nptr = 5 ! Global, Atlantic, Pacific, Indian, Indo-Pacific
486	ALLOCATE( clsubb(nptr) )
487	clsubb(1) = 'glo' ; clsubb(2) = 'atl' ; clsubb(3) = 'pac' ; clsubb(4) = 'ind' ; clsubb(5) = 'ipc'
488	ELSE
489	nptr = 1 ! Global only
490	ALLOCATE( clsubb(nptr) )
491	clsubb(1) = 'glo'
492	ENDIF
493
494	! ! allocate dia_ptr arrays
495	IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' )
496
497	rc_pwatt = rc_pwatt * rau0_rcp ! conversion from K.s-1 to PetaWatt
498
499	IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum
500
501	IF( ln_subbas ) THEN ! load sub-basin mask
502	CALL iom_open( 'subbasins', inum, ldstop = .TRUE. )
503	CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin
504	CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin
505	CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin
506	CALL iom_close( inum )
507	btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin
508	WHERE( gphit(:,:) < -30._wp) ; btm30(:,:) = 0._wp ! mask out Southern Ocean
509	ELSE WHERE ; btm30(:,:) = ssmask(:,:)
510	END WHERE
511	ENDIF
512
513	btmsk(:,:,1) = tmask_i(:,:) ! global ocean
514
515	DO jn = 1, nptr
516	btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only
517	END DO
518
519	! Initialise arrays to zero because diatpr is called before they are first calculated
520	! Note that this means diagnostics will not be exactly correct when model run is restarted.
521	htr_adv(:,:) = 0._wp ; str_adv(:,:) = 0._wp
522	htr_ldf(:,:) = 0._wp ; str_ldf(:,:) = 0._wp
523	htr_eiv(:,:) = 0._wp ; str_eiv(:,:) = 0._wp
524	htr_vt(:,:) = 0._wp ; str_vs(:,:) = 0._wp
525	htr_ove(:,:) = 0._wp ; str_ove(:,:) = 0._wp
526	htr_btr(:,:) = 0._wp ; str_btr(:,:) = 0._wp
527	!
528	ENDIF
529	!
530	END SUBROUTINE dia_ptr_init
531
532	SUBROUTINE dia_ptr_ohst_components( ktra, cptr, pva )
533	!!----------------------------------------------------------------------
534	!! * ROUTINE dia_ptr_ohst_components *
535	!!----------------------------------------------------------------------
536	!! Wrapper for heat and salt transport calculations to calculate them for each basin
537	!! Called from all advection and/or diffusion routines
538	!!----------------------------------------------------------------------
539	INTEGER , INTENT(in ) :: ktra ! tracer index
540	CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv'
541	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pva ! 3D input array of advection/diffusion
542	INTEGER :: jn !
543
544	IF( cptr == 'adv' ) THEN
545	IF( ktra == jp_tem ) htr_adv(:,1) = ptr_sj( pva(:,:,:) )
546	IF( ktra == jp_sal ) str_adv(:,1) = ptr_sj( pva(:,:,:) )
547	ENDIF
548	IF( cptr == 'ldf' ) THEN
549	IF( ktra == jp_tem ) htr_ldf(:,1) = ptr_sj( pva(:,:,:) )
550	IF( ktra == jp_sal ) str_ldf(:,1) = ptr_sj( pva(:,:,:) )
551	ENDIF
552	IF( cptr == 'eiv' ) THEN
553	IF( ktra == jp_tem ) htr_eiv(:,1) = ptr_sj( pva(:,:,:) )
554	IF( ktra == jp_sal ) str_eiv(:,1) = ptr_sj( pva(:,:,:) )
555	ENDIF
556	IF( cptr == 'vts' ) THEN
557	IF( ktra == jp_tem ) htr_vt(:,1) = ptr_sj( pva(:,:,:) )
558	IF( ktra == jp_sal ) str_vs(:,1) = ptr_sj( pva(:,:,:) )
559	ENDIF
560	!
561	IF( ln_subbas ) THEN
562	!
563	IF( cptr == 'adv' ) THEN
564	IF( ktra == jp_tem ) THEN
565	DO jn = 2, nptr
566	htr_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
567	END DO
568	ENDIF
569	IF( ktra == jp_sal ) THEN
570	DO jn = 2, nptr
571	str_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
572	END DO
573	ENDIF
574	ENDIF
575	IF( cptr == 'ldf' ) THEN
576	IF( ktra == jp_tem ) THEN
577	DO jn = 2, nptr
578	htr_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
579	END DO
580	ENDIF
581	IF( ktra == jp_sal ) THEN
582	DO jn = 2, nptr
583	str_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
584	END DO
585	ENDIF
586	ENDIF
587	IF( cptr == 'eiv' ) THEN
588	IF( ktra == jp_tem ) THEN
589	DO jn = 2, nptr
590	htr_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
591	END DO
592	ENDIF
593	IF( ktra == jp_sal ) THEN
594	DO jn = 2, nptr
595	str_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
596	END DO
597	ENDIF
598	ENDIF
599	IF( cptr == 'vts' ) THEN
600	IF( ktra == jp_tem ) THEN
601	DO jn = 2, nptr
602	htr_vt(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
603	END DO
604	ENDIF
605	IF( ktra == jp_sal ) THEN
606	DO jn = 2, nptr
607	str_vs(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
608	END DO
609	ENDIF
610	ENDIF
611	!
612	ENDIF
613	END SUBROUTINE dia_ptr_ohst_components
614
615
616	FUNCTION dia_ptr_alloc()
617	!!----------------------------------------------------------------------
618	!! * ROUTINE dia_ptr_alloc *
619	!!----------------------------------------------------------------------
620	INTEGER :: dia_ptr_alloc ! return value
621	INTEGER, DIMENSION(3) :: ierr
622	!!----------------------------------------------------------------------
623	ierr(:) = 0
624	!
625	ALLOCATE( btmsk(jpi,jpj,nptr) , &
626	& htr_adv(jpj,nptr) , str_adv(jpj,nptr) , &
627	& htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , &
628	& htr_vt(jpj,nptr) , str_vs(jpj,nptr) , &
629	& htr_ove(jpj,nptr) , str_ove(jpj,nptr) , &
630	& htr_btr(jpj,nptr) , str_btr(jpj,nptr) , &
631	& htr_ldf(jpj,nptr) , str_ldf(jpj,nptr) , STAT=ierr(1) )
632	!
633	ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2))
634	!
635	ALLOCATE( btm30(jpi,jpj), STAT=ierr(3) )
636
637	!
638	dia_ptr_alloc = MAXVAL( ierr )
639	IF(lk_mpp) CALL mpp_sum( dia_ptr_alloc )
640	!
641	END FUNCTION dia_ptr_alloc
642
643
644	FUNCTION ptr_sj_3d( pva, pmsk ) RESULT ( p_fval )
645	!!----------------------------------------------------------------------
646	!! * ROUTINE ptr_sj_3d *
647	!!
648	!! ** Purpose : i-k sum computation of a j-flux array
649	!!
650	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
651	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
652	!!
653	!! ** Action : - p_fval: i-k-mean poleward flux of pva
654	!!----------------------------------------------------------------------
655	REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point
656	REAL(wp), INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: pmsk ! Optional 2D basin mask
657	!
658	INTEGER :: ji, jj, jk ! dummy loop arguments
659	INTEGER :: ijpj ! ???
660	REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
661	!!--------------------------------------------------------------------
662	!
663	p_fval => p_fval1d
664
665	ijpj = jpj
666	p_fval(:) = 0._wp
667	IF( PRESENT( pmsk ) ) THEN
668	DO jk = 1, jpkm1
669	DO jj = 2, jpjm1
670	DO ji = fs_2, fs_jpim1 ! Vector opt.
671	p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) * pmsk(ji,jj)
672	END DO
673	END DO
674	END DO
675	ELSE
676	DO jk = 1, jpkm1
677	DO jj = 2, jpjm1
678	DO ji = fs_2, fs_jpim1 ! Vector opt.
679	p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj)
680	END DO
681	END DO
682	END DO
683	ENDIF
684	#if defined key_mpp_mpi
685	IF(lk_mpp) CALL mpp_sum( p_fval, ijpj, ncomm_znl)
686	#endif
687	!
688	END FUNCTION ptr_sj_3d
689
690
691	FUNCTION ptr_sj_2d( pva, pmsk ) RESULT ( p_fval )
692	!!----------------------------------------------------------------------
693	!! * ROUTINE ptr_sj_2d *
694	!!
695	!! ** Purpose : "zonal" and vertical sum computation of a i-flux array
696	!!
697	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
698	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
699	!!
700	!! ** Action : - p_fval: i-k-mean poleward flux of pva
701	!!----------------------------------------------------------------------
702	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point
703	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: pmsk ! Optional 2D basin mask
704	!
705	INTEGER :: ji,jj ! dummy loop arguments
706	INTEGER :: ijpj ! ???
707	REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
708	!!--------------------------------------------------------------------
709	!
710	p_fval => p_fval1d
711
712	ijpj = jpj
713	p_fval(:) = 0._wp
714	IF( PRESENT( pmsk ) ) THEN
715	DO jj = 2, jpjm1
716	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
717	p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) * pmsk(ji,jj)
718	END DO
719	END DO
720	ELSE
721	DO jj = 2, jpjm1
722	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
723	p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj)
724	END DO
725	END DO
726	ENDIF
727	#if defined key_mpp_mpi
728	CALL mpp_sum( p_fval, ijpj, ncomm_znl )
729	#endif
730	!
731	END FUNCTION ptr_sj_2d
732
733
734	FUNCTION ptr_sjk( pta, pmsk ) RESULT ( p_fval )
735	!!----------------------------------------------------------------------
736	!! * ROUTINE ptr_sjk *
737	!!
738	!! ** Purpose : i-sum computation of an array
739	!!
740	!! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i).
741	!!
742	!! ** Action : - p_fval: i-mean poleward flux of pva
743	!!----------------------------------------------------------------------
744	!!
745	IMPLICIT none
746	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! mask flux array at V-point
747	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: pmsk ! Optional 2D basin mask
748	!!
749	INTEGER :: ji, jj, jk ! dummy loop arguments
750	REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value
751	#if defined key_mpp_mpi
752	INTEGER, DIMENSION(1) :: ish
753	INTEGER, DIMENSION(2) :: ish2
754	INTEGER :: ijpjjpk
755	REAL(wp), DIMENSION(jpj*jpk) :: zwork ! mask flux array at V-point
756	#endif
757	!!--------------------------------------------------------------------
758	!
759	p_fval => p_fval2d
760
761	p_fval(:,:) = 0._wp
762	!
763	IF( PRESENT( pmsk ) ) THEN
764	DO jk = 1, jpkm1
765	DO jj = 2, jpjm1
766	!!gm here, use of tmask_i ==> no need of loop over nldi, nlei....
767	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
768	p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj)
769	END DO
770	END DO
771	END DO
772	ELSE
773	DO jk = 1, jpkm1
774	DO jj = 2, jpjm1
775	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
776	p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * tmask_i(ji,jj)
777	END DO
778	END DO
779	END DO
780	END IF
781	!
782	#if defined key_mpp_mpi
783	ijpjjpk = jpj*jpk
784	ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk
785	zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )
786	CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
787	p_fval(:,:) = RESHAPE( zwork, ish2 )
788	#endif
789	!
790
791	END FUNCTION ptr_sjk
792
793
794	!!======================================================================
795	END MODULE diaptr

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

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

Context Navigation

source: branches/UKMO/dev_r5518_GO6_fix_diaar5/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90 @ 10870

Download in other formats: