Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

diaptr.F90

Last change on this file was 11101, checked in by frrh, 5 years ago

Merge changes from Met Office GMED ticket 450 to reduce unnecessary
text output from NEMO.
This output, which is typically not switchable, is rarely of interest
in normal (non-debugging) runs and simply redunantley consumes extra
file space.
Further, the presence of this text output has been shown to
significantly degrade performance of models which are run during
Met Office HPC RAID (disk) checks.
The new code introduces switches which are configurable via the
changes made in the associated Met Office MOCI ticket 399.

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 .AND. nprint > 2) 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	IF(lflush) CALL flush(numout)
481	ENDIF
482
483	IF( ln_diaptr ) THEN
484	!
485	IF( ln_subbas ) THEN
486	nptr = 5 ! Global, Atlantic, Pacific, Indian, Indo-Pacific
487	ALLOCATE( clsubb(nptr) )
488	clsubb(1) = 'glo' ; clsubb(2) = 'atl' ; clsubb(3) = 'pac' ; clsubb(4) = 'ind' ; clsubb(5) = 'ipc'
489	ELSE
490	nptr = 1 ! Global only
491	ALLOCATE( clsubb(nptr) )
492	clsubb(1) = 'glo'
493	ENDIF
494
495	! ! allocate dia_ptr arrays
496	IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' )
497
498	rc_pwatt = rc_pwatt * rau0_rcp ! conversion from K.s-1 to PetaWatt
499
500	IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum
501
502	IF( ln_subbas ) THEN ! load sub-basin mask
503	CALL iom_open( 'subbasins', inum, ldstop = .TRUE. )
504	CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin
505	CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin
506	CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin
507	CALL iom_close( inum )
508	btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin
509	WHERE( gphit(:,:) < -30._wp) ; btm30(:,:) = 0._wp ! mask out Southern Ocean
510	ELSE WHERE ; btm30(:,:) = ssmask(:,:)
511	END WHERE
512	ENDIF
513
514	btmsk(:,:,1) = tmask_i(:,:) ! global ocean
515
516	DO jn = 1, nptr
517	btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only
518	END DO
519
520	! Initialise arrays to zero because diatpr is called before they are first calculated
521	! Note that this means diagnostics will not be exactly correct when model run is restarted.
522	htr_adv(:,:) = 0._wp ; str_adv(:,:) = 0._wp
523	htr_ldf(:,:) = 0._wp ; str_ldf(:,:) = 0._wp
524	htr_eiv(:,:) = 0._wp ; str_eiv(:,:) = 0._wp
525	htr_vt(:,:) = 0._wp ; str_vs(:,:) = 0._wp
526	htr_ove(:,:) = 0._wp ; str_ove(:,:) = 0._wp
527	htr_btr(:,:) = 0._wp ; str_btr(:,:) = 0._wp
528	!
529	ENDIF
530	!
531	END SUBROUTINE dia_ptr_init
532
533	SUBROUTINE dia_ptr_ohst_components( ktra, cptr, pva )
534	!!----------------------------------------------------------------------
535	!! * ROUTINE dia_ptr_ohst_components *
536	!!----------------------------------------------------------------------
537	!! Wrapper for heat and salt transport calculations to calculate them for each basin
538	!! Called from all advection and/or diffusion routines
539	!!----------------------------------------------------------------------
540	INTEGER , INTENT(in ) :: ktra ! tracer index
541	CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv'
542	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pva ! 3D input array of advection/diffusion
543	INTEGER :: jn !
544
545	IF( cptr == 'adv' ) THEN
546	IF( ktra == jp_tem ) htr_adv(:,1) = ptr_sj( pva(:,:,:) )
547	IF( ktra == jp_sal ) str_adv(:,1) = ptr_sj( pva(:,:,:) )
548	ENDIF
549	IF( cptr == 'ldf' ) THEN
550	IF( ktra == jp_tem ) htr_ldf(:,1) = ptr_sj( pva(:,:,:) )
551	IF( ktra == jp_sal ) str_ldf(:,1) = ptr_sj( pva(:,:,:) )
552	ENDIF
553	IF( cptr == 'eiv' ) THEN
554	IF( ktra == jp_tem ) htr_eiv(:,1) = ptr_sj( pva(:,:,:) )
555	IF( ktra == jp_sal ) str_eiv(:,1) = ptr_sj( pva(:,:,:) )
556	ENDIF
557	IF( cptr == 'vts' ) THEN
558	IF( ktra == jp_tem ) htr_vt(:,1) = ptr_sj( pva(:,:,:) )
559	IF( ktra == jp_sal ) str_vs(:,1) = ptr_sj( pva(:,:,:) )
560	ENDIF
561	!
562	IF( ln_subbas ) THEN
563	!
564	IF( cptr == 'adv' ) THEN
565	IF( ktra == jp_tem ) THEN
566	DO jn = 2, nptr
567	htr_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
568	END DO
569	ENDIF
570	IF( ktra == jp_sal ) THEN
571	DO jn = 2, nptr
572	str_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
573	END DO
574	ENDIF
575	ENDIF
576	IF( cptr == 'ldf' ) THEN
577	IF( ktra == jp_tem ) THEN
578	DO jn = 2, nptr
579	htr_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
580	END DO
581	ENDIF
582	IF( ktra == jp_sal ) THEN
583	DO jn = 2, nptr
584	str_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
585	END DO
586	ENDIF
587	ENDIF
588	IF( cptr == 'eiv' ) THEN
589	IF( ktra == jp_tem ) THEN
590	DO jn = 2, nptr
591	htr_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
592	END DO
593	ENDIF
594	IF( ktra == jp_sal ) THEN
595	DO jn = 2, nptr
596	str_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
597	END DO
598	ENDIF
599	ENDIF
600	IF( cptr == 'vts' ) THEN
601	IF( ktra == jp_tem ) THEN
602	DO jn = 2, nptr
603	htr_vt(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
604	END DO
605	ENDIF
606	IF( ktra == jp_sal ) THEN
607	DO jn = 2, nptr
608	str_vs(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
609	END DO
610	ENDIF
611	ENDIF
612	!
613	ENDIF
614	END SUBROUTINE dia_ptr_ohst_components
615
616
617	FUNCTION dia_ptr_alloc()
618	!!----------------------------------------------------------------------
619	!! * ROUTINE dia_ptr_alloc *
620	!!----------------------------------------------------------------------
621	INTEGER :: dia_ptr_alloc ! return value
622	INTEGER, DIMENSION(3) :: ierr
623	!!----------------------------------------------------------------------
624	ierr(:) = 0
625	!
626	ALLOCATE( btmsk(jpi,jpj,nptr) , &
627	& htr_adv(jpj,nptr) , str_adv(jpj,nptr) , &
628	& htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , &
629	& htr_vt(jpj,nptr) , str_vs(jpj,nptr) , &
630	& htr_ove(jpj,nptr) , str_ove(jpj,nptr) , &
631	& htr_btr(jpj,nptr) , str_btr(jpj,nptr) , &
632	& htr_ldf(jpj,nptr) , str_ldf(jpj,nptr) , STAT=ierr(1) )
633	!
634	ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2))
635	!
636	ALLOCATE( btm30(jpi,jpj), STAT=ierr(3) )
637
638	!
639	dia_ptr_alloc = MAXVAL( ierr )
640	IF(lk_mpp) CALL mpp_sum( dia_ptr_alloc )
641	!
642	END FUNCTION dia_ptr_alloc
643
644
645	FUNCTION ptr_sj_3d( pva, pmsk ) RESULT ( p_fval )
646	!!----------------------------------------------------------------------
647	!! * ROUTINE ptr_sj_3d *
648	!!
649	!! ** Purpose : i-k sum computation of a j-flux array
650	!!
651	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
652	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
653	!!
654	!! ** Action : - p_fval: i-k-mean poleward flux of pva
655	!!----------------------------------------------------------------------
656	REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point
657	REAL(wp), INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: pmsk ! Optional 2D basin mask
658	!
659	INTEGER :: ji, jj, jk ! dummy loop arguments
660	INTEGER :: ijpj ! ???
661	REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
662	!!--------------------------------------------------------------------
663	!
664	p_fval => p_fval1d
665
666	ijpj = jpj
667	p_fval(:) = 0._wp
668	IF( PRESENT( pmsk ) ) THEN
669	DO jk = 1, jpkm1
670	DO jj = 2, jpjm1
671	DO ji = fs_2, fs_jpim1 ! Vector opt.
672	p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) * pmsk(ji,jj)
673	END DO
674	END DO
675	END DO
676	ELSE
677	DO jk = 1, jpkm1
678	DO jj = 2, jpjm1
679	DO ji = fs_2, fs_jpim1 ! Vector opt.
680	p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj)
681	END DO
682	END DO
683	END DO
684	ENDIF
685	#if defined key_mpp_mpi
686	IF(lk_mpp) CALL mpp_sum( p_fval, ijpj, ncomm_znl)
687	#endif
688	!
689	END FUNCTION ptr_sj_3d
690
691
692	FUNCTION ptr_sj_2d( pva, pmsk ) RESULT ( p_fval )
693	!!----------------------------------------------------------------------
694	!! * ROUTINE ptr_sj_2d *
695	!!
696	!! ** Purpose : "zonal" and vertical sum computation of a i-flux array
697	!!
698	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
699	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
700	!!
701	!! ** Action : - p_fval: i-k-mean poleward flux of pva
702	!!----------------------------------------------------------------------
703	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point
704	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: pmsk ! Optional 2D basin mask
705	!
706	INTEGER :: ji,jj ! dummy loop arguments
707	INTEGER :: ijpj ! ???
708	REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
709	!!--------------------------------------------------------------------
710	!
711	p_fval => p_fval1d
712
713	ijpj = jpj
714	p_fval(:) = 0._wp
715	IF( PRESENT( pmsk ) ) THEN
716	DO jj = 2, jpjm1
717	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
718	p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) * pmsk(ji,jj)
719	END DO
720	END DO
721	ELSE
722	DO jj = 2, jpjm1
723	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
724	p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj)
725	END DO
726	END DO
727	ENDIF
728	#if defined key_mpp_mpi
729	CALL mpp_sum( p_fval, ijpj, ncomm_znl )
730	#endif
731	!
732	END FUNCTION ptr_sj_2d
733
734
735	FUNCTION ptr_sjk( pta, pmsk ) RESULT ( p_fval )
736	!!----------------------------------------------------------------------
737	!! * ROUTINE ptr_sjk *
738	!!
739	!! ** Purpose : i-sum computation of an array
740	!!
741	!! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i).
742	!!
743	!! ** Action : - p_fval: i-mean poleward flux of pva
744	!!----------------------------------------------------------------------
745	!!
746	IMPLICIT none
747	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! mask flux array at V-point
748	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: pmsk ! Optional 2D basin mask
749	!!
750	INTEGER :: ji, jj, jk ! dummy loop arguments
751	REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value
752	#if defined key_mpp_mpi
753	INTEGER, DIMENSION(1) :: ish
754	INTEGER, DIMENSION(2) :: ish2
755	INTEGER :: ijpjjpk
756	REAL(wp), DIMENSION(jpj*jpk) :: zwork ! mask flux array at V-point
757	#endif
758	!!--------------------------------------------------------------------
759	!
760	p_fval => p_fval2d
761
762	p_fval(:,:) = 0._wp
763	!
764	IF( PRESENT( pmsk ) ) THEN
765	DO jk = 1, jpkm1
766	DO jj = 2, jpjm1
767	!!gm here, use of tmask_i ==> no need of loop over nldi, nlei....
768	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
769	p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj)
770	END DO
771	END DO
772	END DO
773	ELSE
774	DO jk = 1, jpkm1
775	DO jj = 2, jpjm1
776	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
777	p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * tmask_i(ji,jj)
778	END DO
779	END DO
780	END DO
781	END IF
782	!
783	#if defined key_mpp_mpi
784	ijpjjpk = jpj*jpk
785	ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk
786	zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )
787	CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
788	p_fval(:,:) = RESHAPE( zwork, ish2 )
789	#endif
790	!
791
792	END FUNCTION ptr_sjk
793
794
795	!!======================================================================
796	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_package/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90

Download in other formats: