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

Context Navigation

source: NEMO/trunk/src/OCE/DIA/diaptr.F90 @ 13557

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

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

Download in other formats: