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_r11943_MERGE_2019/src/OCE/DIA – NEMO

Context Navigation

source: NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/DIA/diaptr.F90 @ 12193

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

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

Download in other formats: