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 NEMO/branches/2019/dev_r11643_ENHANCE-11_CEthe_Shaconemo_diags/src/OCE/DIA – NEMO

Context Navigation

source: NEMO/branches/2019/dev_r11643_ENHANCE-11_CEthe_Shaconemo_diags/src/OCE/DIA/diaptr.F90 @ 11995

Last change on this file since 11995 was 11995, checked in by cetlod, 4 years ago
Finalisation of CMIP6 diags implementation, src directory
Property svn:keywords set to `Id`
File size: 27.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	!! 4.0 ! 2010-08 ( C. Ethe, J. Deshayes ) Improvment
13	!!----------------------------------------------------------------------
14
15	!!----------------------------------------------------------------------
16	!! dia_ptr : Poleward Transport Diagnostics module
17	!! dia_ptr_init : Initialization, namelist read
18	!! ptr_sjk : "zonal" mean computation of a field - tracer or flux array
19	!! ptr_sj : "zonal" and vertical sum computation of a "meridional" flux array
20	!! (Generic interface to ptr_sj_3d, ptr_sj_2d)
21	!!----------------------------------------------------------------------
22	USE oce ! ocean dynamics and active tracers
23	USE dom_oce ! ocean space and time domain
24	USE phycst ! physical constants
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 memogcm
41	PUBLIC dia_ptr ! call in step module
42	PUBLIC dia_ptr_hst ! called from tra_ldf/tra_adv routines
43
44	! !! namelist namptr
45	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.)
46	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional)
47
48	LOGICAL , PUBLIC :: l_diaptr !: tracers trend flag (set from namelist in trdini)
49	INTEGER, PARAMETER, PUBLIC :: nptr = 5 ! (glo, atl, pac, ind, ipc)
50
51	REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup
52	REAL(wp) :: rc_pwatt = 1.e-15_wp ! conversion from W to PW (further x rau0 x Cp)
53	REAL(wp) :: rc_ggram = 1.e-9_wp ! conversion from g to Gg (further x rau0)
54
55	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks
56	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S)
57
58	REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:) :: p_fval1d
59	REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d
60
61	LOGICAL :: ll_init = .TRUE. !: tracers trend flag (set from namelist in trdini)
62	!! * Substitutions
63	# include "vectopt_loop_substitute.h90"
64	!!----------------------------------------------------------------------
65	!! NEMO/OCE 4.0 , NEMO Consortium (2018)
66	!! $Id$
67	!! Software governed by the CeCILL license (see ./LICENSE)
68	!!----------------------------------------------------------------------
69	CONTAINS
70
71	SUBROUTINE dia_ptr( kt, pvtr )
72	!!----------------------------------------------------------------------
73	!! * ROUTINE dia_ptr *
74	!!----------------------------------------------------------------------
75	INTEGER, INTENT( in ) :: kt ! ocean time-step index
76	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport
77	!
78	INTEGER :: ji, jj, jk, jn ! dummy loop indices
79	REAL(wp) :: zsfc,zvfc ! local scalar
80	REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace
81	REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask ! 3D workspace
82	REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace
83	REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace
84	REAL(wp), DIMENSION(jpj) :: zvsum, ztsum, zssum ! 1D workspace
85	!
86	!overturning calculation
87	REAL(wp), DIMENSION(jpj,jpk,nptr) :: sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse
88	REAL(wp), DIMENSION(jpj,jpk,nptr) :: zt_jk, zs_jk ! i-mean T and S, j-Stream-Function
89
90	REAL(wp), DIMENSION(jpi,jpj,jpk,nptr) :: z4d1, z4d2
91	REAL(wp), DIMENSION(jpi,jpj,nptr) :: z3dtr ! i-mean T and S, j-Stream-Function
92	!!----------------------------------------------------------------------
93	!
94	IF( ln_timing ) CALL timing_start('dia_ptr')
95
96	IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init
97	!
98	IF( .NOT. l_diaptr ) RETURN
99
100	IF( PRESENT( pvtr ) ) THEN
101	IF( iom_use( 'zomsf' ) ) THEN ! effective MSF
102	DO jn = 1, nptr ! by sub-basins
103	z4d1(1,:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) ! zonal cumulative effective transport excluding closed seas
104	DO jk = jpkm1, 1, -1
105	z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn) ! effective j-Stream-Function (MSF)
106	END DO
107	DO ji = 1, jpi
108	z4d1(ji,:,:,jn) = z4d1(1,:,:,jn)
109	ENDDO
110	END DO
111	CALL iom_put( 'zomsf', z4d1 * rc_sv )
112	ENDIF
113	IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. &
114	& iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN
115	! define fields multiplied by scalar
116	zmask(:,:,:) = 0._wp
117	zts(:,:,:,:) = 0._wp
118	DO jk = 1, jpkm1
119	DO jj = 1, jpjm1
120	DO ji = 1, jpi
121	zvfc = e1v(ji,jj) * e3v_n(ji,jj,jk)
122	zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc
123	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
124	zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc
125	ENDDO
126	ENDDO
127	ENDDO
128	ENDIF
129	IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN
130	DO jn = 1, nptr
131	sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
132	r1_sjk(:,:,jn) = 0._wp
133	WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn)
134	! i-mean T and S, j-Stream-Function, basin
135	zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
136	zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
137	v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) )
138	hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 )
139	hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 )
140	!
141	ENDDO
142	DO jn = 1, nptr
143	z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
144	DO ji = 1, jpi
145	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
146	ENDDO
147	ENDDO
148	CALL iom_put( 'sophtove', z3dtr )
149	DO jn = 1, nptr
150	z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
151	DO ji = 1, jpi
152	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
153	ENDDO
154	ENDDO
155	CALL iom_put( 'sopstove', z3dtr )
156	ENDIF
157
158	IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN
159	! Calculate barotropic heat and salt transport here
160	DO jn = 1, nptr
161	sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) )
162	r1_sjk(:,1,jn) = 0._wp
163	WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn)
164	!
165	zvsum(:) = ptr_sj( pvtr(:,:,:), btmsk34(:,:,jn) )
166	ztsum(:) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) )
167	zssum(:) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) )
168	hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn)
169	hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn)
170	!
171	ENDDO
172	DO jn = 1, nptr
173	z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
174	DO ji = 1, jpi
175	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
176	ENDDO
177	ENDDO
178	CALL iom_put( 'sophtbtr', z3dtr )
179	DO jn = 1, nptr
180	z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
181	DO ji = 1, jpi
182	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
183	ENDDO
184	ENDDO
185	CALL iom_put( 'sopstbtr', z3dtr )
186	ENDIF
187	!
188	ELSE
189	!
190	zmask(:,:,:) = 0._wp
191	zts(:,:,:,:) = 0._wp
192	IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface
193	DO jk = 1, jpkm1
194	DO jj = 1, jpj
195	DO ji = 1, jpi
196	zsfc = e1t(ji,jj) * e3t_n(ji,jj,jk)
197	zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc
198	zts(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * zsfc
199	zts(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * zsfc
200	END DO
201	END DO
202	END DO
203	!
204	DO jn = 1, nptr
205	zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
206	z4d1(:,:,:,jn) = zmask(:,:,:)
207	ENDDO
208	CALL iom_put( 'zosrf', z4d1 )
209	!
210	DO jn = 1, nptr
211	z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) &
212	& / MAX( z4d1(1,:,:,jn), 10.e-15 )
213	DO ji = 1, jpi
214	z4d2(ji,:,:,jn) = z4d2(1,:,:,jn)
215	ENDDO
216	ENDDO
217	CALL iom_put( 'zotem', z4d2 )
218	!
219	DO jn = 1, nptr
220	z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) &
221	& / MAX( z4d1(1,:,:,jn), 10.e-15 )
222	DO ji = 1, jpi
223	z4d2(ji,:,:,jn) = z4d2(1,:,:,jn)
224	ENDDO
225	ENDDO
226	CALL iom_put( 'zosal', z4d2 )
227	!
228	ENDIF
229	!
230	! ! Advective and diffusive heat and salt transport
231	IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN
232	!
233	DO jn = 1, nptr
234	z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
235	DO ji = 1, jpi
236	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
237	ENDDO
238	ENDDO
239	CALL iom_put( 'sophtadv', z3dtr )
240	DO jn = 1, nptr
241	z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
242	DO ji = 1, jpi
243	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
244	ENDDO
245	ENDDO
246	CALL iom_put( 'sopstadv', z3dtr )
247	ENDIF
248	!
249	IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN
250	!
251	DO jn = 1, nptr
252	z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
253	DO ji = 1, jpi
254	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
255	ENDDO
256	ENDDO
257	CALL iom_put( 'sophtldf', z3dtr )
258	DO jn = 1, nptr
259	z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
260	DO ji = 1, jpi
261	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
262	ENDDO
263	ENDDO
264	CALL iom_put( 'sopstldf', z3dtr )
265	ENDIF
266	!
267	IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN
268	!
269	DO jn = 1, nptr
270	z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
271	DO ji = 1, jpi
272	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
273	ENDDO
274	ENDDO
275	CALL iom_put( 'sophteiv', z3dtr )
276	DO jn = 1, nptr
277	z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
278	DO ji = 1, jpi
279	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
280	ENDDO
281	ENDDO
282	CALL iom_put( 'sopsteiv', z3dtr )
283	ENDIF
284	!
285	IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN
286	zts(:,:,:,:) = 0._wp
287	DO jk = 1, jpkm1
288	DO jj = 1, jpjm1
289	DO ji = 1, jpi
290	zvfc = e1v(ji,jj) * e3v_n(ji,jj,jk)
291	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
292	zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc
293	ENDDO
294	ENDDO
295	ENDDO
296	CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) )
297	CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) )
298	DO jn = 1, nptr
299	z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
300	DO ji = 1, jpi
301	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
302	ENDDO
303	ENDDO
304	CALL iom_put( 'sophtvtr', z3dtr )
305	DO jn = 1, nptr
306	z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
307	DO ji = 1, jpi
308	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
309	ENDDO
310	ENDDO
311	CALL iom_put( 'sopstvtr', z3dtr )
312	ENDIF
313	!
314	IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN
315	CALL iom_get_var( 'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml
316	z2d(:,:) = ptr_ci_2d( z2d(:,:) )
317	CALL iom_put( 'uocetr_vsum_cumul', z2d )
318	ENDIF
319	!
320	ENDIF
321	!
322	IF( ln_timing ) CALL timing_stop('dia_ptr')
323	!
324	END SUBROUTINE dia_ptr
325
326
327	SUBROUTINE dia_ptr_init
328	!!----------------------------------------------------------------------
329	!! * ROUTINE dia_ptr_init *
330	!!
331	!! ** Purpose : Initialization, namelist read
332	!!----------------------------------------------------------------------
333	INTEGER :: inum, jn ! local integers
334	!!
335	REAL(wp), DIMENSION(jpi,jpj) :: zmsk
336	!!----------------------------------------------------------------------
337
338	l_diaptr = .FALSE.
339	IF( iom_use( 'zomsf' ) .OR. iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. &
340	& iom_use( 'zosrf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. &
341	& iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR. &
342	& iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. &
343	& iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR. &
344	& iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' ) ) l_diaptr = .TRUE.
345
346
347	IF(lwp) THEN ! Control print
348	WRITE(numout,*)
349	WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
350	WRITE(numout,*) '~~~~~~~~~~~~'
351	WRITE(numout,*) ' Namelist namptr : set ptr parameters'
352	WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) l_diaptr = ', l_diaptr
353	ENDIF
354
355	IF( l_diaptr ) THEN
356	!
357	IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' )
358
359	rc_pwatt = rc_pwatt * rau0_rcp ! conversion from K.s-1 to PetaWatt
360	rc_ggram = rc_ggram * rau0 ! conversion from m3/s to Gg/s
361
362	IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum
363
364	btmsk(:,:,1) = tmask_i(:,:)
365	CALL iom_open( 'subbasins', inum, ldstop = .FALSE. )
366	CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin
367	CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin
368	CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin
369	CALL iom_close( inum )
370	btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin
371	DO jn = 2, nptr
372	btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only
373	END DO
374	! JD : modification so that overturning streamfunction is available in Atlantic at 34S to compare with observations
375	WHERE( gphit(:,:)*tmask_i(:,:) < -34._wp)
376	zmsk(:,:) = 0._wp ! mask out Southern Ocean
377	ELSE WHERE
378	zmsk(:,:) = ssmask(:,:)
379	END WHERE
380	btmsk34(:,:,1) = btmsk(:,:,1)
381	DO jn = 2, nptr
382	btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:) ! interior domain only
383	ENDDO
384
385	! Initialise arrays to zero because diatpr is called before they are first calculated
386	! Note that this means diagnostics will not be exactly correct when model run is restarted.
387	hstr_adv(:,:,:) = 0._wp
388	hstr_ldf(:,:,:) = 0._wp
389	hstr_eiv(:,:,:) = 0._wp
390	hstr_ove(:,:,:) = 0._wp
391	hstr_btr(:,:,:) = 0._wp !
392	hstr_vtr(:,:,:) = 0._wp !
393	!
394	ll_init = .FALSE.
395	!
396	ENDIF
397	!
398	END SUBROUTINE dia_ptr_init
399
400
401	SUBROUTINE dia_ptr_hst( ktra, cptr, pva )
402	!!----------------------------------------------------------------------
403	!! * ROUTINE dia_ptr_hst *
404	!!----------------------------------------------------------------------
405	!! Wrapper for heat and salt transport calculations to calculate them for each basin
406	!! Called from all advection and/or diffusion routines
407	!!----------------------------------------------------------------------
408	INTEGER , INTENT(in ) :: ktra ! tracer index
409	CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv'
410	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pva ! 3D input array of advection/diffusion
411	INTEGER :: jn !
412
413	!
414	IF( cptr == 'adv' ) THEN
415	IF( ktra == jp_tem ) THEN
416	DO jn = 1, nptr
417	hstr_adv(:,jp_tem,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
418	ENDDO
419	ENDIF
420	IF( ktra == jp_sal ) THEN
421	DO jn = 1, nptr
422	hstr_adv(:,jp_sal,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
423	ENDDO
424	ENDIF
425	ENDIF
426	!
427	IF( cptr == 'ldf' ) THEN
428	IF( ktra == jp_tem ) THEN
429	DO jn = 1, nptr
430	hstr_ldf(:,jp_tem,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
431	ENDDO
432	ENDIF
433	IF( ktra == jp_sal ) THEN
434	DO jn = 1, nptr
435	hstr_ldf(:,jp_sal,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
436	ENDDO
437	ENDIF
438	ENDIF
439	!
440	IF( cptr == 'eiv' ) THEN
441	IF( ktra == jp_tem ) THEN
442	DO jn = 1, nptr
443	hstr_eiv(:,jp_tem,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
444	ENDDO
445	ENDIF
446	IF( ktra == jp_sal ) THEN
447	DO jn = 1, nptr
448	hstr_eiv(:,jp_sal,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
449	ENDDO
450	ENDIF
451	ENDIF
452	!
453	IF( cptr == 'vtr' ) THEN
454	IF( ktra == jp_tem ) THEN
455	DO jn = 1, nptr
456	hstr_vtr(:,jp_tem,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
457	ENDDO
458	ENDIF
459	IF( ktra == jp_sal ) THEN
460	DO jn = 1, nptr
461	hstr_vtr(:,jp_sal,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
462	ENDDO
463	ENDIF
464	ENDIF
465	!
466	END SUBROUTINE dia_ptr_hst
467
468
469	FUNCTION dia_ptr_alloc()
470	!!----------------------------------------------------------------------
471	!! * ROUTINE dia_ptr_alloc *
472	!!----------------------------------------------------------------------
473	INTEGER :: dia_ptr_alloc ! return value
474	INTEGER, DIMENSION(3) :: ierr
475	!!----------------------------------------------------------------------
476	ierr(:) = 0
477	!
478	IF( .NOT. ALLOCATED( btmsk ) ) THEN
479	ALLOCATE( btmsk(jpi,jpj,nptr) , btmsk34(jpi,jpj,nptr), &
480	& hstr_adv(jpj,jpts,nptr), hstr_eiv(jpj,jpts,nptr), &
481	& hstr_ove(jpj,jpts,nptr), hstr_btr(jpj,jpts,nptr), &
482	& hstr_ldf(jpj,jpts,nptr), hstr_vtr(jpj,jpts,nptr), STAT=ierr(1) )
483	!
484	ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2))
485	!
486	dia_ptr_alloc = MAXVAL( ierr )
487	CALL mpp_sum( 'diaptr', dia_ptr_alloc )
488	ENDIF
489	!
490	END FUNCTION dia_ptr_alloc
491
492
493	FUNCTION ptr_sj_3d( pva, pmsk ) RESULT ( p_fval )
494	!!----------------------------------------------------------------------
495	!! * ROUTINE ptr_sj_3d *
496	!!
497	!! ** Purpose : i-k sum computation of a j-flux array
498	!!
499	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
500	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
501	!!
502	!! ** Action : - p_fval: i-k-mean poleward flux of pva
503	!!----------------------------------------------------------------------
504	REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point
505	REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask
506	!
507	INTEGER :: ji, jj, jk ! dummy loop arguments
508	INTEGER :: ijpj ! ???
509	REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
510	!!--------------------------------------------------------------------
511	!
512	p_fval => p_fval1d
513
514	ijpj = jpj
515	p_fval(:) = 0._wp
516	DO jk = 1, jpkm1
517	DO jj = 2, jpjm1
518	DO ji = fs_2, fs_jpim1 ! Vector opt.
519	p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj)
520	END DO
521	END DO
522	END DO
523	#if defined key_mpp_mpi
524	CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl)
525	#endif
526	!
527	END FUNCTION ptr_sj_3d
528
529
530	FUNCTION ptr_sj_2d( pva, pmsk ) RESULT ( p_fval )
531	!!----------------------------------------------------------------------
532	!! * ROUTINE ptr_sj_2d *
533	!!
534	!! ** Purpose : "zonal" and vertical sum computation of a i-flux array
535	!!
536	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
537	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
538	!!
539	!! ** Action : - p_fval: i-k-mean poleward flux of pva
540	!!----------------------------------------------------------------------
541	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point
542	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask
543	!
544	INTEGER :: ji,jj ! dummy loop arguments
545	INTEGER :: ijpj ! ???
546	REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
547	!!--------------------------------------------------------------------
548	!
549	p_fval => p_fval1d
550
551	ijpj = jpj
552	p_fval(:) = 0._wp
553	DO jj = 2, jpjm1
554	DO ji = fs_2, fs_jpim1 ! Vector opt.
555	p_fval(jj) = p_fval(jj) + pva(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj)
556	END DO
557	END DO
558	#if defined key_mpp_mpi
559	CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl )
560	#endif
561	!
562	END FUNCTION ptr_sj_2d
563
564	FUNCTION ptr_ci_2d( pva ) RESULT ( p_fval )
565	!!----------------------------------------------------------------------
566	!! * ROUTINE ptr_ci_2d *
567	!!
568	!! ** Purpose : "meridional" cumulated sum computation of a j-flux array
569	!!
570	!! ** Method : - j cumulated sum of pva using the interior 2D vmask (umask_i).
571	!!
572	!! ** Action : - p_fval: j-cumulated sum of pva
573	!!----------------------------------------------------------------------
574	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point
575	!
576	INTEGER :: ji,jj,jc ! dummy loop arguments
577	INTEGER :: ijpj ! ???
578	REAL(wp), DIMENSION(jpi,jpj) :: p_fval ! function value
579	!!--------------------------------------------------------------------
580	!
581	ijpj = jpj ! ???
582	p_fval(:,:) = 0._wp
583	DO jc = 1, jpnj ! looping over all processors in j axis
584	DO jj = 2, jpjm1
585	DO ji = fs_2, fs_jpim1 ! Vector opt.
586	p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj)
587	END DO
588	END DO
589	CALL lbc_lnk( 'diaptr', p_fval, 'U', -1. )
590	END DO
591	!
592	END FUNCTION ptr_ci_2d
593
594
595
596	FUNCTION ptr_sjk( pta, pmsk ) RESULT ( p_fval )
597	!!----------------------------------------------------------------------
598	!! * ROUTINE ptr_sjk *
599	!!
600	!! ** Purpose : i-sum computation of an array
601	!!
602	!! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i).
603	!!
604	!! ** Action : - p_fval: i-mean poleward flux of pva
605	!!----------------------------------------------------------------------
606	!!
607	IMPLICIT none
608	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! mask flux array at V-point
609	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask
610	!!
611	INTEGER :: ji, jj, jk ! dummy loop arguments
612	REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value
613	#if defined key_mpp_mpi
614	INTEGER, DIMENSION(1) :: ish
615	INTEGER, DIMENSION(2) :: ish2
616	INTEGER :: ijpjjpk
617	REAL(wp), DIMENSION(jpj*jpk) :: zwork ! mask flux array at V-point
618	#endif
619	!!--------------------------------------------------------------------
620	!
621	p_fval => p_fval2d
622
623	p_fval(:,:) = 0._wp
624	!
625	DO jk = 1, jpkm1
626	DO jj = 2, jpjm1
627	DO ji = fs_2, fs_jpim1 ! Vector opt.
628	p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj)
629	END DO
630	END DO
631	END DO
632	!
633	#if defined key_mpp_mpi
634	ijpjjpk = jpj*jpk
635	ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk
636	zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )
637	CALL mpp_sum( 'diaptr', zwork, ijpjjpk, ncomm_znl )
638	p_fval(:,:) = RESHAPE( zwork, ish2 )
639	#endif
640	!
641	END FUNCTION ptr_sjk
642
643
644	!!======================================================================
645	END MODULE diaptr

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

Download in other formats: