Context Navigation

diaptr.F90 @ 12377

Last change on this file since 12377 was 12377, checked in by acc, 4 years ago

The big one. Merging all 2019 developments from the option 1 branch back onto the trunk.

This changeset reproduces 2019/dev_r11943_MERGE_2019 on the trunk using a 2-URL merge
onto a working copy of the trunk. I.e.:

svn merge --ignore-ancestry \

svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/trunk \
svn+ssh://acc@forge.ipsl.jussieu.fr/ipsl/forge/projets/nemo/svn/NEMO/branches/2019/dev_r11943_MERGE_2019 ./

The --ignore-ancestry flag avoids problems that may otherwise arise from the fact that
the merge history been trunk and branch may have been applied in a different order but
care has been taken before this step to ensure that all applicable fixes and updates
are present in the merge branch.

The trunk state just before this step has been branched to releases/release-4.0-HEAD
and that branch has been immediately tagged as releases/release-4.0.2. Any fixes
or additions in response to tickets on 4.0, 4.0.1 or 4.0.2 should be done on
releases/release-4.0-HEAD. From now on future 'point' releases (e.g. 4.0.2) will
remain unchanged with periodic releases as needs demand. Note release-4.0-HEAD is a
transitional naming convention. Future full releases, say 4.2, will have a release-4.2
branch which fulfills this role and the first point release (e.g. 4.2.0) will be made
immediately following the release branch creation.

2020 developments can be started from any trunk revision later than this one.

Property svn:keywords set to Id

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

Download in other formats: