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.

diaptr.F90 in trunk/NEMO/OPA_SRC/DIA – NEMO

Context Navigation

source: trunk/NEMO/OPA_SRC/DIA/diaptr.F90 @ 1715

Last change on this file since 1715 was 1715, checked in by smasson, 15 years ago
move daymod public variables in dom_oce, see ticket:590
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 47.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 ! 2003-03 (O. Marti, S. Flavoni) Add fields
9	!!----------------------------------------------------------------------
10
11	!!----------------------------------------------------------------------
12	!! dia_ptr : Poleward Transport Diagnostics module
13	!! dia_ptr_init : Initialization, namelist read
14	!! dia_ptr_wri : Output of poleward fluxes
15	!! ptr_vjk : "zonal" sum computation of a "meridional" flux array
16	!! ptr_tjk : "zonal" mean computation of a tracer field
17	!! ptr_vj : "zonal" and vertical sum computation of a "meridional"
18	!! : flux array; Generic interface: ptr_vj_3d, ptr_vj_2d
19	!!----------------------------------------------------------------------
20	USE oce ! ocean dynamics and active tracers
21	USE dom_oce ! ocean space and time domain
22	USE phycst ! physical constants
23	USE ldftra_oce ! ocean active tracers: lateral physics
24	USE dianam
25	USE iom
26	USE ioipsl
27	USE in_out_manager
28	USE lib_mpp
29
30	IMPLICIT NONE
31	PRIVATE
32
33	INTERFACE ptr_vj
34	MODULE PROCEDURE ptr_vj_3d, ptr_vj_2d
35	END INTERFACE
36
37	PUBLIC dia_ptr_init ! call in opa module
38	PUBLIC dia_ptr ! call in step module
39	PUBLIC ptr_vj ! call by tra_ldf & tra_adv routines
40	PUBLIC ptr_vjk ! call by tra_ldf & tra_adv routines
41
42	! !! namelist namptr
43	LOGICAL , PUBLIC :: ln_diaptr = .FALSE. !: Poleward transport flag (T) or not (F)
44	LOGICAL , PUBLIC :: ln_subbas = .FALSE. !: Atlantic/Pacific/Indian basins calculation
45	LOGICAL , PUBLIC :: ln_diaznl = .FALSE. !: Add zonal means and meridional stream functions
46	LOGICAL , PUBLIC :: ln_ptrcomp = .FALSE. !: Add decomposition : overturning (and gyre, soon ...)
47	INTEGER , PUBLIC :: nf_ptr = 15 !: frequency of ptr computation
48	INTEGER , PUBLIC :: nf_ptr_wri = 15 !: frequency of ptr outputs
49
50	REAL(wp), PUBLIC, DIMENSION(jpi,jpj) :: abasin, pbasin, ibasin, dbasin, sbasin !: Sub basin masks
51
52	! !!! poleward heat and salt transport
53	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_adv , pst_adv !: advection
54	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_ldf , pst_ldf !: lateral diffusion
55	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_ove_glo, pst_ove_glo !: global overturning
56	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_ove_atl, pst_ove_atl !: Atlantic overturning
57	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_ove_pac, pst_ove_pac !: Pacific overturning
58	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_ove_ind, pst_ove_ind !: Indian overturning
59	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_ove_ipc, pst_ove_ipc !: Indo-Pacific overturning
60	REAL(wp), PUBLIC, DIMENSION(jpj) :: ht_glo, ht_atl, ht_ind, ht_pac, ht_ipc !: heat
61	REAL(wp), PUBLIC, DIMENSION(jpj) :: st_glo, st_atl, st_ind, st_pac, st_ipc !: salt
62
63	INTEGER :: niter
64	INTEGER :: nidom_ptr
65	INTEGER :: numptr !: logical unit for Poleward TRansports
66
67	REAL(wp), DIMENSION(jpj,jpk) :: tn_jk_glo , sn_jk_glo ! global i-mean temperature and salinity
68	REAL(wp), DIMENSION(jpj,jpk) :: tn_jk_atl , sn_jk_atl ! Atlantic - -
69	REAL(wp), DIMENSION(jpj,jpk) :: tn_jk_pac , sn_jk_pac ! Pacific - -
70	REAL(wp), DIMENSION(jpj,jpk) :: tn_jk_ind , sn_jk_ind ! Indian - -
71	REAL(wp), DIMENSION(jpj,jpk) :: tn_jk_ipc , sn_jk_ipc ! Indo-Pacific - -
72	REAL(wp), DIMENSION(jpj,jpk) :: v_msf_glo ! global "meridional" Stream-Function
73	REAL(wp), DIMENSION(jpj,jpk) :: v_msf_atl ! Atlantic - -
74	REAL(wp), DIMENSION(jpj,jpk) :: v_msf_pac ! Pacific - -
75	REAL(wp), DIMENSION(jpj,jpk) :: v_msf_ind ! Indian - -
76	REAL(wp), DIMENSION(jpj,jpk) :: v_msf_ipc ! Indo-Pacific - -
77	REAL(wp), DIMENSION(jpj,jpk) :: surf_jk_glo, surf_jk_r_glo ! surface of global i-section and its inverse
78	REAL(wp), DIMENSION(jpj,jpk) :: surf_jk_atl, surf_jk_r_atl ! surface of Atlantic - -
79	REAL(wp), DIMENSION(jpj,jpk) :: surf_jk_pac, surf_jk_r_pac ! surface of Pacific - -
80	REAL(wp), DIMENSION(jpj,jpk) :: surf_jk_ind, surf_jk_r_ind ! surface of Indian - -
81	REAL(wp), DIMENSION(jpj,jpk) :: surf_jk_ipc, surf_jk_r_ipc ! surface of Indo-Pacific - -
82	#if defined key_diaeiv
83	! !!! eddy induced velocity (bolus)
84	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_eiv_glo, pst_eiv_glo !: global poleward heat and salt bolus advection
85	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_eiv_atl, pst_eiv_atl !: Atlantic - -
86	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_eiv_pac, pst_eiv_pac !: Pacific - -
87	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_eiv_ind, pst_eiv_ind !: Indian - -
88	REAL(wp), PUBLIC, DIMENSION(jpj) :: pht_eiv_ipc, pst_eiv_ipc !: Indo-Pacific - -
89
90	REAL(wp), DIMENSION(jpj,jpk) :: v_msf_eiv_glo ! global "meridional" bolus Stream-Function
91	REAL(wp), DIMENSION(jpj,jpk) :: v_msf_eiv_atl ! Atlantic - -
92	REAL(wp), DIMENSION(jpj,jpk) :: v_msf_eiv_pac ! Pacific - -
93	REAL(wp), DIMENSION(jpj,jpk) :: v_msf_eiv_ind ! Indian - -
94	REAL(wp), DIMENSION(jpj,jpk) :: v_msf_eiv_ipc ! Indo-Pacific - -
95	#endif
96
97	!! * Substitutions
98	# include "domzgr_substitute.h90"
99	# include "vectopt_loop_substitute.h90"
100	!!----------------------------------------------------------------------
101	!! NEMO/OPA 3.2 , LOCEAN-IPSL (2009)
102	!! $Id$
103	!! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt)
104	!!----------------------------------------------------------------------
105
106	CONTAINS
107
108	FUNCTION ptr_vj_3d( pva ) RESULT ( p_fval )
109	!!----------------------------------------------------------------------
110	!! * ROUTINE ptr_vj_3d *
111	!!
112	!! ** Purpose : "zonal" and vertical sum computation of a "meridional"
113	!! flux array
114	!!
115	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
116	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
117	!!
118	!! ** Action : - p_fval: i-k-mean poleward flux of pva
119	!!----------------------------------------------------------------------
120	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point
121	!!
122	INTEGER :: ji, jj, jk ! dummy loop arguments
123	INTEGER :: ijpj ! ???
124	REAL(wp), DIMENSION(jpj) :: p_fval ! function value
125	!!--------------------------------------------------------------------
126	!
127	ijpj = jpj
128	p_fval(:) = 0.e0
129	DO jk = 1, jpkm1
130	DO jj = 2, jpjm1
131	DO ji = fs_2, fs_jpim1 ! Vector opt.
132	p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj)
133	END DO
134	END DO
135	END DO
136	!
137	#if defined key_mpp_mpi
138	CALL mpp_sum( p_fval, ijpj, ncomm_znl) !!bug I presume
139	#endif
140	!
141	END FUNCTION ptr_vj_3d
142
143
144	FUNCTION ptr_vj_2d( pva ) RESULT ( p_fval )
145	!!----------------------------------------------------------------------
146	!! * ROUTINE ptr_vj_2d *
147	!!
148	!! ** Purpose : "zonal" and vertical sum computation of a "meridional"
149	!! flux array
150	!!
151	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
152	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
153	!!
154	!! ** Action : - p_fval: i-k-mean poleward flux of pva
155	!!----------------------------------------------------------------------
156	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point
157	!!
158	INTEGER :: ji,jj ! dummy loop arguments
159	INTEGER :: ijpj ! ???
160	REAL(wp), DIMENSION(jpj) :: p_fval ! function value
161	!!--------------------------------------------------------------------
162	!
163	ijpj = jpj
164	p_fval(:) = 0.e0
165	DO jj = 2, jpjm1
166	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
167	p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj)
168	END DO
169	END DO
170	!
171	#if defined key_mpp_mpi
172	CALL mpp_sum( p_fval, ijpj, ncomm_znl ) !!bug I presume
173	#endif
174	!
175	END FUNCTION ptr_vj_2d
176
177
178	FUNCTION ptr_vjk( pva, bmask ) RESULT ( p_fval )
179	!!----------------------------------------------------------------------
180	!! * ROUTINE ptr_vjk *
181	!!
182	!! ** Purpose : "zonal" sum computation of a "meridional" flux array
183	!!
184	!! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i).
185	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
186	!!
187	!! ** Action : - p_fval: i-k-mean poleward flux of pva
188	!!----------------------------------------------------------------------
189	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point
190	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: bmask ! Optional 2D basin mask
191	!!
192	INTEGER :: ji, jj, jk ! dummy loop arguments
193	REAL(wp), DIMENSION(jpj,jpk) :: p_fval ! return function value
194	#if defined key_mpp_mpi
195	INTEGER, DIMENSION(1) :: ish
196	INTEGER, DIMENSION(2) :: ish2
197	REAL(wp), DIMENSION(jpj*jpk) :: zwork ! 1D workspace
198	#endif
199	!!--------------------------------------------------------------------
200	!
201	p_fval(:,:) = 0.e0
202	!
203	IF( PRESENT( bmask ) ) THEN
204	DO jk = 1, jpkm1
205	DO jj = 2, jpjm1
206	!!gm here, use of tmask_i ==> no need of loop over nldi, nlei....
207	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
208	p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) &
209	& * tmask_i(ji,jj) * bmask(ji,jj)
210	END DO
211	END DO
212	END DO
213	ELSE
214	DO jk = 1, jpkm1
215	DO jj = 2, jpjm1
216	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
217	p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) &
218	& * tmask_i(ji,jj)
219	END DO
220	END DO
221	END DO
222	END IF
223	!
224	#if defined key_mpp_mpi
225	ish(1) = jpj*jpk ; ish2(1) = jpj ; ish2(2) = jpk
226	zwork(:) = RESHAPE( p_fval, ish )
227	CALL mpp_sum( zwork, jpj*jpk, ncomm_znl )
228	p_fval(:,:) = RESHAPE( zwork, ish2 )
229	#endif
230	!
231	END FUNCTION ptr_vjk
232
233
234	FUNCTION ptr_tjk( pta, bmask ) RESULT ( p_fval )
235	!!----------------------------------------------------------------------
236	!! * ROUTINE ptr_tjk *
237	!!
238	!! ** Purpose : "zonal" mean computation of a tracer field
239	!!
240	!! ** Method : - i-sum of mj(pta) using tmask
241	!! multiplied by the inverse of the surface of the "zonal" ocean
242	!! section
243	!!
244	!! ** Action : - p_fval: i-k-mean poleward flux of pta
245	!!----------------------------------------------------------------------
246	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! tracer flux array at T-point
247	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: bmask ! Optional 2D basin mask
248	!!
249	INTEGER :: ji, jj, jk ! dummy loop arguments
250	REAL(wp),DIMENSION(jpj,jpk) :: p_fval ! return function value
251	#if defined key_mpp_mpi
252	INTEGER, DIMENSION(1) :: ish
253	INTEGER, DIMENSION(2) :: ish2
254	REAL(wp),DIMENSION(jpj*jpk) :: zwork ! 1D workspace
255	#endif
256	!!--------------------------------------------------------------------
257	!
258	p_fval(:,:) = 0.e0
259	IF (PRESENT (bmask)) THEN
260	DO jk = 1, jpkm1
261	DO jj = 2, jpjm1
262	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
263	p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) &
264	& * e1t(ji,jj) * fse3t(ji,jj,jk) &
265	& * tmask_i(ji,jj) &
266	& * bmask(ji,jj)
267	END DO
268	END DO
269	END DO
270	ELSE
271	DO jk = 1, jpkm1
272	DO jj = 2, jpjm1
273	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
274	p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) &
275	& * e1t(ji,jj) * fse3t(ji,jj,jk) &
276	& * tmask_i(ji,jj)
277	END DO
278	END DO
279	END DO
280	END IF
281	p_fval(:,:) = p_fval(:,:) * 0.5
282	#if defined key_mpp_mpi
283	ish(1) = jpj*jpk ; ish2(1) = jpj ; ish2(2) = jpk
284	zwork(:)= RESHAPE( p_fval, ish )
285	CALL mpp_sum( zwork, jpj*jpk, ncomm_znl )
286	p_fval(:,:)= RESHAPE(zwork,ish2)
287	#endif
288	!
289	END FUNCTION ptr_tjk
290
291
292	SUBROUTINE dia_ptr( kt )
293	!!----------------------------------------------------------------------
294	!! * ROUTINE dia_ptr *
295	!!----------------------------------------------------------------------
296	INTEGER, INTENT(in) :: kt ! ocean time step index
297	!!
298	INTEGER :: jk, jj, ji ! dummy loop
299	REAL(wp) :: zsverdrup ! conversion from m3/s to Sverdrup
300	REAL(wp) :: zpwatt ! conversion from W to PW
301	REAL(wp) :: zggram ! conversion from g to Pg
302	REAL(wp), DIMENSION(jpi,jpj,jpk) :: vt, vs ! 3D workspace
303	!!----------------------------------------------------------------------
304
305	IF( kt == nit000 .OR. MOD( kt, nf_ptr ) == 0 ) THEN
306
307	IF ( MOD( kt, nf_ptr ) == 0 ) THEN
308
309	zsverdrup = 1.e-6
310	zpwatt = 1.e-15
311	zggram = 1.e-6
312
313	IF ( ln_diaznl ) THEN
314	! "zonal" mean temperature and salinity at V-points
315	tn_jk_glo(:,:) = ptr_tjk( tn(:,:,:) ) * surf_jk_r_glo(:,:)
316	sn_jk_glo(:,:) = ptr_tjk( sn(:,:,:) ) * surf_jk_r_glo(:,:)
317
318	IF (ln_subbas) THEN
319	tn_jk_atl(:,:) = ptr_tjk( tn(:,:,:), abasin(:,:) ) * surf_jk_r_atl(:,:)
320	sn_jk_atl(:,:) = ptr_tjk( sn(:,:,:), abasin(:,:) ) * surf_jk_r_atl(:,:)
321	tn_jk_pac(:,:) = ptr_tjk( tn(:,:,:), pbasin(:,:) ) * surf_jk_r_pac(:,:)
322	sn_jk_pac(:,:) = ptr_tjk( sn(:,:,:), pbasin(:,:) ) * surf_jk_r_pac(:,:)
323	tn_jk_ind(:,:) = ptr_tjk( tn(:,:,:), ibasin(:,:) ) * surf_jk_r_ind(:,:)
324	sn_jk_ind(:,:) = ptr_tjk( sn(:,:,:), ibasin(:,:) ) * surf_jk_r_ind(:,:)
325	tn_jk_ipc(:,:) = ptr_tjk( tn(:,:,:), dbasin(:,:) ) * surf_jk_r_ipc(:,:)
326	sn_jk_ipc(:,:) = ptr_tjk( sn(:,:,:), dbasin(:,:) ) * surf_jk_r_ipc(:,:)
327	ENDIF
328	ENDIF
329
330	!--------------------------------------------------------
331	! overturning calculation:
332
333	! horizontal integral and vertical dz
334
335	#if defined key_diaeiv
336	v_msf_glo(:,:) = ptr_vjk( vn(:,:,:)+v_eiv(:,:,:) )
337	IF( ln_subbas .AND. ln_diaznl ) THEN
338	v_msf_atl(:,:) = ptr_vjk( vn(:,:,:)+v_eiv(:,:,:), abasin(:,:)*sbasin(:,:) )
339	v_msf_pac(:,:) = ptr_vjk( vn(:,:,:)+v_eiv(:,:,:), pbasin(:,:)*sbasin(:,:) )
340	v_msf_ind(:,:) = ptr_vjk( vn(:,:,:)+v_eiv(:,:,:), ibasin(:,:)*sbasin(:,:) )
341	v_msf_ipc(:,:) = ptr_vjk( vn(:,:,:)+v_eiv(:,:,:), dbasin(:,:)*sbasin(:,:) )
342	ENDIF
343	#else
344	v_msf_glo(:,:) = ptr_vjk( vn(:,:,:) )
345	IF( ln_subbas .AND. ln_diaznl ) THEN
346	v_msf_atl(:,:) = ptr_vjk( vn(:,:,:), abasin(:,:)*sbasin(:,:) )
347	v_msf_pac(:,:) = ptr_vjk( vn(:,:,:), pbasin(:,:)*sbasin(:,:) )
348	v_msf_ind(:,:) = ptr_vjk( vn(:,:,:), ibasin(:,:)*sbasin(:,:) )
349	v_msf_ipc(:,:) = ptr_vjk( vn(:,:,:), dbasin(:,:)*sbasin(:,:) )
350	ENDIF
351	#endif
352
353	#if defined key_diaeiv
354	v_msf_eiv_glo(:,:) = ptr_vjk( v_eiv(:,:,:) )
355	IF (ln_subbas ) THEN
356	v_msf_eiv_atl(:,:) = ptr_vjk( v_eiv(:,:,:), abasin(:,:)*sbasin(:,:) )
357	v_msf_eiv_pac(:,:) = ptr_vjk( v_eiv(:,:,:), pbasin(:,:)*sbasin(:,:) )
358	v_msf_eiv_ind(:,:) = ptr_vjk( v_eiv(:,:,:), ibasin(:,:)*sbasin(:,:) )
359	v_msf_eiv_ipc(:,:) = ptr_vjk( v_eiv(:,:,:), dbasin(:,:)*sbasin(:,:) )
360	END IF
361	#endif
362
363	! "Meridional" Stream-Function
364	DO jk = 2,jpk
365	v_msf_glo(:,jk) = v_msf_glo(:,jk-1) + v_msf_glo(:,jk)
366	END DO
367	v_msf_glo(:,:) = v_msf_glo(:,:) * zsverdrup
368	#if defined key_diaeiv
369	! Bolus "Meridional" Stream-Function
370	DO jk = 2,jpk
371	v_msf_eiv_glo(:,jk) = v_msf_eiv_glo(:,jk-1) + v_msf_eiv_glo(:,jk)
372	END DO
373	v_msf_eiv_glo(:,:) = v_msf_eiv_glo(:,:) * zsverdrup
374	IF ( ln_subbas ) THEN
375	DO jk = 2,jpk
376	v_msf_eiv_atl(:,jk) = v_msf_eiv_atl(:,jk-1) + v_msf_eiv_atl(:,jk)
377	v_msf_eiv_pac(:,jk) = v_msf_eiv_pac(:,jk-1) + v_msf_eiv_pac(:,jk)
378	v_msf_eiv_ind(:,jk) = v_msf_eiv_ind(:,jk-1) + v_msf_eiv_ind(:,jk)
379	v_msf_eiv_ipc(:,jk) = v_msf_eiv_ipc(:,jk-1) + v_msf_eiv_ipc(:,jk)
380	END DO
381	ENDIF
382	#endif
383	!
384	IF( ln_subbas .AND. ln_diaznl ) THEN
385	DO jk = 2,jpk
386	v_msf_atl(:,jk) = v_msf_atl(:,jk-1) + v_msf_atl(:,jk)
387	v_msf_pac(:,jk) = v_msf_pac(:,jk-1) + v_msf_pac(:,jk)
388	v_msf_ind(:,jk) = v_msf_ind(:,jk-1) + v_msf_ind(:,jk)
389	v_msf_ipc(:,jk) = v_msf_ipc(:,jk-1) + v_msf_ipc(:,jk)
390	END DO
391	v_msf_atl(:,:) = v_msf_atl(:,:) * zsverdrup
392	v_msf_pac(:,:) = v_msf_pac(:,:) * zsverdrup
393	v_msf_ind(:,:) = v_msf_ind(:,:) * zsverdrup
394	v_msf_ipc(:,:) = v_msf_ipc(:,:) * zsverdrup
395	ENDIF
396
397	! Transports
398	! T times V on T points (include bolus velocities)
399	#if defined key_diaeiv
400	DO jj = 1, jpj
401	DO ji = 1, jpi
402	vt(ji,jj,:) = tn(ji,jj,:) * ( vn(ji,jj,:) + vn(ji,jj-1,:) + u_eiv(ji,jj,:) + u_eiv(ji,jj-1,:) )*0.5
403	vs(ji,jj,:) = sn(ji,jj,:) * ( vn(ji,jj,:) + vn(ji,jj-1,:) + v_eiv(ji,jj,:) + v_eiv(ji,jj-1,:) )*0.5
404	END DO
405	END DO
406	#else
407	DO jj = 1, jpj
408	DO ji = 1, jpi
409	vt(ji,jj,:) = tn(ji,jj,:) * ( vn(ji,jj,:) + vn(ji,jj-1,:) )*0.5
410	vs(ji,jj,:) = sn(ji,jj,:) * ( vn(ji,jj,:) + vn(ji,jj-1,:) )*0.5
411	END DO
412	END DO
413	#endif
414
415	ht_glo(:) = SUM( ptr_vjk( vt(:,:,:)), 2 )
416	st_glo(:) = SUM( ptr_vjk( vs(:,:,:)), 2 )
417
418	IF ( ln_subbas ) THEN
419	ht_atl(:) = SUM( ptr_vjk( vt (:,:,:), abasin(:,:)*sbasin(:,:)), 2 )
420	ht_pac(:) = SUM( ptr_vjk( vt (:,:,:), pbasin(:,:)*sbasin(:,:)), 2 )
421	ht_ind(:) = SUM( ptr_vjk( vt (:,:,:), ibasin(:,:)*sbasin(:,:)), 2 )
422	ht_ipc(:) = SUM( ptr_vjk( vt (:,:,:), dbasin(:,:)*sbasin(:,:)), 2 )
423	st_atl(:) = SUM( ptr_vjk( vs (:,:,:), abasin(:,:)*sbasin(:,:)), 2 )
424	st_pac(:) = SUM( ptr_vjk( vs (:,:,:), pbasin(:,:)*sbasin(:,:)), 2 )
425	st_ind(:) = SUM( ptr_vjk( vs (:,:,:), ibasin(:,:)*sbasin(:,:)), 2 )
426	st_ipc(:) = SUM( ptr_vjk( vs (:,:,:), dbasin(:,:)*sbasin(:,:)), 2 )
427	ENDIF
428
429	! poleward tracer transports:
430	! overturning components:
431	IF ( ln_ptrcomp ) THEN
432	pht_ove_glo(:) = SUM( v_msf_glo(:,:) * tn_jk_glo(:,:), 2 ) ! SUM over jk
433	pst_ove_glo(:) = SUM( v_msf_glo(:,:) * sn_jk_glo(:,:), 2 )
434	IF ( ln_subbas ) THEN
435	pht_ove_atl(:) = SUM( v_msf_atl(:,:) * tn_jk_atl(:,:), 2 ) ! SUM over jk
436	pst_ove_atl(:) = SUM( v_msf_atl(:,:) * sn_jk_atl(:,:), 2 )
437	pht_ove_pac(:) = SUM( v_msf_pac(:,:) * tn_jk_pac(:,:), 2 ) ! SUM over jk
438	pst_ove_pac(:) = SUM( v_msf_pac(:,:) * sn_jk_pac(:,:), 2 )
439	pht_ove_ind(:) = SUM( v_msf_ind(:,:) * tn_jk_ind(:,:), 2 ) ! SUM over jk
440	pst_ove_ind(:) = SUM( v_msf_ind(:,:) * sn_jk_ind(:,:), 2 )
441	pht_ove_ipc(:) = SUM( v_msf_ipc(:,:) * tn_jk_ipc(:,:), 2 ) ! SUM over jk
442	pst_ove_ipc(:) = SUM( v_msf_ipc(:,:) * sn_jk_ipc(:,:), 2 )
443	END IF
444	END IF
445
446	! Bolus component
447	#if defined key_diaeiv
448	pht_eiv_glo(:) = SUM( v_msf_eiv_glo(:,:) * tn_jk_glo(:,:), 2 ) ! SUM over jk
449	pst_eiv_glo(:) = SUM( v_msf_eiv_glo(:,:) * sn_jk_glo(:,:), 2 ) ! SUM over jk
450	IF ( ln_subbas ) THEN
451	pht_eiv_atl(:) = SUM( v_msf_eiv_glo(:,:) * tn_jk_atl(:,:), 2 ) ! SUM over jk
452	pst_eiv_atl(:) = SUM( v_msf_eiv_glo(:,:) * sn_jk_atl(:,:), 2 ) ! SUM over jk
453	pht_eiv_pac(:) = SUM( v_msf_eiv_pac(:,:) * tn_jk_pac(:,:), 2 ) ! SUM over jk
454	pst_eiv_pac(:) = SUM( v_msf_eiv_pac(:,:) * sn_jk_pac(:,:), 2 ) ! SUM over jk
455	pht_eiv_ind(:) = SUM( v_msf_eiv_ind(:,:) * tn_jk_ind(:,:), 2 ) ! SUM over jk
456	pst_eiv_ind(:) = SUM( v_msf_eiv_ind(:,:) * sn_jk_ind(:,:), 2 ) ! SUM over jk
457	pht_eiv_ipc(:) = SUM( v_msf_eiv_ipc(:,:) * tn_jk_ipc(:,:), 2 ) ! SUM over jk
458	pst_eiv_ipc(:) = SUM( v_msf_eiv_ipc(:,:) * sn_jk_ipc(:,:), 2 ) ! SUM over jk
459	ENDIF
460	#endif
461
462	! conversion in PW and G g
463	zpwatt = zpwatt * rau0 * rcp
464	pht_adv(:) = pht_adv(:) * zpwatt
465	pht_ldf(:) = pht_ldf(:) * zpwatt
466	pst_adv(:) = pst_adv(:) * zggram
467	pst_ldf(:) = pst_ldf(:) * zggram
468	IF ( ln_ptrcomp ) THEN
469	pht_ove_glo(:) = pht_ove_glo(:) * zpwatt
470	pst_ove_glo(:) = pst_ove_glo(:) * zggram
471	END IF
472	#if defined key_diaeiv
473	pht_eiv_glo(:) = pht_eiv_glo(:) * zpwatt
474	pst_eiv_glo(:) = pst_eiv_glo(:) * zggram
475	#endif
476	IF( ln_subbas ) THEN
477	ht_atl(:) = ht_atl(:) * zpwatt
478	ht_pac(:) = ht_pac(:) * zpwatt
479	ht_ind(:) = ht_ind(:) * zpwatt
480	ht_ipc(:) = ht_ipc(:) * zpwatt
481	st_atl(:) = st_atl(:) * zggram
482	st_pac(:) = st_pac(:) * zggram
483	st_ind(:) = st_ind(:) * zggram
484	st_ipc(:) = st_ipc(:) * zggram
485	ENDIF
486	ENDIF
487	!
488	CALL dia_ptr_wri( kt ) ! outputs
489	!
490	ENDIF
491	!
492	IF( kt == nitend ) CALL histclo( numptr ) ! Close the file
493	!
494	END SUBROUTINE dia_ptr
495
496
497	SUBROUTINE dia_ptr_init
498	!!----------------------------------------------------------------------
499	!! * ROUTINE dia_ptr_init *
500	!!
501	!! ** Purpose : Initialization, namelist read
502	!!----------------------------------------------------------------------
503	INTEGER :: inum ! temporary logical unit
504	#if defined key_mpp_mpi
505	INTEGER, DIMENSION(1) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid
506	#endif
507	!!
508	NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, nf_ptr, nf_ptr_wri
509	!!----------------------------------------------------------------------
510
511	REWIND ( numnam ) ! Read Namelist namptr : poleward transport parameters
512	READ ( numnam, namptr )
513
514	IF(lwp) THEN ! Control print
515	WRITE(numout,*)
516	WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
517	WRITE(numout,*) '~~~~~~~~~~~~'
518	WRITE(numout,*) ' Namelist namptr : set ptr parameters'
519	WRITE(numout,*) ' Switch for ptr diagnostic (T) or not (F) ln_diaptr = ', ln_diaptr
520	WRITE(numout,*) ' Atl/Pac/Ind basins computation ln_subbas = ', ln_subbas
521	WRITE(numout,*) ' Frequency of computation nf_ptr = ', nf_ptr
522	WRITE(numout,*) ' Frequency of outputs nf_ptr_wri = ', nf_ptr_wri
523	ENDIF
524
525	IF( .NOT. ln_diaptr ) RETURN
526
527	IF( lk_mpp ) CALL mpp_ini_znl ! Define MPI communicator for zonal sum
528
529	IF( ln_subbas ) THEN ! load sub-basin mask
530	CALL iom_open( 'subbasins', inum )
531	CALL iom_get( inum, jpdom_data, 'atlmsk', abasin ) ! Atlantic basin
532	CALL iom_get( inum, jpdom_data, 'pacmsk', pbasin ) ! Pacific basin
533	CALL iom_get( inum, jpdom_data, 'indmsk', ibasin ) ! Indian basin
534	CALL iom_close( inum )
535	dbasin(:,:) = MAX ( pbasin(:,:), ibasin(:,:) )
536	sbasin(:,:) = tmask (:,:,1)
537	WHERE ( gphit (:,:) < -30.e0) sbasin(:,:) = 0.e0
538	ENDIF
539
540	!!gm CAUTION : this is only valid in fixed volume case !
541
542	! inverse of the ocean "zonal" v-point section
543	surf_jk_glo(:,:) = ptr_tjk( tmask(:,:,:) )
544	surf_jk_r_glo(:,:) = 0.e0
545	WHERE( surf_jk_glo(:,:) /= 0.e0 ) surf_jk_r_glo(:,:) = 1.e0 / surf_jk_glo(:,:)
546
547	IF (ln_subbas) THEN
548	surf_jk_atl(:,:) = ptr_tjk( tmask (:,:,:), abasin(:,:) )
549	surf_jk_r_atl(:,:) = 0.e0
550	WHERE( surf_jk_atl(:,:) /= 0.e0 ) surf_jk_r_atl(:,:) = 1.e0 / surf_jk_atl(:,:)
551	!
552	surf_jk_pac(:,:) = ptr_tjk( tmask (:,:,:), pbasin(:,:) )
553	surf_jk_r_pac(:,:) = 0.e0
554	WHERE( surf_jk_pac(:,:) /= 0.e0 ) surf_jk_r_pac(:,:) = 1.e0 / surf_jk_pac(:,:)
555	!
556	surf_jk_ind(:,:) = ptr_tjk( tmask (:,:,:), ibasin(:,:) )
557	surf_jk_r_ind(:,:) = 0.e0
558	WHERE( surf_jk_ind(:,:) /= 0.e0 ) surf_jk_r_ind(:,:) = 1.e0 / surf_jk_ind(:,:)
559	!
560	surf_jk_ipc(:,:) = ptr_tjk( tmask (:,:,:), dbasin(:,:) )
561	surf_jk_r_ipc(:,:) = 0.e0
562	WHERE( surf_jk_ipc(:,:) /= 0.e0 ) surf_jk_r_ipc(:,:) = 1.e0 / surf_jk_ipc(:,:)
563	END IF
564
565
566	!!----------------------------------------------------------------------
567
568	#if defined key_mpp_mpi
569	iglo (1) = jpjglo
570	iloc (1) = nlcj
571	iabsf(1) = njmppt(narea)
572	iabsl(:) = iabsf(:) + iloc(:) - 1
573	ihals(1) = nldj - 1
574	ihale(1) = nlcj - nlej
575	idid (1) = 2
576
577	!-$$ IF(lwp) THEN
578	!-$$ WRITE(numout,*)
579	!-$$ WRITE(numout,*) 'dia_ptr_init : iloc = ', iloc
580	!-$$ WRITE(numout,*) '~~~~~~~~~~~~ iabsf = ', iabsf
581	!-$$ WRITE(numout,*) ' ihals = ', ihals
582	!-$$ WRITE(numout,*) ' ihale = ', ihale
583	!-$$ ENDIF
584
585	CALL flio_dom_set ( jpnj, nproc/jpni, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom_ptr)
586	#else
587	nidom_ptr = FLIO_DOM_NONE
588	#endif
589	!
590	END SUBROUTINE dia_ptr_init
591
592
593	SUBROUTINE dia_ptr_wri( kt )
594	!!---------------------------------------------------------------------
595	!! * ROUTINE dia_ptr_wri *
596	!!
597	!! ** Purpose : output of poleward fluxes
598	!!
599	!! ** Method : NetCDF file
600	!!----------------------------------------------------------------------
601	INTEGER, INTENT(in) :: kt ! ocean time-step index
602	!!
603	INTEGER, SAVE :: nhoridz, ndepidzt, ndepidzw
604	INTEGER, SAVE :: ndim , ndim_atl , ndim_pac , ndim_ind , ndim_ipc
605	INTEGER, SAVE :: ndim_atl_30 , ndim_pac_30 , ndim_ind_30 , ndim_ipc_30
606	INTEGER, SAVE :: ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30
607	INTEGER, SAVE, DIMENSION (jpj*jpk) :: ndex , ndex_atl , ndex_pac , ndex_ind , ndex_ipc
608	INTEGER, SAVE, DIMENSION (jpj*jpk) :: ndex_atl_30 , ndex_pac_30 , ndex_ind_30 , ndex_ipc_30
609	INTEGER, SAVE, DIMENSION (jpj) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30
610
611	CHARACTER (len=40) :: clhstnam, clop, clop_once, cl_comment ! temporary names
612	INTEGER :: iline, it, itmod, ji, jj, jk !
613	#if defined key_iomput
614	INTEGER :: inum ! temporary logical unit
615	#endif
616	REAL(wp) :: zsto, zout, zdt, zjulian ! temporary scalars
617	REAL(wp), DIMENSION(jpj) :: zphi, zfoo
618	REAL(wp), DIMENSION(jpj,jpk) :: z_1
619	!!----------------------------------------------------------------------
620
621	! define time axis
622	it = kt / nf_ptr
623	itmod = kt - nit000 + 1
624
625	!-$$ IF(lwp) THEN
626	!-$$ WRITE(numout,*)
627	!-$$ WRITE(numout,*) 'dia_ptr_wri : kt = ', kt, 'it = ', it, ' itmod = ', itmod, ' niter = ', niter
628	!-$$ WRITE(numout,*) '~~~~~~~~~~~~'
629	!-$$ ENDIF
630
631	! Initialization
632	! --------------
633	IF( kt == nit000 ) THEN
634
635	niter = (nit000 - 1) / nf_ptr
636
637	!-$$ IF(lwp) THEN
638	!-$$ WRITE(numout,*)
639	!-$$ WRITE(numout,*) 'dia_ptr_wri : poleward transport and msf writing: initialization , niter = ', niter
640	!-$$ WRITE(numout,*) '~~~~~~~~~~~~'
641	!-$$ ENDIF
642
643	zdt = rdt
644	IF( nacc == 1 ) zdt = rdtmin
645
646	! Reference latitude
647	! ------------------
648	! ! =======================
649	IF( cp_cfg == "orca" ) THEN ! ORCA configurations
650	! ! =======================
651
652	IF( jp_cfg == 05 ) iline = 192 ! i-line that passes near the North Pole
653	IF( jp_cfg == 025 ) iline = 384 ! i-line that passes near the North Pole
654	IF( jp_cfg == 1 ) iline = 96 ! i-line that passes near the North Pole
655	IF( jp_cfg == 2 ) iline = 48 ! i-line that passes near the North Pole
656	IF( jp_cfg == 4 ) iline = 24 ! i-line that passes near the North Pole
657	zphi(:) = 0.e0
658	DO ji = mi0(iline), mi1(iline)
659	zphi(:) = gphiv(ji,:) ! if iline is in the local domain
660	! Correct highest latitude for some configurations - will work if domain is parallelized in J ?
661	IF( jp_cfg == 05 ) THEN
662	DO jj = mj0(jpjdta), mj1(jpjdta)
663	zphi( jj ) = zphi(mj0(jpjdta-1)) + (zphi(mj0(jpjdta-1))-zphi(mj0(jpjdta-2)))/2.
664	zphi( jj ) = MIN( zphi(jj), 90.)
665	END DO
666	END IF
667	IF( jp_cfg == 1 .OR. jp_cfg == 2 .OR. jp_cfg == 4 ) THEN
668	DO jj = mj0(jpjdta-1), mj1(jpjdta-1)
669	zphi( jj ) = 88.5e0
670	END DO
671	DO jj = mj0(jpjdta ), mj1(jpjdta )
672	zphi( jj ) = 89.5e0
673	END DO
674	END IF
675	END DO
676	! provide the correct zphi to all local domains
677	#if defined key_mpp_mpi
678	CALL mpp_sum( zphi, jpj, ncomm_znl )
679	#endif
680
681	! ! =======================
682	ELSE ! OTHER configurations
683	! ! =======================
684	zphi(:) = gphiv(1,:) ! assume lat/lon coordinate, select the first i-line
685	!
686	ENDIF
687	!
688	! Work only on westmost processor (will not work if mppini2 is used)
689	#if defined key_mpp_mpi
690	IF ( l_znl_root ) THEN
691	#endif
692	!
693	! OPEN netcdf file
694	! ----------------
695	! Define frequency of output and means
696	zsto = nf_ptr * zdt
697	IF( ln_mskland ) THEN ! put 1.e+20 on land (very expensive!!)
698	clop = "ave(only(x))"
699	clop_once = "once(only(x))"
700	ELSE ! no use of the mask value (require less cpu time)
701	clop = "ave(x)"
702	clop_once = "once"
703	ENDIF
704
705	zout = nf_ptr_wri * zdt
706	zfoo(:) = 0.e0
707
708	! Compute julian date from starting date of the run
709
710	CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian )
711	zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment
712
713	#if defined key_iomput
714	! Requested by IPSL people, use by their postpro...
715	IF(lwp) THEN
716	CALL dia_nam( clhstnam, nf_ptr_wri,' ' )
717	CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
718	WRITE(inum,*) clhstnam
719	CLOSE(inum)
720	ENDIF
721	#endif
722
723	CALL dia_nam( clhstnam, nf_ptr_wri, 'diaptr' )
724	IF(lwp)WRITE( numout,*)" Name of diaptr NETCDF file : ", clhstnam
725
726	! Horizontal grid : zphi()
727	CALL histbeg(clhstnam, 1, zfoo, jpj, zphi, &
728	1, 1, 1, jpj, niter, zjulian, zdt*nf_ptr, nhoridz, numptr, domain_id=nidom_ptr)
729	! Vertical grids : gdept_0, gdepw_0
730	CALL histvert( numptr, "deptht", "Vertical T levels", &
731	"m", jpk, gdept_0, ndepidzt, "down" )
732	CALL histvert( numptr, "depthw", "Vertical W levels", &
733	"m", jpk, gdepw_0, ndepidzw, "down" )
734
735	!
736	CALL wheneq ( jpj*jpk, MIN(surf_jk_glo(:,:), 1.e0), 1, 1., ndex , ndim ) ! Lat-Depth
737	CALL wheneq ( jpj , MIN(surf_jk_glo(:,1), 1.e0), 1, 1., ndex_h, ndim_h ) ! Lat
738
739	IF (ln_subbas) THEN
740	z_1 (:,1) = 1.0e0
741	WHERE ( gphit (jpi/2,:) .LT. -30 ) z_1 (:,1) = 0.e0
742	DO jk = 2, jpk
743	z_1 (:,jk) = z_1 (:,1)
744	END DO
745
746	CALL wheneq ( jpj*jpk, MIN(surf_jk_atl(:,:) , 1.e0), 1, 1., ndex_atl , ndim_atl ) ! Lat-Depth
747	CALL wheneq ( jpjjpk, MIN(surf_jk_atl(:,:)z_1(:,:), 1.e0), 1, 1., ndex_atl_30 , ndim_atl_30 ) ! Lat-Depth
748	CALL wheneq ( jpj , MIN(surf_jk_atl(:,1)*z_1(:,1), 1.e0), 1, 1., ndex_h_atl_30, ndim_h_atl_30 ) ! Lat
749
750	CALL wheneq ( jpj*jpk, MIN(surf_jk_pac(:,:) , 1.e0), 1, 1., ndex_pac , ndim_pac ) ! Lat-Depth
751	CALL wheneq ( jpjjpk, MIN(surf_jk_pac(:,:)z_1(:,:), 1.e0), 1, 1., ndex_pac_30 , ndim_pac_30 ) ! Lat-Depth
752	CALL wheneq ( jpj , MIN(surf_jk_pac(:,1)*z_1(:,1), 1.e0), 1, 1., ndex_h_pac_30, ndim_h_pac_30 ) ! Lat
753
754	CALL wheneq ( jpj*jpk, MIN(surf_jk_ind(:,:) , 1.e0), 1, 1., ndex_ind , ndim_ind ) ! Lat-Depth
755	CALL wheneq ( jpjjpk, MIN(surf_jk_ind(:,:)z_1(:,:), 1.e0), 1, 1., ndex_ind_30 , ndim_ind_30 ) ! Lat-Depth
756	CALL wheneq ( jpj , MIN(surf_jk_ind(:,1)*z_1(:,1), 1.e0), 1, 1., ndex_h_ind_30, ndim_h_ind_30 ) ! Lat
757
758	CALL wheneq ( jpj*jpk, MIN(surf_jk_ipc(:,:) , 1.e0), 1, 1., ndex_ipc , ndim_ipc ) ! Lat-Depth
759	CALL wheneq ( jpjjpk, MIN(surf_jk_ipc(:,:)z_1(:,:), 1.e0), 1, 1., ndex_ipc_30 , ndim_ipc_30 ) ! Lat-Depth
760	CALL wheneq ( jpj , MIN(surf_jk_ipc(:,1)*z_1(:,1), 1.e0), 1, 1., ndex_h_ipc_30, ndim_h_ipc_30 ) ! Lat
761
762	ENDIF
763
764	!
765	#if defined key_diaeiv
766	cl_comment = ' (Bolus part included)'
767	#else
768	cl_comment = ' '
769	#endif
770	! Zonal mean T and S
771
772	IF ( ln_diaznl ) THEN
773	CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" , &
774	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
775	CALL histdef( numptr, "zosalglo", "Zonal Mean Salinity","PSU" , &
776	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
777
778	CALL histdef( numptr, "zosrfglo", "Zonal Mean Surface","m^2" , &
779	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
780
781	IF (ln_subbas) THEN
782	CALL histdef( numptr, "zotematl", "Zonal Mean Temperature: Atlantic","C" , &
783	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
784	CALL histdef( numptr, "zosalatl", "Zonal Mean Salinity: Atlantic","PSU" , &
785	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
786	CALL histdef( numptr, "zosrfatl", "Zonal Mean Surface: Atlantic","m^2" , &
787	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
788
789	CALL histdef( numptr, "zotempac", "Zonal Mean Temperature: Pacific","C" , &
790	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
791	CALL histdef( numptr, "zosalpac", "Zonal Mean Salinity: Pacific","PSU" , &
792	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
793	CALL histdef( numptr, "zosrfpac", "Zonal Mean Surface: Pacific","m^2" , &
794	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
795
796	CALL histdef( numptr, "zotemind", "Zonal Mean Temperature: Indian","C" , &
797	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
798	CALL histdef( numptr, "zosalind", "Zonal Mean Salinity: Indian","PSU" , &
799	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
800	CALL histdef( numptr, "zosrfind", "Zonal Mean Surface: Indian","m^2" , &
801	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
802
803	CALL histdef( numptr, "zotemipc", "Zonal Mean Temperature: Pacific+Indian","C" , &
804	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
805	CALL histdef( numptr, "zosalipc", "Zonal Mean Salinity: Pacific+Indian","PSU" , &
806	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
807	CALL histdef( numptr, "zosrfipc", "Zonal Mean Surface: Pacific+Indian","m^2" , &
808	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
809	ENDIF
810
811	ENDIF
812
813	! Meridional Stream-Function (Eulerian and Bolus)
814
815	CALL histdef( numptr, "zomsfglo", "Meridional Stream-Function: Global"//TRIM(cl_comment),"Sv" , &
816	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
817	IF( ln_subbas .AND. ln_diaznl ) THEN
818	CALL histdef( numptr, "zomsfatl", "Meridional Stream-Function: Atlantic"//TRIM(cl_comment),"Sv" , &
819	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
820	CALL histdef( numptr, "zomsfpac", "Meridional Stream-Function: Pacific"//TRIM(cl_comment),"Sv" , &
821	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
822	CALL histdef( numptr, "zomsfind", "Meridional Stream-Function: Indian"//TRIM(cl_comment),"Sv" , &
823	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
824	CALL histdef( numptr, "zomsfipc", "Meridional Stream-Function: Indo-Pacific"//TRIM(cl_comment),"Sv" ,&
825	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
826	ENDIF
827
828	! Heat transport
829
830	CALL histdef( numptr, "sophtadv", "Advective Heat Transport" , &
831	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
832	CALL histdef( numptr, "sophtldf", "Diffusive Heat Transport" , &
833	"PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
834	IF ( ln_ptrcomp ) THEN
835	CALL histdef( numptr, "sophtove", "Overturning Heat Transport" , &
836	"PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
837	END IF
838	IF( ln_subbas ) THEN
839	CALL histdef( numptr, "sohtatl", "Heat Transport Atlantic"//TRIM(cl_comment), &
840	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
841	CALL histdef( numptr, "sohtpac", "Heat Transport Pacific"//TRIM(cl_comment) , &
842	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
843	CALL histdef( numptr, "sohtind", "Heat Transport Indian"//TRIM(cl_comment) , &
844	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
845	CALL histdef( numptr, "sohtipc", "Heat Transport Pacific+Indian"//TRIM(cl_comment), &
846	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
847	ENDIF
848
849
850	! Salt transport
851
852	CALL histdef( numptr, "sopstadv", "Advective Salt Transport" , &
853	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
854	CALL histdef( numptr, "sopstldf", "Diffusive Salt Transport" , &
855	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
856	IF ( ln_ptrcomp ) THEN
857	CALL histdef( numptr, "sopstove", "Overturning Salt Transport" , &
858	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
859	END IF
860	#if defined key_diaeiv
861	! Eddy induced velocity
862	CALL histdef( numptr, "zomsfeiv", "Bolus Meridional Stream-Function: global", &
863	"Sv" , 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
864	CALL histdef( numptr, "sophteiv", "Bolus Advective Heat Transport", &
865	"PW" , 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
866	CALL histdef( numptr, "sopsteiv", "Bolus Advective Salt Transport", &
867	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
868	#endif
869	IF( ln_subbas ) THEN
870	CALL histdef( numptr, "sostatl", "Salt Transport Atlantic"//TRIM(cl_comment) , &
871	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
872	CALL histdef( numptr, "sostpac", "Salt Transport Pacific"//TRIM(cl_comment) , &
873	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
874	CALL histdef( numptr, "sostind", "Salt Transport Indian"//TRIM(cl_comment) , &
875	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
876	CALL histdef( numptr, "sostipc", "Salt Transport Pacific+Indian"//TRIM(cl_comment), &
877	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
878	ENDIF
879
880	CALL histend( numptr )
881
882	END IF
883	#if defined key_mpp_mpi
884	END IF
885	#endif
886
887	#if defined key_mpp_mpi
888	IF( MOD( itmod, nf_ptr ) == 0 .AND. l_znl_root ) THEN
889	#else
890	IF( MOD( itmod, nf_ptr ) == 0 ) THEN
891	#endif
892	niter = niter + 1
893
894	!-$$ IF(lwp) THEN
895	!-$$ WRITE(numout,*)
896	!-$$ WRITE(numout,*) 'dia_ptr_wri : write Poleward Transports at time-step : kt = ', kt, &
897	!-$$ & 'it = ', it, ' itmod = ', itmod, ' niter = ', niter
898	!-$$ WRITE(numout,*) '~~~~~~~~~~'
899	!-$$ WRITE(numout,*)
900	!-$$ ENDIF
901
902	IF (ln_diaznl ) THEN
903	CALL histwrite( numptr, "zosrfglo", niter, surf_jk_glo , ndim, ndex )
904	CALL histwrite( numptr, "zotemglo", niter, tn_jk_glo , ndim, ndex )
905	CALL histwrite( numptr, "zosalglo", niter, sn_jk_glo , ndim, ndex )
906
907	IF (ln_subbas) THEN
908	CALL histwrite( numptr, "zosrfatl", niter, surf_jk_atl, ndim_atl, ndex_atl )
909	CALL histwrite( numptr, "zosrfpac", niter, surf_jk_pac, ndim_pac, ndex_pac )
910	CALL histwrite( numptr, "zosrfind", niter, surf_jk_ind, ndim_ind, ndex_ind )
911	CALL histwrite( numptr, "zosrfipc", niter, surf_jk_ipc, ndim_ipc, ndex_ipc )
912
913	CALL histwrite( numptr, "zotematl", niter, tn_jk_atl , ndim_atl, ndex_atl )
914	CALL histwrite( numptr, "zosalatl", niter, sn_jk_atl , ndim_atl, ndex_atl )
915	CALL histwrite( numptr, "zotempac", niter, tn_jk_pac , ndim_pac, ndex_pac )
916	CALL histwrite( numptr, "zosalpac", niter, sn_jk_pac , ndim_pac, ndex_pac )
917	CALL histwrite( numptr, "zotemind", niter, tn_jk_ind , ndim_ind, ndex_ind )
918	CALL histwrite( numptr, "zosalind", niter, sn_jk_ind , ndim_ind, ndex_ind )
919	CALL histwrite( numptr, "zotemipc", niter, tn_jk_ipc , ndim_ipc, ndex_ipc )
920	CALL histwrite( numptr, "zosalipc", niter, sn_jk_ipc , ndim_ipc, ndex_ipc )
921	END IF
922	ENDIF
923
924	! overturning outputs:
925	CALL histwrite( numptr, "zomsfglo", niter, v_msf_glo, ndim, ndex )
926	IF( ln_subbas .AND. ln_diaznl ) THEN
927	CALL histwrite( numptr, "zomsfatl", niter, v_msf_atl , ndim_atl_30, ndex_atl_30 )
928	CALL histwrite( numptr, "zomsfpac", niter, v_msf_pac , ndim_pac_30, ndex_pac_30 )
929	CALL histwrite( numptr, "zomsfind", niter, v_msf_ind , ndim_ind_30, ndex_ind_30 )
930	CALL histwrite( numptr, "zomsfipc", niter, v_msf_ipc , ndim_ipc_30, ndex_ipc_30 )
931	ENDIF
932	#if defined key_diaeiv
933	CALL histwrite( numptr, "zomsfeiv", niter, v_msf_eiv_glo, ndim , ndex )
934	#endif
935
936
937	! heat transport outputs:
938	IF( ln_subbas ) THEN
939	CALL histwrite( numptr, "sohtatl", niter, ht_atl , ndim_h_atl_30, ndex_h_atl_30 )
940	CALL histwrite( numptr, "sohtpac", niter, ht_pac , ndim_h_pac_30, ndex_h_pac_30 )
941	CALL histwrite( numptr, "sohtind", niter, ht_ind , ndim_h_ind_30, ndex_h_ind_30 )
942	CALL histwrite( numptr, "sohtipc", niter, ht_ipc , ndim_h_ipc_30, ndex_h_ipc_30 )
943	CALL histwrite( numptr, "sostatl", niter, st_atl , ndim_h_atl_30, ndex_h_atl_30 )
944	CALL histwrite( numptr, "sostpac", niter, st_pac , ndim_h_pac_30, ndex_h_pac_30 )
945	CALL histwrite( numptr, "sostind", niter, st_ind , ndim_h_ind_30, ndex_h_ind_30 )
946	CALL histwrite( numptr, "sostipc", niter, st_ipc , ndim_h_ipc_30, ndex_h_ipc_30 )
947	ENDIF
948
949	CALL histwrite( numptr, "sophtadv", niter, pht_adv , ndim_h, ndex_h )
950	CALL histwrite( numptr, "sophtldf", niter, pht_ldf , ndim_h, ndex_h )
951	CALL histwrite( numptr, "sopstadv", niter, pst_adv , ndim_h, ndex_h )
952	CALL histwrite( numptr, "sopstldf", niter, pst_ldf , ndim_h, ndex_h )
953	IF ( ln_ptrcomp ) THEN
954	CALL histwrite( numptr, "sopstove", niter, pst_ove_glo , ndim_h, ndex_h )
955	CALL histwrite( numptr, "sophtove", niter, pht_ove_glo , ndim_h, ndex_h )
956	ENDIF
957	#if defined key_diaeiv
958	CALL histwrite( numptr, "sophteiv", niter, pht_eiv_glo , ndim_h, ndex_h )
959	CALL histwrite( numptr, "sopsteiv", niter, pst_eiv_glo , ndim_h, ndex_h )
960	#endif
961	!
962	ENDIF
963	!
964	END SUBROUTINE dia_ptr_wri
965
966	!!======================================================================
967	END MODULE diaptr

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

Download in other formats: