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 branches/UKMO/dev_r5518_GO6_package_fix_rnf_MOCI_TEST_SUITE/NEMOGCM/NEMO/OPA_SRC/DIA – NEMO

Context Navigation

source: branches/UKMO/dev_r5518_GO6_package_fix_rnf_MOCI_TEST_SUITE/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90 @ 8191

Last change on this file since 8191 was 8191, checked in by andmirek, 7 years ago
merge with XIOS restart read branch
File size: 36.1 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) :: zmask ! 3D workspace
87	REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace
88	REAL(wp), DIMENSION(jpj) :: vsum ! 1D workspace
89	REAL(wp), DIMENSION(jpj,jpts) :: tssum ! 1D workspace
90
91	!
92	!overturning calculation
93	REAL(wp), DIMENSION(jpj,jpk,nptr) :: sjk , r1_sjk ! i-mean i-k-surface and its inverse
94	REAL(wp), DIMENSION(jpj,jpk,nptr) :: v_msf, sn_jk , tn_jk ! i-mean T and S, j-Stream-Function
95	REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvn ! 3D workspace
96
97
98	CHARACTER( len = 12 ) :: cl1
99	!!----------------------------------------------------------------------
100	!
101	IF( nn_timing == 1 ) CALL timing_start('dia_ptr')
102
103	!
104	z3d(:,:,:) = 0._wp
105	IF( PRESENT( pvtr ) ) THEN
106	IF( iom_use("zomsfglo") ) THEN ! effective MSF
107	z3d(1,:,:) = ptr_sjk( pvtr(:,:,:) ) ! zonal cumulative effective transport
108	DO jk = jpkm1,1,-1 !Integrate from bottom up to get
109	z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk) ! effective j-Stream-Function (MSF)
110	END DO
111	DO ji = 1, jpi
112	z3d(ji,:,:) = z3d(1,:,:)
113	ENDDO
114	cl1 = TRIM('zomsf'//clsubb(1) )
115	CALL iom_put( cl1, z3d * rc_sv )
116	DO jn = 2, nptr ! by sub-basins
117	z3d(1,:,:) = ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn) )
118	DO jk = jpkm1,1,-1
119	z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk) ! effective j-Stream-Function (MSF)
120	END DO
121	DO ji = 1, jpi
122	z3d(ji,:,:) = z3d(1,:,:)
123	ENDDO
124	cl1 = TRIM('zomsf'//clsubb(jn) )
125	CALL iom_put( cl1, z3d * rc_sv )
126	END DO
127	ENDIF
128	IF( iom_use("sopstove") .OR. iom_use("sophtove") .OR. iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN
129	! define fields multiplied by scalar
130	zmask(:,:,:) = 0._wp
131	zts(:,:,:,:) = 0._wp
132	zvn(:,:,:) = 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	zvn(ji,jj,jk) = vn(ji,jj,jk) * zvfc
141	ENDDO
142	ENDDO
143	ENDDO
144	ENDIF
145	IF( iom_use("sopstove") .OR. iom_use("sophtove") ) THEN
146	sjk(:,:,1) = ptr_sjk( zmask(:,:,:), btmsk(:,:,1) )
147	r1_sjk(:,:,1) = 0._wp
148	WHERE( sjk(:,:,1) /= 0._wp ) r1_sjk(:,:,1) = 1._wp / sjk(:,:,1)
149
150	! i-mean T and S, j-Stream-Function, global
151	tn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_tem) ) * r1_sjk(:,:,1)
152	sn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_sal) ) * r1_sjk(:,:,1)
153	v_msf(:,:,1) = ptr_sjk( zvn(:,:,:) )
154
155	htr_ove(:,1) = SUM( v_msf(:,:,1)*tn_jk(:,:,1) ,2 )
156	str_ove(:,1) = SUM( v_msf(:,:,1)*sn_jk(:,:,1) ,2 )
157
158	z2d(1,:) = htr_ove(:,1) * rc_pwatt ! (conversion in PW)
159	DO ji = 1, jpi
160	z2d(ji,:) = z2d(1,:)
161	ENDDO
162	cl1 = 'sophtove'
163	CALL iom_put( TRIM(cl1), z2d )
164	z2d(1,:) = str_ove(:,1) * rc_ggram ! (conversion in Gg)
165	DO ji = 1, jpi
166	z2d(ji,:) = z2d(1,:)
167	ENDDO
168	cl1 = 'sopstove'
169	CALL iom_put( TRIM(cl1), z2d )
170	IF( ln_subbas ) THEN
171	DO jn = 2, nptr
172	sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
173	r1_sjk(:,:,jn) = 0._wp
174	WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn)
175
176	! i-mean T and S, j-Stream-Function, basin
177	tn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
178	sn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
179	v_msf(:,:,jn) = ptr_sjk( zvn(:,:,:), btmsk(:,:,jn) )
180	htr_ove(:,jn) = SUM( v_msf(:,:,jn)*tn_jk(:,:,jn) ,2 )
181	str_ove(:,jn) = SUM( v_msf(:,:,jn)*sn_jk(:,:,jn) ,2 )
182
183	z2d(1,:) = htr_ove(:,jn) * rc_pwatt ! (conversion in PW)
184	DO ji = 1, jpi
185	z2d(ji,:) = z2d(1,:)
186	ENDDO
187	cl1 = TRIM('sophtove_'//clsubb(jn))
188	CALL iom_put( cl1, z2d )
189	z2d(1,:) = str_ove(:,jn) * rc_ggram ! (conversion in Gg)
190	DO ji = 1, jpi
191	z2d(ji,:) = z2d(1,:)
192	ENDDO
193	cl1 = TRIM('sopstove_'//clsubb(jn))
194	CALL iom_put( cl1, z2d )
195	END DO
196	ENDIF
197	ENDIF
198	IF( iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN
199	! Calculate barotropic heat and salt transport here
200	sjk(:,1,1) = ptr_sj( zmask(:,:,:), btmsk(:,:,1) )
201	r1_sjk(:,1,1) = 0._wp
202	WHERE( sjk(:,1,1) /= 0._wp ) r1_sjk(:,1,1) = 1._wp / sjk(:,1,1)
203
204	vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,1))
205	tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,1) )
206	tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,1) )
207	htr_btr(:,1) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,1)
208	str_btr(:,1) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,1)
209	z2d(1,:) = htr_btr(:,1) * rc_pwatt ! (conversion in PW)
210	DO ji = 2, jpi
211	z2d(ji,:) = z2d(1,:)
212	ENDDO
213	cl1 = 'sophtbtr'
214	CALL iom_put( TRIM(cl1), z2d )
215	z2d(1,:) = str_btr(:,1) * rc_ggram ! (conversion in Gg)
216	DO ji = 2, jpi
217	z2d(ji,:) = z2d(1,:)
218	ENDDO
219	cl1 = 'sopstbtr'
220	CALL iom_put( TRIM(cl1), z2d )
221	IF( ln_subbas ) THEN
222	DO jn = 2, nptr
223	sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) )
224	r1_sjk(:,1,jn) = 0._wp
225	WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn)
226	vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,jn))
227	tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) )
228	tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) )
229	htr_btr(:,jn) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,jn)
230	str_btr(:,jn) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,jn)
231	z2d(1,:) = htr_btr(:,jn) * rc_pwatt ! (conversion in PW)
232	DO ji = 1, jpi
233	z2d(ji,:) = z2d(1,:)
234	ENDDO
235	cl1 = TRIM('sophtbtr_'//clsubb(jn))
236	CALL iom_put( cl1, z2d )
237	z2d(1,:) = str_btr(:,jn) * rc_ggram ! (conversion in Gg)
238	DO ji = 1, jpi
239	z2d(ji,:) = z2d(1,:)
240	ENDDO
241	cl1 = TRIM('sopstbtr_'//clsubb(jn))
242	CALL iom_put( cl1, z2d )
243	ENDDO
244	ENDIF !ln_subbas
245	ENDIF !iom_use("sopstbtr....)
246	!
247	ELSE
248	!
249	IF( iom_use("zotemglo") ) THEN ! i-mean i-k-surface
250	DO jk = 1, jpkm1
251	DO jj = 1, jpj
252	DO ji = 1, jpi
253	zsfc = e1t(ji,jj) * fse3t(ji,jj,jk)
254	zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc
255	zts(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * zsfc
256	zts(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * zsfc
257	ENDDO
258	ENDDO
259	ENDDO
260	DO jn = 1, nptr
261	zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
262	cl1 = TRIM('zosrf'//clsubb(jn) )
263	CALL iom_put( cl1, zmask )
264	!
265	z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) &
266	& / MAX( zmask(1,:,:), 10.e-15 )
267	DO ji = 1, jpi
268	z3d(ji,:,:) = z3d(1,:,:)
269	ENDDO
270	cl1 = TRIM('zotem'//clsubb(jn) )
271	CALL iom_put( cl1, z3d )
272	!
273	z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) &
274	& / MAX( zmask(1,:,:), 10.e-15 )
275	DO ji = 1, jpi
276	z3d(ji,:,:) = z3d(1,:,:)
277	ENDDO
278	cl1 = TRIM('zosal'//clsubb(jn) )
279	CALL iom_put( cl1, z3d )
280	END DO
281	ENDIF
282	!
283	! ! Advective and diffusive heat and salt transport
284	IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN
285	z2d(1,:) = htr_adv(:,1) * rc_pwatt ! (conversion in PW)
286	DO ji = 1, jpi
287	z2d(ji,:) = z2d(1,:)
288	ENDDO
289	cl1 = 'sophtadv'
290	CALL iom_put( TRIM(cl1), z2d )
291	z2d(1,:) = str_adv(:,1) * rc_ggram ! (conversion in Gg)
292	DO ji = 1, jpi
293	z2d(ji,:) = z2d(1,:)
294	ENDDO
295	cl1 = 'sopstadv'
296	CALL iom_put( TRIM(cl1), z2d )
297	IF( ln_subbas ) THEN
298	DO jn=2,nptr
299	z2d(1,:) = htr_adv(:,jn) * rc_pwatt ! (conversion in PW)
300	DO ji = 1, jpi
301	z2d(ji,:) = z2d(1,:)
302	ENDDO
303	cl1 = TRIM('sophtadv_'//clsubb(jn))
304	CALL iom_put( cl1, z2d )
305	z2d(1,:) = str_adv(:,jn) * rc_ggram ! (conversion in Gg)
306	DO ji = 1, jpi
307	z2d(ji,:) = z2d(1,:)
308	ENDDO
309	cl1 = TRIM('sopstadv_'//clsubb(jn))
310	CALL iom_put( cl1, z2d )
311	ENDDO
312	ENDIF
313	ENDIF
314	!
315	IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN
316	z2d(1,:) = htr_ldf(:,1) * rc_pwatt ! (conversion in PW)
317	DO ji = 1, jpi
318	z2d(ji,:) = z2d(1,:)
319	ENDDO
320	cl1 = 'sophtldf'
321	CALL iom_put( TRIM(cl1), z2d )
322	z2d(1,:) = str_ldf(:,1) * rc_ggram ! (conversion in Gg)
323	DO ji = 1, jpi
324	z2d(ji,:) = z2d(1,:)
325	ENDDO
326	cl1 = 'sopstldf'
327	CALL iom_put( TRIM(cl1), z2d )
328	IF( ln_subbas ) THEN
329	DO jn=2,nptr
330	z2d(1,:) = htr_ldf(:,jn) * rc_pwatt ! (conversion in PW)
331	DO ji = 1, jpi
332	z2d(ji,:) = z2d(1,:)
333	ENDDO
334	cl1 = TRIM('sophtldf_'//clsubb(jn))
335	CALL iom_put( cl1, z2d )
336	z2d(1,:) = str_ldf(:,jn) * rc_ggram ! (conversion in Gg)
337	DO ji = 1, jpi
338	z2d(ji,:) = z2d(1,:)
339	ENDDO
340	cl1 = TRIM('sopstldf_'//clsubb(jn))
341	CALL iom_put( cl1, z2d )
342	ENDDO
343	ENDIF
344	ENDIF
345	<<<<<<< .working
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	z3d(1,:,:) = ptr_sjk( v_eiv(:,:,:) ) ! zonal cumulative effective transport
412	DO jk = jpkm1,1,-1
413	z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk) ! effective j-Stream-Function (MSF)
414	END DO
415	DO ji = 1, jpi
416	z3d(ji,:,:) = z3d(1,:,:)
417	ENDDO
418	cl1 = TRIM('zomsfeiv'//clsubb(1) )
419	CALL iom_put( cl1, z3d * rc_sv )
420	IF( ln_subbas ) THEN
421	DO jn = 2, nptr ! by sub-basins
422	z3d(1,:,:) = ptr_sjk( v_eiv(:,:,:), btmsk(:,:,jn) )
423	DO jk = jpkm1,1,-1
424	z3d(1,:,jk) = z3d(1,:,jk+1) - z3d(1,:,jk) ! effective j-Stream-Function (MSF)
425	END DO
426	DO ji = 1, jpi
427	z3d(ji,:,:) = z3d(1,:,:)
428	ENDDO
429	cl1 = TRIM('zomsfeiv'//clsubb(jn) )
430	CALL iom_put( cl1, z3d * rc_sv )
431	END DO
432	ENDIF
433	ENDIF
434	ENDIF
435	#endif
436	=======
437
438	IF( iom_use("sopht_vt") .OR. iom_use("sopst_vs") ) THEN
439	z2d(1,:) = htr_vt(:,1) * rc_pwatt ! (conversion in PW)
440	DO ji = 1, jpi
441	z2d(ji,:) = z2d(1,:)
442	ENDDO
443	cl1 = 'sopht_vt'
444	CALL iom_put( TRIM(cl1), z2d )
445	z2d(1,:) = str_vs(:,1) * rc_ggram ! (conversion in Gg)
446	DO ji = 1, jpi
447	z2d(ji,:) = z2d(1,:)
448	ENDDO
449	cl1 = 'sopst_vs'
450	CALL iom_put( TRIM(cl1), z2d )
451	IF( ln_subbas ) THEN
452	DO jn=2,nptr
453	z2d(1,:) = htr_vt(:,jn) * rc_pwatt ! (conversion in PW)
454	DO ji = 1, jpi
455	z2d(ji,:) = z2d(1,:)
456	ENDDO
457	cl1 = TRIM('sopht_vt_'//clsubb(jn))
458	CALL iom_put( cl1, z2d )
459	z2d(1,:) = str_vs(:,jn) * rc_ggram ! (conversion in Gg)
460	DO ji = 1, jpi
461	z2d(ji,:) = z2d(1,:)
462	ENDDO
463	cl1 = TRIM('sopst_vs_'//clsubb(jn))
464	CALL iom_put( cl1, z2d )
465	ENDDO
466	ENDIF
467	ENDIF
468
469	#ifdef key_diaeiv
470	IF(lk_traldf_eiv) THEN
471	IF( iom_use("sophteiv") .OR. iom_use("sopsteiv") ) THEN
472	z2d(1,:) = htr_eiv(:,1) * rc_pwatt ! (conversion in PW)
473	DO ji = 1, jpi
474	z2d(ji,:) = z2d(1,:)
475	ENDDO
476	cl1 = 'sophteiv'
477	CALL iom_put( TRIM(cl1), z2d )
478	z2d(1,:) = str_eiv(:,1) * rc_ggram ! (conversion in Gg)
479	DO ji = 1, jpi
480	z2d(ji,:) = z2d(1,:)
481	ENDDO
482	cl1 = 'sopsteiv'
483	CALL iom_put( TRIM(cl1), z2d )
484	IF( ln_subbas ) THEN
485	DO jn=2,nptr
486	z2d(1,:) = htr_eiv(:,jn) * rc_pwatt ! (conversion in PW)
487	DO ji = 1, jpi
488	z2d(ji,:) = z2d(1,:)
489	ENDDO
490	cl1 = TRIM('sophteiv_'//clsubb(jn))
491	CALL iom_put( cl1, z2d )
492	z2d(1,:) = str_eiv(:,jn) * rc_ggram ! (conversion in Gg)
493	DO ji = 1, jpi
494	z2d(ji,:) = z2d(1,:)
495	ENDDO
496	cl1 = TRIM('sopsteiv_'//clsubb(jn))
497	CALL iom_put( cl1, z2d )
498	ENDDO
499	ENDIF
500	ENDIF
501	ENDIF
502	#endif
503	>>>>>>> .merge-right.r7923
504	!
505	ENDIF
506	!
507	IF( nn_timing == 1 ) CALL timing_stop('dia_ptr')
508	!
509	END SUBROUTINE dia_ptr
510
511
512	SUBROUTINE dia_ptr_init
513	!!----------------------------------------------------------------------
514	!! * ROUTINE dia_ptr_init *
515	!!
516	!! ** Purpose : Initialization, namelist read
517	!!----------------------------------------------------------------------
518	INTEGER :: jn ! local integers
519	INTEGER :: inum, ierr ! local integers
520	INTEGER :: ios ! Local integer output status for namelist read
521	!!
522	NAMELIST/namptr/ ln_diaptr, ln_subbas
523	!!----------------------------------------------------------------------
524
525	REWIND( numnam_ref ) ! Namelist namptr in reference namelist : Poleward transport
526	READ ( numnam_ref, namptr, IOSTAT = ios, ERR = 901)
527	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist', lwp )
528
529	REWIND( numnam_cfg ) ! Namelist namptr in configuration namelist : Poleward transport
530	READ ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 )
531	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist', lwp )
532	IF(lwm) WRITE ( numond, namptr )
533
534	IF(lwp) THEN ! Control print
535	WRITE(numout,*)
536	WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
537	WRITE(numout,*) '~~~~~~~~~~~~'
538	WRITE(numout,*) ' Namelist namptr : set ptr parameters'
539	WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) ln_diaptr = ', ln_diaptr
540	WRITE(numout,*) ' Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins ln_subbas = ', ln_subbas
541	ENDIF
542
543	IF( ln_diaptr ) THEN
544	!
545	IF( ln_subbas ) THEN
546	nptr = 5 ! Global, Atlantic, Pacific, Indian, Indo-Pacific
547	ALLOCATE( clsubb(nptr) )
548	clsubb(1) = 'glo' ; clsubb(2) = 'atl' ; clsubb(3) = 'pac' ; clsubb(4) = 'ind' ; clsubb(5) = 'ipc'
549	ELSE
550	nptr = 1 ! Global only
551	ALLOCATE( clsubb(nptr) )
552	clsubb(1) = 'glo'
553	ENDIF
554
555	! ! allocate dia_ptr arrays
556	IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' )
557
558	rc_pwatt = rc_pwatt * rau0_rcp ! conversion from K.s-1 to PetaWatt
559
560	IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum
561
562	IF( ln_subbas ) THEN ! load sub-basin mask
563	CALL iom_open( 'subbasins', inum, ldstop = .FALSE. )
564	CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin
565	CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin
566	CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin
567	CALL iom_close( inum )
568	btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin
569	WHERE( gphit(:,:) < -30._wp) ; btm30(:,:) = 0._wp ! mask out Southern Ocean
570	ELSE WHERE ; btm30(:,:) = ssmask(:,:)
571	END WHERE
572	ENDIF
573
574	btmsk(:,:,1) = tmask_i(:,:) ! global ocean
575
576	DO jn = 1, nptr
577	btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only
578	END DO
579
580	! Initialise arrays to zero because diatpr is called before they are first calculated
581	! Note that this means diagnostics will not be exactly correct when model run is restarted.
582	htr_adv(:,:) = 0._wp ; str_adv(:,:) = 0._wp
583	htr_ldf(:,:) = 0._wp ; str_ldf(:,:) = 0._wp
584	htr_eiv(:,:) = 0._wp ; str_eiv(:,:) = 0._wp
585	htr_vt(:,:) = 0._wp ; str_vs(:,:) = 0._wp
586	htr_ove(:,:) = 0._wp ; str_ove(:,:) = 0._wp
587	htr_btr(:,:) = 0._wp ; str_btr(:,:) = 0._wp
588	!
589	ENDIF
590	!
591	END SUBROUTINE dia_ptr_init
592
593	SUBROUTINE dia_ptr_ohst_components( ktra, cptr, pva )
594	!!----------------------------------------------------------------------
595	!! * ROUTINE dia_ptr_ohst_components *
596	!!----------------------------------------------------------------------
597	!! Wrapper for heat and salt transport calculations to calculate them for each basin
598	!! Called from all advection and/or diffusion routines
599	!!----------------------------------------------------------------------
600	INTEGER , INTENT(in ) :: ktra ! tracer index
601	CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv'
602	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pva ! 3D input array of advection/diffusion
603	INTEGER :: jn !
604
605	IF( cptr == 'adv' ) THEN
606	IF( ktra == jp_tem ) htr_adv(:,1) = ptr_sj( pva(:,:,:) )
607	IF( ktra == jp_sal ) str_adv(:,1) = ptr_sj( pva(:,:,:) )
608	ENDIF
609	IF( cptr == 'ldf' ) THEN
610	IF( ktra == jp_tem ) htr_ldf(:,1) = ptr_sj( pva(:,:,:) )
611	IF( ktra == jp_sal ) str_ldf(:,1) = ptr_sj( pva(:,:,:) )
612	ENDIF
613	IF( cptr == 'eiv' ) THEN
614	IF( ktra == jp_tem ) htr_eiv(:,1) = ptr_sj( pva(:,:,:) )
615	IF( ktra == jp_sal ) str_eiv(:,1) = ptr_sj( pva(:,:,:) )
616	ENDIF
617	IF( cptr == 'vts' ) THEN
618	IF( ktra == jp_tem ) htr_vt(:,1) = ptr_sj( pva(:,:,:) )
619	IF( ktra == jp_sal ) str_vs(:,1) = ptr_sj( pva(:,:,:) )
620	ENDIF
621	!
622	IF( ln_subbas ) THEN
623	!
624	IF( cptr == 'adv' ) THEN
625	IF( ktra == jp_tem ) THEN
626	DO jn = 2, nptr
627	htr_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
628	END DO
629	ENDIF
630	IF( ktra == jp_sal ) THEN
631	DO jn = 2, nptr
632	str_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
633	END DO
634	ENDIF
635	ENDIF
636	IF( cptr == 'ldf' ) THEN
637	IF( ktra == jp_tem ) THEN
638	DO jn = 2, nptr
639	htr_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
640	END DO
641	ENDIF
642	IF( ktra == jp_sal ) THEN
643	DO jn = 2, nptr
644	str_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
645	END DO
646	ENDIF
647	ENDIF
648	IF( cptr == 'eiv' ) THEN
649	IF( ktra == jp_tem ) THEN
650	DO jn = 2, nptr
651	htr_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
652	END DO
653	ENDIF
654	IF( ktra == jp_sal ) THEN
655	DO jn = 2, nptr
656	str_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
657	END DO
658	ENDIF
659	ENDIF
660	IF( cptr == 'vts' ) THEN
661	IF( ktra == jp_tem ) THEN
662	DO jn = 2, nptr
663	htr_vt(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
664	END DO
665	ENDIF
666	IF( ktra == jp_sal ) THEN
667	DO jn = 2, nptr
668	str_vs(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
669	END DO
670	ENDIF
671	ENDIF
672	!
673	ENDIF
674	END SUBROUTINE dia_ptr_ohst_components
675
676
677	FUNCTION dia_ptr_alloc()
678	!!----------------------------------------------------------------------
679	!! * ROUTINE dia_ptr_alloc *
680	!!----------------------------------------------------------------------
681	INTEGER :: dia_ptr_alloc ! return value
682	INTEGER, DIMENSION(3) :: ierr
683	!!----------------------------------------------------------------------
684	ierr(:) = 0
685	!
686	ALLOCATE( btmsk(jpi,jpj,nptr) , &
687	& htr_adv(jpj,nptr) , str_adv(jpj,nptr) , &
688	& htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , &
689	& htr_vt(jpj,nptr) , str_vs(jpj,nptr) , &
690	& htr_ove(jpj,nptr) , str_ove(jpj,nptr) , &
691	& htr_btr(jpj,nptr) , str_btr(jpj,nptr) , &
692	& htr_ldf(jpj,nptr) , str_ldf(jpj,nptr) , STAT=ierr(1) )
693	!
694	ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2))
695	!
696	ALLOCATE( btm30(jpi,jpj), STAT=ierr(3) )
697
698	!
699	dia_ptr_alloc = MAXVAL( ierr )
700	IF(lk_mpp) CALL mpp_sum( dia_ptr_alloc )
701	!
702	END FUNCTION dia_ptr_alloc
703
704
705	FUNCTION ptr_sj_3d( pva, pmsk ) RESULT ( p_fval )
706	!!----------------------------------------------------------------------
707	!! * ROUTINE ptr_sj_3d *
708	!!
709	!! ** Purpose : i-k sum computation of a j-flux array
710	!!
711	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
712	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
713	!!
714	!! ** Action : - p_fval: i-k-mean poleward flux of pva
715	!!----------------------------------------------------------------------
716	REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point
717	REAL(wp), INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: pmsk ! Optional 2D basin mask
718	!
719	INTEGER :: ji, jj, jk ! dummy loop arguments
720	INTEGER :: ijpj ! ???
721	REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
722	!!--------------------------------------------------------------------
723	!
724	p_fval => p_fval1d
725
726	ijpj = jpj
727	p_fval(:) = 0._wp
728	IF( PRESENT( pmsk ) ) THEN
729	DO jk = 1, jpkm1
730	DO jj = 2, jpjm1
731	DO ji = fs_2, fs_jpim1 ! Vector opt.
732	p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) * pmsk(ji,jj)
733	END DO
734	END DO
735	END DO
736	ELSE
737	DO jk = 1, jpkm1
738	DO jj = 2, jpjm1
739	DO ji = fs_2, fs_jpim1 ! Vector opt.
740	p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj)
741	END DO
742	END DO
743	END DO
744	ENDIF
745	#if defined key_mpp_mpi
746	IF(lk_mpp) CALL mpp_sum( p_fval, ijpj, ncomm_znl)
747	#endif
748	!
749	END FUNCTION ptr_sj_3d
750
751
752	FUNCTION ptr_sj_2d( pva, pmsk ) RESULT ( p_fval )
753	!!----------------------------------------------------------------------
754	!! * ROUTINE ptr_sj_2d *
755	!!
756	!! ** Purpose : "zonal" and vertical sum computation of a i-flux array
757	!!
758	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
759	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
760	!!
761	!! ** Action : - p_fval: i-k-mean poleward flux of pva
762	!!----------------------------------------------------------------------
763	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point
764	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: pmsk ! Optional 2D basin mask
765	!
766	INTEGER :: ji,jj ! dummy loop arguments
767	INTEGER :: ijpj ! ???
768	REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
769	!!--------------------------------------------------------------------
770	!
771	p_fval => p_fval1d
772
773	ijpj = jpj
774	p_fval(:) = 0._wp
775	IF( PRESENT( pmsk ) ) THEN
776	DO jj = 2, jpjm1
777	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
778	p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) * pmsk(ji,jj)
779	END DO
780	END DO
781	ELSE
782	DO jj = 2, jpjm1
783	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
784	p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj)
785	END DO
786	END DO
787	ENDIF
788	#if defined key_mpp_mpi
789	CALL mpp_sum( p_fval, ijpj, ncomm_znl )
790	#endif
791	!
792	END FUNCTION ptr_sj_2d
793
794
795	FUNCTION ptr_sjk( pta, pmsk ) RESULT ( p_fval )
796	!!----------------------------------------------------------------------
797	!! * ROUTINE ptr_sjk *
798	!!
799	!! ** Purpose : i-sum computation of an array
800	!!
801	!! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i).
802	!!
803	!! ** Action : - p_fval: i-mean poleward flux of pva
804	!!----------------------------------------------------------------------
805	!!
806	IMPLICIT none
807	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! mask flux array at V-point
808	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: pmsk ! Optional 2D basin mask
809	!!
810	INTEGER :: ji, jj, jk ! dummy loop arguments
811	REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value
812	#if defined key_mpp_mpi
813	INTEGER, DIMENSION(1) :: ish
814	INTEGER, DIMENSION(2) :: ish2
815	INTEGER :: ijpjjpk
816	REAL(wp), DIMENSION(jpj*jpk) :: zwork ! mask flux array at V-point
817	#endif
818	!!--------------------------------------------------------------------
819	!
820	p_fval => p_fval2d
821
822	p_fval(:,:) = 0._wp
823	!
824	IF( PRESENT( pmsk ) ) THEN
825	DO jk = 1, jpkm1
826	DO jj = 2, jpjm1
827	!!gm here, use of tmask_i ==> no need of loop over nldi, nlei....
828	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
829	p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj)
830	END DO
831	END DO
832	END DO
833	ELSE
834	DO jk = 1, jpkm1
835	DO jj = 2, jpjm1
836	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
837	p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * tmask_i(ji,jj)
838	END DO
839	END DO
840	END DO
841	END IF
842	!
843	#if defined key_mpp_mpi
844	ijpjjpk = jpj*jpk
845	ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk
846	zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )
847	CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
848	p_fval(:,:) = RESHAPE( zwork, ish2 )
849	#endif
850	!
851
852	END FUNCTION ptr_sjk
853
854
855	!!======================================================================
856	END MODULE diaptr

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

Download in other formats: