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_r11613_ENHANCE-04_namelists_as_internalfiles/src/OCE/DIA – NEMO

Context Navigation

source: NEMO/branches/2019/dev_r11613_ENHANCE-04_namelists_as_internalfiles/src/OCE/DIA/diaptr.F90 @ 11671

Last change on this file since 11671 was 11671, checked in by acc, 5 years ago
Branch 2019/dev_r11613_ENHANCE-04_namelists_as_internalfiles. Final, non-substantive changes to complete this branch. These changes remove all REWIND statements on the old namelist fortran units (now character variables for internal files). These changes have been left until last since they are easily repeated via a script and it may be preferable to use the previous revision for merge purposes and reapply these last changes separately. This branch has been fully SETTE tested.
Property svn:keywords set to `Id`
File size: 30.0 KB

Line
1	MODULE diaptr
2	!!======================================================================
3	!! * MODULE diaptr *
4	!! Ocean physics: Computes meridonal transports and zonal means
5	!!=====================================================================
6	!! History : 1.0 ! 2003-09 (C. Talandier, G. Madec) Original code
7	!! 2.0 ! 2006-01 (A. Biastoch) Allow sub-basins computation
8	!! 3.2 ! 2010-03 (O. Marti, S. Flavoni) Add fields
9	!! 3.3 ! 2010-10 (G. Madec) dynamical allocation
10	!! 3.6 ! 2014-12 (C. Ethe) use of IOM
11	!! 3.6 ! 2016-06 (T. Graham) Addition of diagnostics for CMIP6
12	!!----------------------------------------------------------------------
13
14	!!----------------------------------------------------------------------
15	!! dia_ptr : Poleward Transport Diagnostics module
16	!! dia_ptr_init : Initialization, namelist read
17	!! ptr_sjk : "zonal" mean computation of a field - tracer or flux array
18	!! ptr_sj : "zonal" and vertical sum computation of a "meridional" flux array
19	!! (Generic interface to ptr_sj_3d, ptr_sj_2d)
20	!!----------------------------------------------------------------------
21	USE oce ! ocean dynamics and active tracers
22	USE dom_oce ! ocean space and time domain
23	USE phycst ! physical constants
24	!
25	USE iom ! IOM library
26	USE in_out_manager ! I/O manager
27	USE lib_mpp ! MPP library
28	USE timing ! preformance summary
29
30	IMPLICIT NONE
31	PRIVATE
32
33	INTERFACE ptr_sj
34	MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d
35	END INTERFACE
36
37	PUBLIC ptr_sj ! call by tra_ldf & tra_adv routines
38	PUBLIC ptr_sjk !
39	PUBLIC dia_ptr_init ! call in memogcm
40	PUBLIC dia_ptr ! call in step module
41	PUBLIC dia_ptr_hst ! called from tra_ldf/tra_adv routines
42
43	! !! namelist namptr
44	REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_adv, htr_ldf, htr_eiv !: Heat TRansports (adv, diff, Bolus.)
45	REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: str_adv, str_ldf, str_eiv !: Salt TRansports (adv, diff, Bolus.)
46	REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_ove, str_ove !: heat Salt TRansports ( overturn.)
47	REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:,:) :: htr_btr, str_btr !: heat Salt TRansports ( barotropic )
48
49	LOGICAL, PUBLIC :: ln_diaptr ! Poleward transport flag (T) or not (F)
50	LOGICAL, PUBLIC :: ln_subbas ! Atlantic/Pacific/Indian basins calculation
51	INTEGER, PUBLIC :: nptr ! = 1 (l_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (l_subbas=T)
52
53	REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup
54	REAL(wp) :: rc_pwatt = 1.e-15_wp ! conversion from W to PW (further x rau0 x Cp)
55	REAL(wp) :: rc_ggram = 1.e-6_wp ! conversion from g to Pg
56
57	CHARACTER(len=3), ALLOCATABLE, SAVE, DIMENSION(:) :: clsubb
58	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks
59	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: btm30 ! mask out Southern Ocean (=0 south of 30°S)
60
61	REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:) :: p_fval1d
62	REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d
63
64	!! * Substitutions
65	# include "vectopt_loop_substitute.h90"
66	!!----------------------------------------------------------------------
67	!! NEMO/OCE 4.0 , NEMO Consortium (2018)
68	!! $Id$
69	!! Software governed by the CeCILL license (see ./LICENSE)
70	!!----------------------------------------------------------------------
71	CONTAINS
72
73	SUBROUTINE dia_ptr( pvtr )
74	!!----------------------------------------------------------------------
75	!! * ROUTINE dia_ptr *
76	!!----------------------------------------------------------------------
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) :: z3d ! 3D workspace
83	REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask ! 3D workspace
84	REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace
85	REAL(wp), DIMENSION(jpj) :: vsum ! 1D workspace
86	REAL(wp), DIMENSION(jpj,jpts) :: tssum ! 1D workspace
87
88	!
89	!overturning calculation
90	REAL(wp), DIMENSION(jpj,jpk,nptr) :: sjk , r1_sjk ! i-mean i-k-surface and its inverse
91	REAL(wp), DIMENSION(jpj,jpk,nptr) :: v_msf, sn_jk , tn_jk ! i-mean T and S, j-Stream-Function
92	REAL(wp), DIMENSION(jpi,jpj,jpk) :: zvn ! 3D workspace
93
94
95	CHARACTER( len = 12 ) :: cl1
96	!!----------------------------------------------------------------------
97	!
98	IF( ln_timing ) CALL timing_start('dia_ptr')
99
100	!
101	IF( PRESENT( pvtr ) ) THEN
102	IF( iom_use("zomsfglo") ) THEN ! effective MSF
103	z3d(1,:,:) = ptr_sjk( pvtr(:,:,:) ) ! zonal cumulative effective transport
104	DO jk = 2, jpkm1
105	z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk) ! effective j-Stream-Function (MSF)
106	END DO
107	DO ji = 1, jpi
108	z3d(ji,:,:) = z3d(1,:,:)
109	ENDDO
110	cl1 = TRIM('zomsf'//clsubb(1) )
111	CALL iom_put( cl1, z3d * rc_sv )
112	DO jn = 2, nptr ! by sub-basins
113	z3d(1,:,:) = ptr_sjk( pvtr(:,:,:), btmsk(:,:,jn)*btm30(:,:) )
114	DO jk = 2, jpkm1
115	z3d(1,:,jk) = z3d(1,:,jk-1) + z3d(1,:,jk) ! effective j-Stream-Function (MSF)
116	END DO
117	DO ji = 1, jpi
118	z3d(ji,:,:) = z3d(1,:,:)
119	ENDDO
120	cl1 = TRIM('zomsf'//clsubb(jn) )
121	CALL iom_put( cl1, z3d * rc_sv )
122	END DO
123	ENDIF
124	IF( iom_use("sopstove") .OR. iom_use("sophtove") .OR. iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN
125	! define fields multiplied by scalar
126	zmask(:,:,:) = 0._wp
127	zts(:,:,:,:) = 0._wp
128	zvn(:,:,:) = 0._wp
129	DO jk = 1, jpkm1
130	DO jj = 1, jpjm1
131	DO ji = 1, jpi
132	zvfc = e1v(ji,jj) * e3v_n(ji,jj,jk)
133	zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc
134	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
135	zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc
136	zvn(ji,jj,jk) = vn(ji,jj,jk) * zvfc
137	ENDDO
138	ENDDO
139	ENDDO
140	ENDIF
141	IF( iom_use("sopstove") .OR. iom_use("sophtove") ) THEN
142	sjk(:,:,1) = ptr_sjk( zmask(:,:,:), btmsk(:,:,1) )
143	r1_sjk(:,:,1) = 0._wp
144	WHERE( sjk(:,:,1) /= 0._wp ) r1_sjk(:,:,1) = 1._wp / sjk(:,:,1)
145
146	! i-mean T and S, j-Stream-Function, global
147	tn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_tem) ) * r1_sjk(:,:,1)
148	sn_jk(:,:,1) = ptr_sjk( zts(:,:,:,jp_sal) ) * r1_sjk(:,:,1)
149	v_msf(:,:,1) = ptr_sjk( zvn(:,:,:) )
150
151	htr_ove(:,1) = SUM( v_msf(:,:,1)*tn_jk(:,:,1) ,2 )
152	str_ove(:,1) = SUM( v_msf(:,:,1)*sn_jk(:,:,1) ,2 )
153
154	z2d(1,:) = htr_ove(:,1) * rc_pwatt ! (conversion in PW)
155	DO ji = 1, jpi
156	z2d(ji,:) = z2d(1,:)
157	ENDDO
158	cl1 = 'sophtove'
159	CALL iom_put( TRIM(cl1), z2d )
160	z2d(1,:) = str_ove(:,1) * rc_ggram ! (conversion in Gg)
161	DO ji = 1, jpi
162	z2d(ji,:) = z2d(1,:)
163	ENDDO
164	cl1 = 'sopstove'
165	CALL iom_put( TRIM(cl1), z2d )
166	IF( ln_subbas ) THEN
167	DO jn = 2, nptr
168	sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
169	r1_sjk(:,:,jn) = 0._wp
170	WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn)
171
172	! i-mean T and S, j-Stream-Function, basin
173	tn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
174	sn_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
175	v_msf(:,:,jn) = ptr_sjk( zvn(:,:,:), btmsk(:,:,jn) )
176	htr_ove(:,jn) = SUM( v_msf(:,:,jn)*tn_jk(:,:,jn) ,2 )
177	str_ove(:,jn) = SUM( v_msf(:,:,jn)*sn_jk(:,:,jn) ,2 )
178
179	z2d(1,:) = htr_ove(:,jn) * rc_pwatt ! (conversion in PW)
180	DO ji = 1, jpi
181	z2d(ji,:) = z2d(1,:)
182	ENDDO
183	cl1 = TRIM('sophtove_'//clsubb(jn))
184	CALL iom_put( cl1, z2d )
185	z2d(1,:) = str_ove(:,jn) * rc_ggram ! (conversion in Gg)
186	DO ji = 1, jpi
187	z2d(ji,:) = z2d(1,:)
188	ENDDO
189	cl1 = TRIM('sopstove_'//clsubb(jn))
190	CALL iom_put( cl1, z2d )
191	END DO
192	ENDIF
193	ENDIF
194	IF( iom_use("sopstbtr") .OR. iom_use("sophtbtr") ) THEN
195	! Calculate barotropic heat and salt transport here
196	sjk(:,1,1) = ptr_sj( zmask(:,:,:), btmsk(:,:,1) )
197	r1_sjk(:,1,1) = 0._wp
198	WHERE( sjk(:,1,1) /= 0._wp ) r1_sjk(:,1,1) = 1._wp / sjk(:,1,1)
199
200	vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,1))
201	tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,1) )
202	tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,1) )
203	htr_btr(:,1) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,1)
204	str_btr(:,1) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,1)
205	z2d(1,:) = htr_btr(:,1) * rc_pwatt ! (conversion in PW)
206	DO ji = 2, jpi
207	z2d(ji,:) = z2d(1,:)
208	ENDDO
209	cl1 = 'sophtbtr'
210	CALL iom_put( TRIM(cl1), z2d )
211	z2d(1,:) = str_btr(:,1) * rc_ggram ! (conversion in Gg)
212	DO ji = 2, jpi
213	z2d(ji,:) = z2d(1,:)
214	ENDDO
215	cl1 = 'sopstbtr'
216	CALL iom_put( TRIM(cl1), z2d )
217	IF( ln_subbas ) THEN
218	DO jn = 2, nptr
219	sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) )
220	r1_sjk(:,1,jn) = 0._wp
221	WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn)
222	vsum = ptr_sj( zvn(:,:,:), btmsk(:,:,jn))
223	tssum(:,jp_tem) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) )
224	tssum(:,jp_sal) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) )
225	htr_btr(:,jn) = vsum * tssum(:,jp_tem) * r1_sjk(:,1,jn)
226	str_btr(:,jn) = vsum * tssum(:,jp_sal) * r1_sjk(:,1,jn)
227	z2d(1,:) = htr_btr(:,jn) * rc_pwatt ! (conversion in PW)
228	DO ji = 1, jpi
229	z2d(ji,:) = z2d(1,:)
230	ENDDO
231	cl1 = TRIM('sophtbtr_'//clsubb(jn))
232	CALL iom_put( cl1, z2d )
233	z2d(1,:) = str_btr(:,jn) * rc_ggram ! (conversion in Gg)
234	DO ji = 1, jpi
235	z2d(ji,:) = z2d(1,:)
236	ENDDO
237	cl1 = TRIM('sopstbtr_'//clsubb(jn))
238	CALL iom_put( cl1, z2d )
239	ENDDO
240	ENDIF !ln_subbas
241	ENDIF !iom_use("sopstbtr....)
242	!
243	ELSE
244	!
245	IF( iom_use("zotemglo") ) THEN ! i-mean i-k-surface
246	DO jk = 1, jpkm1
247	DO jj = 1, jpj
248	DO ji = 1, jpi
249	zsfc = e1t(ji,jj) * e3t_n(ji,jj,jk)
250	zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc
251	zts(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * zsfc
252	zts(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * zsfc
253	END DO
254	END DO
255	END DO
256	DO jn = 1, nptr
257	zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
258	cl1 = TRIM('zosrf'//clsubb(jn) )
259	CALL iom_put( cl1, zmask )
260	!
261	z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) &
262	& / MAX( zmask(1,:,:), 10.e-15 )
263	DO ji = 1, jpi
264	z3d(ji,:,:) = z3d(1,:,:)
265	ENDDO
266	cl1 = TRIM('zotem'//clsubb(jn) )
267	CALL iom_put( cl1, z3d )
268	!
269	z3d(1,:,:) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) &
270	& / MAX( zmask(1,:,:), 10.e-15 )
271	DO ji = 1, jpi
272	z3d(ji,:,:) = z3d(1,:,:)
273	ENDDO
274	cl1 = TRIM('zosal'//clsubb(jn) )
275	CALL iom_put( cl1, z3d )
276	END DO
277	ENDIF
278	!
279	! ! Advective and diffusive heat and salt transport
280	IF( iom_use("sophtadv") .OR. iom_use("sopstadv") ) THEN
281	z2d(1,:) = htr_adv(:,1) * rc_pwatt ! (conversion in PW)
282	DO ji = 1, jpi
283	z2d(ji,:) = z2d(1,:)
284	ENDDO
285	cl1 = 'sophtadv'
286	CALL iom_put( TRIM(cl1), z2d )
287	z2d(1,:) = str_adv(:,1) * rc_ggram ! (conversion in Gg)
288	DO ji = 1, jpi
289	z2d(ji,:) = z2d(1,:)
290	ENDDO
291	cl1 = 'sopstadv'
292	CALL iom_put( TRIM(cl1), z2d )
293	IF( ln_subbas ) THEN
294	DO jn=2,nptr
295	z2d(1,:) = htr_adv(:,jn) * rc_pwatt ! (conversion in PW)
296	DO ji = 1, jpi
297	z2d(ji,:) = z2d(1,:)
298	ENDDO
299	cl1 = TRIM('sophtadv_'//clsubb(jn))
300	CALL iom_put( cl1, z2d )
301	z2d(1,:) = str_adv(:,jn) * rc_ggram ! (conversion in Gg)
302	DO ji = 1, jpi
303	z2d(ji,:) = z2d(1,:)
304	ENDDO
305	cl1 = TRIM('sopstadv_'//clsubb(jn))
306	CALL iom_put( cl1, z2d )
307	ENDDO
308	ENDIF
309	ENDIF
310	!
311	IF( iom_use("sophtldf") .OR. iom_use("sopstldf") ) THEN
312	z2d(1,:) = htr_ldf(:,1) * rc_pwatt ! (conversion in PW)
313	DO ji = 1, jpi
314	z2d(ji,:) = z2d(1,:)
315	ENDDO
316	cl1 = 'sophtldf'
317	CALL iom_put( TRIM(cl1), z2d )
318	z2d(1,:) = str_ldf(:,1) * rc_ggram ! (conversion in Gg)
319	DO ji = 1, jpi
320	z2d(ji,:) = z2d(1,:)
321	ENDDO
322	cl1 = 'sopstldf'
323	CALL iom_put( TRIM(cl1), z2d )
324	IF( ln_subbas ) THEN
325	DO jn=2,nptr
326	z2d(1,:) = htr_ldf(:,jn) * rc_pwatt ! (conversion in PW)
327	DO ji = 1, jpi
328	z2d(ji,:) = z2d(1,:)
329	ENDDO
330	cl1 = TRIM('sophtldf_'//clsubb(jn))
331	CALL iom_put( cl1, z2d )
332	z2d(1,:) = str_ldf(:,jn) * rc_ggram ! (conversion in Gg)
333	DO ji = 1, jpi
334	z2d(ji,:) = z2d(1,:)
335	ENDDO
336	cl1 = TRIM('sopstldf_'//clsubb(jn))
337	CALL iom_put( cl1, z2d )
338	ENDDO
339	ENDIF
340	ENDIF
341
342	IF( iom_use("sophteiv") .OR. iom_use("sopsteiv") ) THEN
343	z2d(1,:) = htr_eiv(:,1) * rc_pwatt ! (conversion in PW)
344	DO ji = 1, jpi
345	z2d(ji,:) = z2d(1,:)
346	ENDDO
347	cl1 = 'sophteiv'
348	CALL iom_put( TRIM(cl1), z2d )
349	z2d(1,:) = str_eiv(:,1) * rc_ggram ! (conversion in Gg)
350	DO ji = 1, jpi
351	z2d(ji,:) = z2d(1,:)
352	ENDDO
353	cl1 = 'sopsteiv'
354	CALL iom_put( TRIM(cl1), z2d )
355	IF( ln_subbas ) THEN
356	DO jn=2,nptr
357	z2d(1,:) = htr_eiv(:,jn) * rc_pwatt ! (conversion in PW)
358	DO ji = 1, jpi
359	z2d(ji,:) = z2d(1,:)
360	ENDDO
361	cl1 = TRIM('sophteiv_'//clsubb(jn))
362	CALL iom_put( cl1, z2d )
363	z2d(1,:) = str_eiv(:,jn) * rc_ggram ! (conversion in Gg)
364	DO ji = 1, jpi
365	z2d(ji,:) = z2d(1,:)
366	ENDDO
367	cl1 = TRIM('sopsteiv_'//clsubb(jn))
368	CALL iom_put( cl1, z2d )
369	ENDDO
370	ENDIF
371	ENDIF
372	!
373	ENDIF
374	!
375	IF( ln_timing ) CALL timing_stop('dia_ptr')
376	!
377	END SUBROUTINE dia_ptr
378
379
380	SUBROUTINE dia_ptr_init
381	!!----------------------------------------------------------------------
382	!! * ROUTINE dia_ptr_init *
383	!!
384	!! ** Purpose : Initialization, namelist read
385	!!----------------------------------------------------------------------
386	INTEGER :: jn ! local integers
387	INTEGER :: inum, ierr ! local integers
388	INTEGER :: ios ! Local integer output status for namelist read
389	!!
390	NAMELIST/namptr/ ln_diaptr, ln_subbas
391	!!----------------------------------------------------------------------
392
393	READ ( numnam_ref, namptr, IOSTAT = ios, ERR = 901)
394	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist' )
395
396	READ ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 )
397	902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist' )
398	IF(lwm) WRITE ( numond, namptr )
399
400	IF(lwp) THEN ! Control print
401	WRITE(numout,*)
402	WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
403	WRITE(numout,*) '~~~~~~~~~~~~'
404	WRITE(numout,*) ' Namelist namptr : set ptr parameters'
405	WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) ln_diaptr = ', ln_diaptr
406	WRITE(numout,*) ' Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins ln_subbas = ', ln_subbas
407	ENDIF
408
409	IF( ln_diaptr ) THEN
410	!
411	IF( ln_subbas ) THEN
412	nptr = 5 ! Global, Atlantic, Pacific, Indian, Indo-Pacific
413	ALLOCATE( clsubb(nptr) )
414	clsubb(1) = 'glo' ; clsubb(2) = 'atl' ; clsubb(3) = 'pac' ; clsubb(4) = 'ind' ; clsubb(5) = 'ipc'
415	ELSE
416	nptr = 1 ! Global only
417	ALLOCATE( clsubb(nptr) )
418	clsubb(1) = 'glo'
419	ENDIF
420
421	! ! allocate dia_ptr arrays
422	IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' )
423
424	rc_pwatt = rc_pwatt * rau0_rcp ! conversion from K.s-1 to PetaWatt
425
426	IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum
427
428	IF( ln_subbas ) THEN ! load sub-basin mask
429	CALL iom_open( 'subbasins', inum, ldstop = .FALSE. )
430	CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin
431	CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin
432	CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin
433	CALL iom_close( inum )
434	btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin
435	WHERE( gphit(:,:) < -30._wp) ; btm30(:,:) = 0._wp ! mask out Southern Ocean
436	ELSE WHERE ; btm30(:,:) = ssmask(:,:)
437	END WHERE
438	ENDIF
439
440	btmsk(:,:,1) = tmask_i(:,:) ! global ocean
441
442	DO jn = 1, nptr
443	btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only
444	END DO
445
446	! Initialise arrays to zero because diatpr is called before they are first calculated
447	! Note that this means diagnostics will not be exactly correct when model run is restarted.
448	htr_adv(:,:) = 0._wp ; str_adv(:,:) = 0._wp
449	htr_ldf(:,:) = 0._wp ; str_ldf(:,:) = 0._wp
450	htr_eiv(:,:) = 0._wp ; str_eiv(:,:) = 0._wp
451	htr_ove(:,:) = 0._wp ; str_ove(:,:) = 0._wp
452	htr_btr(:,:) = 0._wp ; str_btr(:,:) = 0._wp
453	!
454	ENDIF
455	!
456	END SUBROUTINE dia_ptr_init
457
458
459	SUBROUTINE dia_ptr_hst( ktra, cptr, pva )
460	!!----------------------------------------------------------------------
461	!! * ROUTINE dia_ptr_hst *
462	!!----------------------------------------------------------------------
463	!! Wrapper for heat and salt transport calculations to calculate them for each basin
464	!! Called from all advection and/or diffusion routines
465	!!----------------------------------------------------------------------
466	INTEGER , INTENT(in ) :: ktra ! tracer index
467	CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv'
468	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pva ! 3D input array of advection/diffusion
469	INTEGER :: jn !
470
471	IF( cptr == 'adv' ) THEN
472	IF( ktra == jp_tem ) htr_adv(:,1) = ptr_sj( pva(:,:,:) )
473	IF( ktra == jp_sal ) str_adv(:,1) = ptr_sj( pva(:,:,:) )
474	ENDIF
475	IF( cptr == 'ldf' ) THEN
476	IF( ktra == jp_tem ) htr_ldf(:,1) = ptr_sj( pva(:,:,:) )
477	IF( ktra == jp_sal ) str_ldf(:,1) = ptr_sj( pva(:,:,:) )
478	ENDIF
479	IF( cptr == 'eiv' ) THEN
480	IF( ktra == jp_tem ) htr_eiv(:,1) = ptr_sj( pva(:,:,:) )
481	IF( ktra == jp_sal ) str_eiv(:,1) = ptr_sj( pva(:,:,:) )
482	ENDIF
483	!
484	IF( ln_subbas ) THEN
485	!
486	IF( cptr == 'adv' ) THEN
487	IF( ktra == jp_tem ) THEN
488	DO jn = 2, nptr
489	htr_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
490	END DO
491	ENDIF
492	IF( ktra == jp_sal ) THEN
493	DO jn = 2, nptr
494	str_adv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
495	END DO
496	ENDIF
497	ENDIF
498	IF( cptr == 'ldf' ) THEN
499	IF( ktra == jp_tem ) THEN
500	DO jn = 2, nptr
501	htr_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
502	END DO
503	ENDIF
504	IF( ktra == jp_sal ) THEN
505	DO jn = 2, nptr
506	str_ldf(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
507	END DO
508	ENDIF
509	ENDIF
510	IF( cptr == 'eiv' ) THEN
511	IF( ktra == jp_tem ) THEN
512	DO jn = 2, nptr
513	htr_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
514	END DO
515	ENDIF
516	IF( ktra == jp_sal ) THEN
517	DO jn = 2, nptr
518	str_eiv(:,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) )
519	END DO
520	ENDIF
521	ENDIF
522	!
523	ENDIF
524	END SUBROUTINE dia_ptr_hst
525
526
527	FUNCTION dia_ptr_alloc()
528	!!----------------------------------------------------------------------
529	!! * ROUTINE dia_ptr_alloc *
530	!!----------------------------------------------------------------------
531	INTEGER :: dia_ptr_alloc ! return value
532	INTEGER, DIMENSION(3) :: ierr
533	!!----------------------------------------------------------------------
534	ierr(:) = 0
535	!
536	ALLOCATE( btmsk(jpi,jpj,nptr) , &
537	& htr_adv(jpj,nptr) , str_adv(jpj,nptr) , &
538	& htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , &
539	& htr_ove(jpj,nptr) , str_ove(jpj,nptr) , &
540	& htr_btr(jpj,nptr) , str_btr(jpj,nptr) , &
541	& htr_ldf(jpj,nptr) , str_ldf(jpj,nptr) , STAT=ierr(1) )
542	!
543	ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2))
544	!
545	ALLOCATE( btm30(jpi,jpj), STAT=ierr(3) )
546
547	!
548	dia_ptr_alloc = MAXVAL( ierr )
549	CALL mpp_sum( 'diaptr', dia_ptr_alloc )
550	!
551	END FUNCTION dia_ptr_alloc
552
553
554	FUNCTION ptr_sj_3d( pva, pmsk ) RESULT ( p_fval )
555	!!----------------------------------------------------------------------
556	!! * ROUTINE ptr_sj_3d *
557	!!
558	!! ** Purpose : i-k sum computation of a j-flux array
559	!!
560	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
561	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
562	!!
563	!! ** Action : - p_fval: i-k-mean poleward flux of pva
564	!!----------------------------------------------------------------------
565	REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point
566	REAL(wp), INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: pmsk ! Optional 2D basin mask
567	!
568	INTEGER :: ji, jj, jk ! dummy loop arguments
569	INTEGER :: ijpj ! ???
570	REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
571	!!--------------------------------------------------------------------
572	!
573	p_fval => p_fval1d
574
575	ijpj = jpj
576	p_fval(:) = 0._wp
577	IF( PRESENT( pmsk ) ) THEN
578	DO jk = 1, jpkm1
579	DO jj = 2, jpjm1
580	DO ji = fs_2, fs_jpim1 ! Vector opt.
581	p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj) * pmsk(ji,jj)
582	END DO
583	END DO
584	END DO
585	ELSE
586	DO jk = 1, jpkm1
587	DO jj = 2, jpjm1
588	DO ji = fs_2, fs_jpim1 ! Vector opt.
589	p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj)
590	END DO
591	END DO
592	END DO
593	ENDIF
594	#if defined key_mpp_mpi
595	CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl)
596	#endif
597	!
598	END FUNCTION ptr_sj_3d
599
600
601	FUNCTION ptr_sj_2d( pva, pmsk ) RESULT ( p_fval )
602	!!----------------------------------------------------------------------
603	!! * ROUTINE ptr_sj_2d *
604	!!
605	!! ** Purpose : "zonal" and vertical sum computation of a i-flux array
606	!!
607	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
608	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
609	!!
610	!! ** Action : - p_fval: i-k-mean poleward flux of pva
611	!!----------------------------------------------------------------------
612	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point
613	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj), OPTIONAL :: pmsk ! Optional 2D basin mask
614	!
615	INTEGER :: ji,jj ! dummy loop arguments
616	INTEGER :: ijpj ! ???
617	REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
618	!!--------------------------------------------------------------------
619	!
620	p_fval => p_fval1d
621
622	ijpj = jpj
623	p_fval(:) = 0._wp
624	IF( PRESENT( pmsk ) ) THEN
625	DO jj = 2, jpjm1
626	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
627	p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj) * pmsk(ji,jj)
628	END DO
629	END DO
630	ELSE
631	DO jj = 2, jpjm1
632	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
633	p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj)
634	END DO
635	END DO
636	ENDIF
637	#if defined key_mpp_mpi
638	CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl )
639	#endif
640	!
641	END FUNCTION ptr_sj_2d
642
643
644	FUNCTION ptr_sjk( pta, pmsk ) RESULT ( p_fval )
645	!!----------------------------------------------------------------------
646	!! * ROUTINE ptr_sjk *
647	!!
648	!! ** Purpose : i-sum computation of an array
649	!!
650	!! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i).
651	!!
652	!! ** Action : - p_fval: i-mean poleward flux of pva
653	!!----------------------------------------------------------------------
654	!!
655	IMPLICIT none
656	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! mask flux array at V-point
657	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: pmsk ! Optional 2D basin mask
658	!!
659	INTEGER :: ji, jj, jk ! dummy loop arguments
660	REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value
661	#if defined key_mpp_mpi
662	INTEGER, DIMENSION(1) :: ish
663	INTEGER, DIMENSION(2) :: ish2
664	INTEGER :: ijpjjpk
665	REAL(wp), DIMENSION(jpj*jpk) :: zwork ! mask flux array at V-point
666	#endif
667	!!--------------------------------------------------------------------
668	!
669	p_fval => p_fval2d
670
671	p_fval(:,:) = 0._wp
672	!
673	IF( PRESENT( pmsk ) ) THEN
674	DO jk = 1, jpkm1
675	DO jj = 2, jpjm1
676	!!gm here, use of tmask_i ==> no need of loop over nldi, nlei....
677	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
678	p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj)
679	END DO
680	END DO
681	END DO
682	ELSE
683	DO jk = 1, jpkm1
684	DO jj = 2, jpjm1
685	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
686	p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * tmask_i(ji,jj)
687	END DO
688	END DO
689	END DO
690	END IF
691	!
692	#if defined key_mpp_mpi
693	ijpjjpk = jpj*jpk
694	ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk
695	zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )
696	CALL mpp_sum( 'diaptr', zwork, ijpjjpk, ncomm_znl )
697	p_fval(:,:) = RESHAPE( zwork, ish2 )
698	#endif
699	!
700	END FUNCTION ptr_sjk
701
702
703	!!======================================================================
704	END MODULE diaptr

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

Download in other formats: