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 trunk/NEMOGCM/NEMO/OPA_SRC/DIA – NEMO

Context Navigation

source: trunk/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90 @ 4731

Last change on this file since 4731 was 4624, checked in by acc, 10 years ago
#1305. Fix slow start-up problems on some systems by introducing and using lwm logical to restrict output of merged namelists to the first (or only) processor. lwm is true only on the first processor regardless of ln_ctl. Small changes to all flavours of nemogcm.F90 are also required to write namctl and namcfg after the call to mynode which now opens output.namelist.dyn and writes nammpp.
Property svn:keywords set to `Id`
File size: 43.7 KB

Rev	Line
[134]	1	MODULE diaptr
	2	!!======================================================================
	3	!! * MODULE diaptr *
[1340]	4	!! Ocean physics: Computes meridonal transports and zonal means
[134]	5	!!=====================================================================
[1559]	6	!! History : 1.0 ! 2003-09 (C. Talandier, G. Madec) Original code
	7	!! 2.0 ! 2006-01 (A. Biastoch) Allow sub-basins computation
[2528]	8	!! 3.2 ! 2010-03 (O. Marti, S. Flavoni) Add fields
	9	!! 3.3 ! 2010-10 (G. Madec) dynamical allocation
[134]	10	!!----------------------------------------------------------------------
[508]	11
	12	!!----------------------------------------------------------------------
[134]	13	!! dia_ptr : Poleward Transport Diagnostics module
	14	!! dia_ptr_init : Initialization, namelist read
	15	!! dia_ptr_wri : Output of poleward fluxes
	16	!! ptr_vjk : "zonal" sum computation of a "meridional" flux array
[1340]	17	!! ptr_tjk : "zonal" mean computation of a tracer field
[2528]	18	!! ptr_vj : "zonal" and vertical sum computation of a "meridional" flux array
	19	!! (Generic interface to ptr_vj_3d, ptr_vj_2d)
[134]	20	!!----------------------------------------------------------------------
[2528]	21	USE oce ! ocean dynamics and active tracers
	22	USE dom_oce ! ocean space and time domain
	23	USE phycst ! physical constants
	24	USE ldftra_oce ! ocean active tracers: lateral physics
	25	USE dianam !
	26	USE iom ! IOM library
	27	USE ioipsl ! IO-IPSL library
	28	USE in_out_manager ! I/O manager
	29	USE lib_mpp ! MPP library
	30	USE lbclnk ! lateral boundary condition - processor exchanges
[3294]	31	USE timing ! preformance summary
	32	USE wrk_nemo ! working arrays
[134]	33
	34	IMPLICIT NONE
	35	PRIVATE
	36
	37	INTERFACE ptr_vj
	38	MODULE PROCEDURE ptr_vj_3d, ptr_vj_2d
	39	END INTERFACE
	40
[508]	41	PUBLIC dia_ptr_init ! call in opa module
	42	PUBLIC dia_ptr ! call in step module
	43	PUBLIC ptr_vj ! call by tra_ldf & tra_adv routines
	44	PUBLIC ptr_vjk ! call by tra_ldf & tra_adv routines
[134]	45
[4147]	46	! !! namelist namptr
	47	LOGICAL , PUBLIC :: ln_diaptr !: Poleward transport flag (T) or not (F)
	48	LOGICAL , PUBLIC :: ln_subbas !: Atlantic/Pacific/Indian basins calculation
	49	LOGICAL , PUBLIC :: ln_diaznl !: Add zonal means and meridional stream functions
	50	LOGICAL , PUBLIC :: ln_ptrcomp !: Add decomposition : overturning (and gyre, soon ...)
	51	INTEGER , PUBLIC :: nn_fptr !: frequency of ptr computation [time step]
	52	INTEGER , PUBLIC :: nn_fwri !: frequency of ptr outputs [time step]
[508]	53
[2715]	54	REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: htr_adv, htr_ldf, htr_ove !: Heat TRansports (adv, diff, overturn.)
	55	REAL(wp), ALLOCATABLE, SAVE, PUBLIC, DIMENSION(:) :: str_adv, str_ldf, str_ove !: Salt TRansports (adv, diff, overturn.)
[2528]	56
[2715]	57	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks
	58	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: btm30 ! mask out Southern Ocean (=0 south of 30°S)
	59	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htr , str ! adv heat and salt transports (approx)
	60	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: tn_jk, sn_jk , v_msf ! i-mean T and S, j-Stream-Function
	61	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: sjk , r1_sjk ! i-mean i-k-surface and its inverse
	62	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: htr_eiv, str_eiv ! bolus adv heat ans salt transports ('key_diaeiv')
	63	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: v_msf_eiv ! bolus j-streamfuction ('key_diaeiv')
[1345]	64
[2715]	65
[2528]	66	INTEGER :: niter !
	67	INTEGER :: nidom_ptr !
	68	INTEGER :: numptr ! logical unit for Poleward TRansports
	69	INTEGER :: nptr ! = 1 (ln_subbas=F) or = 5 (glo, atl, pac, ind, ipc) (ln_subbas=T)
[508]	70
[2528]	71	REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup
	72	REAL(wp) :: rc_pwatt = 1.e-15_wp ! conversion from W to PW (further x rau0 x Cp)
	73	REAL(wp) :: rc_ggram = 1.e-6_wp ! conversion from g to Pg
[134]	74
[2715]	75	REAL(wp), TARGET, DIMENSION(:), ALLOCATABLE, SAVE :: p_fval1d
	76	REAL(wp), TARGET, DIMENSION(:,:), ALLOCATABLE, SAVE :: p_fval2d
	77
	78	!! Integer, 1D workspace arrays. Not common enough to be implemented in
	79	!! wrk_nemo module.
	80	INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex , ndex_atl , ndex_pac , ndex_ind , ndex_ipc
	81	INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_atl_30 , ndex_pac_30 , ndex_ind_30 , ndex_ipc_30
	82	INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndex_h, ndex_h_atl_30, ndex_h_pac_30, ndex_h_ind_30, ndex_h_ipc_30
	83
[134]	84	!! * Substitutions
	85	# include "domzgr_substitute.h90"
	86	# include "vectopt_loop_substitute.h90"
	87	!!----------------------------------------------------------------------
[2528]	88	!! NEMO/OPA 3.3 , NEMO Consortium (2010)
[1152]	89	!! $Id$
[2528]	90	!! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)
[134]	91	!!----------------------------------------------------------------------
	92	CONTAINS
	93
[2715]	94	FUNCTION dia_ptr_alloc()
	95	!!----------------------------------------------------------------------
	96	!! * ROUTINE dia_ptr_alloc *
	97	!!----------------------------------------------------------------------
	98	INTEGER :: dia_ptr_alloc ! return value
[3294]	99	INTEGER, DIMENSION(6) :: ierr
[2715]	100	!!----------------------------------------------------------------------
	101	ierr(:) = 0
	102	!
	103	ALLOCATE( btmsk(jpi,jpj,nptr) , &
	104	& htr_adv(jpj) , str_adv(jpj) , &
	105	& htr_ldf(jpj) , str_ldf(jpj) , &
	106	& htr_ove(jpj) , str_ove(jpj), &
	107	& htr(jpj,nptr) , str(jpj,nptr) , &
	108	& tn_jk(jpj,jpk,nptr) , sn_jk (jpj,jpk,nptr) , v_msf(jpj,jpk,nptr) , &
	109	& sjk (jpj,jpk,nptr) , r1_sjk(jpj,jpk,nptr) , STAT=ierr(1) )
	110	!
	111	#if defined key_diaeiv
	112	ALLOCATE( htr_eiv(jpj,nptr) , str_eiv(jpj,nptr) , &
	113	& v_msf_eiv(jpj,jpk,nptr) , STAT=ierr(2) )
	114	#endif
	115	ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(3))
	116	!
	117	ALLOCATE(ndex(jpjjpk), ndex_atl(jpjjpk), ndex_pac(jpj*jpk), &
	118	& ndex_ind(jpjjpk), ndex_ipc(jpjjpk), &
	119	& ndex_atl_30(jpjjpk), ndex_pac_30(jpjjpk), Stat=ierr(4))
	120
	121	ALLOCATE(ndex_ind_30(jpjjpk), ndex_ipc_30(jpjjpk), &
	122	& ndex_h(jpj), ndex_h_atl_30(jpj), ndex_h_pac_30(jpj), &
	123	& ndex_h_ind_30(jpj), ndex_h_ipc_30(jpj), Stat=ierr(5) )
	124	!
[3294]	125	ALLOCATE( btm30(jpi,jpj) , STAT=ierr(6) )
	126	!
[2715]	127	dia_ptr_alloc = MAXVAL( ierr )
	128	IF(lk_mpp) CALL mpp_sum( dia_ptr_alloc )
	129	!
	130	END FUNCTION dia_ptr_alloc
	131
	132
[134]	133	FUNCTION ptr_vj_3d( pva ) RESULT ( p_fval )
	134	!!----------------------------------------------------------------------
	135	!! * ROUTINE ptr_vj_3d *
	136	!!
[2528]	137	!! ** Purpose : i-k sum computation of a j-flux array
[134]	138	!!
	139	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
[1559]	140	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
[134]	141	!!
	142	!! ** Action : - p_fval: i-k-mean poleward flux of pva
[508]	143	!!----------------------------------------------------------------------
	144	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point
[134]	145	!!
[508]	146	INTEGER :: ji, jj, jk ! dummy loop arguments
	147	INTEGER :: ijpj ! ???
[2715]	148	REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
[134]	149	!!--------------------------------------------------------------------
[508]	150	!
[2715]	151	p_fval => p_fval1d
	152
[389]	153	ijpj = jpj
[2528]	154	p_fval(:) = 0._wp
[134]	155	DO jk = 1, jpkm1
	156	DO jj = 2, jpjm1
	157	DO ji = fs_2, fs_jpim1 ! Vector opt.
[1413]	158	p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * tmask_i(ji,jj)
[134]	159	END DO
	160	END DO
	161	END DO
[1346]	162	#if defined key_mpp_mpi
[2715]	163	IF(lk_mpp) CALL mpp_sum( p_fval, ijpj, ncomm_znl)
[1346]	164	#endif
[508]	165	!
[134]	166	END FUNCTION ptr_vj_3d
	167
	168
	169	FUNCTION ptr_vj_2d( pva ) RESULT ( p_fval )
	170	!!----------------------------------------------------------------------
	171	!! * ROUTINE ptr_vj_2d *
	172	!!
[2528]	173	!! ** Purpose : "zonal" and vertical sum computation of a i-flux array
[134]	174	!!
	175	!! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i).
	176	!! pva is supposed to be a masked flux (i.e. * vmaske1ve3v)
	177	!!
	178	!! ** Action : - p_fval: i-k-mean poleward flux of pva
[508]	179	!!----------------------------------------------------------------------
[2715]	180	IMPLICIT none
[508]	181	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point
[134]	182	!!
[2715]	183	INTEGER :: ji,jj ! dummy loop arguments
	184	INTEGER :: ijpj ! ???
	185	REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
[134]	186	!!--------------------------------------------------------------------
[508]	187	!
[2715]	188	p_fval => p_fval1d
	189
[389]	190	ijpj = jpj
[2528]	191	p_fval(:) = 0._wp
[134]	192	DO jj = 2, jpjm1
[1345]	193	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
[1413]	194	p_fval(jj) = p_fval(jj) + pva(ji,jj) * tmask_i(ji,jj)
[134]	195	END DO
	196	END DO
[1346]	197	#if defined key_mpp_mpi
[2528]	198	CALL mpp_sum( p_fval, ijpj, ncomm_znl )
[1346]	199	#endif
[508]	200	!
	201	END FUNCTION ptr_vj_2d
[134]	202
	203
[2528]	204	FUNCTION ptr_vjk( pva, pmsk ) RESULT ( p_fval )
[134]	205	!!----------------------------------------------------------------------
	206	!! * ROUTINE ptr_vjk *
	207	!!
[2528]	208	!! ** Purpose : i-sum computation of a j-velocity array
[134]	209	!!
	210	!! ** Method : - i-sum of pva using the interior 2D vmask (vmask_i).
[2528]	211	!! pva is supposed to be a masked flux (i.e. * vmask)
[134]	212	!!
[2528]	213	!! ** Action : - p_fval: i-mean poleward flux of pva
[508]	214	!!----------------------------------------------------------------------
[2715]	215	!!
	216	IMPLICIT none
[2528]	217	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! mask flux array at V-point
	218	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) , OPTIONAL :: pmsk ! Optional 2D basin mask
[134]	219	!!
[2715]	220	INTEGER :: ji, jj, jk ! dummy loop arguments
	221	REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value
[1559]	222	#if defined key_mpp_mpi
	223	INTEGER, DIMENSION(1) :: ish
	224	INTEGER, DIMENSION(2) :: ish2
[2715]	225	INTEGER :: ijpjjpk
[1559]	226	#endif
[3294]	227	#if defined key_mpp_mpi
	228	REAL(wp), POINTER, DIMENSION(:) :: zwork ! mask flux array at V-point
	229	#endif
[134]	230	!!--------------------------------------------------------------------
[1559]	231	!
[2715]	232	#if defined key_mpp_mpi
[3294]	233	ijpjjpk = jpj*jpk
	234	CALL wrk_alloc( jpj*jpk, zwork )
[2715]	235	#endif
	236
	237	p_fval => p_fval2d
	238
[2528]	239	p_fval(:,:) = 0._wp
[508]	240	!
[2528]	241	IF( PRESENT( pmsk ) ) THEN
[1340]	242	DO jk = 1, jpkm1
	243	DO jj = 2, jpjm1
[1559]	244	!!gm here, use of tmask_i ==> no need of loop over nldi, nlei....
[1345]	245	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
[2528]	246	p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * pmsk(ji,jj)
[1340]	247	END DO
	248	END DO
[134]	249	END DO
[1340]	250	ELSE
	251	DO jk = 1, jpkm1
	252	DO jj = 2, jpjm1
[1345]	253	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
[2528]	254	p_fval(jj,jk) = p_fval(jj,jk) + pva(ji,jj,jk) * e1v(ji,jj) * fse3v(ji,jj,jk) * tmask_i(ji,jj)
[1340]	255	END DO
	256	END DO
	257	END DO
	258	END IF
[508]	259	!
[1346]	260	#if defined key_mpp_mpi
[4292]	261	ijpjjpk = jpj*jpk
[2715]	262	ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk
	263	zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )
	264	CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
[1559]	265	p_fval(:,:) = RESHAPE( zwork, ish2 )
[1346]	266	#endif
[508]	267	!
[2715]	268	#if defined key_mpp_mpi
[3294]	269	CALL wrk_dealloc( jpj*jpk, zwork )
[2715]	270	#endif
	271	!
[134]	272	END FUNCTION ptr_vjk
	273
[1559]	274
[2528]	275	FUNCTION ptr_tjk( pta, pmsk ) RESULT ( p_fval )
[134]	276	!!----------------------------------------------------------------------
[1340]	277	!! * ROUTINE ptr_tjk *
[134]	278	!!
[2528]	279	!! ** Purpose : i-sum computation of e1te3t a tracer field
[134]	280	!!
[1340]	281	!! ** Method : - i-sum of mj(pta) using tmask
[134]	282	!!
[2528]	283	!! ** Action : - p_fval: i-sum of e1te3tpta
[508]	284	!!----------------------------------------------------------------------
[2715]	285	!!
[1340]	286	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! tracer flux array at T-point
[2528]	287	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask
[134]	288	!!
[2715]	289	INTEGER :: ji, jj, jk ! dummy loop arguments
	290	REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value
[1559]	291	#if defined key_mpp_mpi
	292	INTEGER, DIMENSION(1) :: ish
	293	INTEGER, DIMENSION(2) :: ish2
[2715]	294	INTEGER :: ijpjjpk
[1559]	295	#endif
[3294]	296	#if defined key_mpp_mpi
	297	REAL(wp), POINTER, DIMENSION(:) :: zwork ! mask flux array at V-point
	298	#endif
[134]	299	!!--------------------------------------------------------------------
[508]	300	!
[2715]	301	#if defined key_mpp_mpi
[3294]	302	ijpjjpk = jpj*jpk
	303	CALL wrk_alloc( jpj*jpk, zwork )
[2715]	304	#endif
	305
	306	p_fval => p_fval2d
	307
[2528]	308	p_fval(:,:) = 0._wp
	309	DO jk = 1, jpkm1
	310	DO jj = 2, jpjm1
	311	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
	312	p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * e1t(ji,jj) * fse3t(ji,jj,jk) * pmsk(ji,jj)
[134]	313	END DO
	314	END DO
[2528]	315	END DO
[1346]	316	#if defined key_mpp_mpi
[4292]	317	ijpjjpk = jpj*jpk
[1346]	318	ish(1) = jpj*jpk ; ish2(1) = jpj ; ish2(2) = jpk
[2715]	319	zwork(1:ijpjjpk)= RESHAPE( p_fval, ish )
	320	CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
[2528]	321	p_fval(:,:)= RESHAPE( zwork, ish2 )
[1346]	322	#endif
[508]	323	!
[2715]	324	#if defined key_mpp_mpi
[3294]	325	CALL wrk_dealloc( jpj*jpk, zwork )
[2715]	326	#endif
	327	!
[1340]	328	END FUNCTION ptr_tjk
[134]	329
	330
	331	SUBROUTINE dia_ptr( kt )
	332	!!----------------------------------------------------------------------
	333	!! * ROUTINE dia_ptr *
	334	!!----------------------------------------------------------------------
[2528]	335	USE oce, vt => ua ! use ua as workspace
[3610]	336	USE oce, vs => va ! use va as workspace
[2715]	337	IMPLICIT none
[2528]	338	!!
[134]	339	INTEGER, INTENT(in) :: kt ! ocean time step index
[2528]	340	!
	341	INTEGER :: ji, jj, jk, jn ! dummy loop indices
	342	REAL(wp) :: zv ! local scalar
[134]	343	!!----------------------------------------------------------------------
[2528]	344	!
[3294]	345	IF( nn_timing == 1 ) CALL timing_start('dia_ptr')
	346	!
[2528]	347	IF( kt == nit000 .OR. MOD( kt, nn_fptr ) == 0 ) THEN
	348	!
	349	IF( MOD( kt, nn_fptr ) == 0 ) THEN
	350	!
	351	IF( ln_diaznl ) THEN ! i-mean temperature and salinity
	352	DO jn = 1, nptr
[3294]	353	tn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
[4148]	354	sn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
[2528]	355	END DO
[1340]	356	ENDIF
[2528]	357	!
	358	! ! horizontal integral and vertical dz
	359	! ! eulerian velocity
	360	v_msf(:,:,1) = ptr_vjk( vn(:,:,:) )
	361	DO jn = 2, nptr
	362	v_msf(:,:,jn) = ptr_vjk( vn(:,:,:), btmsk(:,:,jn)*btm30(:,:) )
	363	END DO
[1340]	364	#if defined key_diaeiv
[2528]	365	DO jn = 1, nptr ! bolus velocity
	366	v_msf_eiv(:,:,jn) = ptr_vjk( v_eiv(:,:,:), btmsk(:,:,jn) ) ! here no btm30 for MSFeiv
	367	END DO
	368	! ! add bolus stream-function to the eulerian one
	369	v_msf(:,:,:) = v_msf(:,:,:) + v_msf_eiv(:,:,:)
[1340]	370	#endif
[2528]	371	!
	372	! ! Transports
[3294]	373	! ! local heat & salt transports at T-points ( tsn*mj[vn+v_eiv] )
[2528]	374	vt(:,:,jpk) = 0._wp ; vs(:,:,jpk) = 0._wp
	375	DO jk= 1, jpkm1
	376	DO jj = 2, jpj
	377	DO ji = 1, jpi
[1340]	378	#if defined key_diaeiv
[2571]	379	zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) + v_eiv(ji,jj,jk) + v_eiv(ji,jj-1,jk) ) * 0.5_wp
[1340]	380	#else
[2528]	381	zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) ) * 0.5_wp
	382	#endif
[3610]	383	vt(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_tem)
	384	vs(ji,jj,jk) = zv * tsn(ji,jj,jk,jp_sal)
[2528]	385	END DO
[1345]	386	END DO
[1340]	387	END DO
[2528]	388	!!gm useless as overlap areas are not used in ptr_vjk
[1775]	389	CALL lbc_lnk( vs, 'V', -1. ) ; CALL lbc_lnk( vt, 'V', -1. )
[2528]	390	!!gm
	391	! ! heat & salt advective transports (approximation)
	392	htr(:,1) = SUM( ptr_vjk( vt(:,:,:) ) , 2 ) * rc_pwatt ! SUM over jk + conversion
	393	str(:,1) = SUM( ptr_vjk( vs(:,:,:) ) , 2 ) * rc_ggram
	394	DO jn = 2, nptr
	395	htr(:,jn) = SUM( ptr_vjk( vt(:,:,:), btmsk(:,:,jn)btm30(:,:) ) , 2 ) rc_pwatt ! mask Southern Ocean
	396	str(:,jn) = SUM( ptr_vjk( vs(:,:,:), btmsk(:,:,jn)btm30(:,:) ) , 2 ) rc_ggram ! mask Southern Ocean
	397	END DO
[1345]	398
[2528]	399	IF( ln_ptrcomp ) THEN ! overturning transport
	400	htr_ove(:) = SUM( v_msf(:,:,1) * tn_jk(:,:,1), 2 ) * rc_pwatt ! SUM over jk + conversion
	401	str_ove(:) = SUM( v_msf(:,:,1) * sn_jk(:,:,1), 2 ) * rc_ggram
[1345]	402	END IF
[2528]	403	! ! Advective and diffusive transport
	404	htr_adv(:) = htr_adv(:) * rc_pwatt ! these are computed in tra_adv... and tra_ldf... routines
	405	htr_ldf(:) = htr_ldf(:) * rc_pwatt ! here just the conversion in PW and Gg
	406	str_adv(:) = str_adv(:) * rc_ggram
	407	str_ldf(:) = str_ldf(:) * rc_ggram
[1345]	408
[406]	409	#if defined key_diaeiv
[2528]	410	DO jn = 1, nptr ! Bolus component
	411	htr_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * tn_jk(:,:,jn), 2 ) * rc_pwatt ! SUM over jk
	412	str_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * sn_jk(:,:,jn), 2 ) * rc_ggram ! SUM over jk
	413	END DO
[406]	414	#endif
[2528]	415	! ! "Meridional" Stream-Function
	416	DO jn = 1, nptr
	417	DO jk = 2, jpk
	418	v_msf (:,jk,jn) = v_msf (:,jk-1,jn) + v_msf (:,jk,jn) ! Eulerian j-Stream-Function
	419	#if defined key_diaeiv
	420	v_msf_eiv(:,jk,jn) = v_msf_eiv(:,jk-1,jn) + v_msf_eiv(:,jk,jn) ! Bolus j-Stream-Function
[1340]	421
[406]	422	#endif
[2528]	423	END DO
[1877]	424	END DO
[2528]	425	v_msf (:,:,:) = v_msf (:,:,:) * rc_sv ! converte in Sverdrups
[1877]	426	#if defined key_diaeiv
[2528]	427	v_msf_eiv(:,:,:) = v_msf_eiv(:,:,:) * rc_sv
[1877]	428	#endif
[406]	429	ENDIF
[1559]	430	!
	431	CALL dia_ptr_wri( kt ) ! outputs
	432	!
[406]	433	ENDIF
[508]	434	!
[3294]	435	#if defined key_mpp_mpi
	436	IF( kt == nitend .AND. l_znl_root ) CALL histclo( numptr ) ! Close the file
	437	#else
	438	IF( kt == nitend ) CALL histclo( numptr ) ! Close the file
	439	#endif
[1559]	440	!
[3294]	441	IF( nn_timing == 1 ) CALL timing_stop('dia_ptr')
	442	!
[134]	443	END SUBROUTINE dia_ptr
	444
	445
	446	SUBROUTINE dia_ptr_init
	447	!!----------------------------------------------------------------------
	448	!! * ROUTINE dia_ptr_init *
	449	!!
	450	!! ** Purpose : Initialization, namelist read
	451	!!----------------------------------------------------------------------
[2528]	452	INTEGER :: jn ! dummy loop indices
	453	INTEGER :: inum, ierr ! local integers
[4147]	454	INTEGER :: ios ! Local integer output status for namelist read
[1397]	455	#if defined key_mpp_mpi
[1559]	456	INTEGER, DIMENSION(1) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid
[1397]	457	#endif
[1559]	458	!!
[2528]	459	NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, nn_fptr, nn_fwri
[134]	460	!!----------------------------------------------------------------------
	461
[4147]	462	REWIND( numnam_ref ) ! Namelist namptr in reference namelist : Poleward transport
	463	READ ( numnam_ref, namptr, IOSTAT = ios, ERR = 901)
	464	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist', lwp )
[134]	465
[4147]	466	REWIND( numnam_cfg ) ! Namelist namptr in configuration namelist : Poleward transport
	467	READ ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 )
	468	902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist', lwp )
[4624]	469	IF(lwm) WRITE ( numond, namptr )
[4147]	470
[2528]	471	IF(lwp) THEN ! Control print
[134]	472	WRITE(numout,*)
	473	WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
	474	WRITE(numout,*) '~~~~~~~~~~~~'
[1559]	475	WRITE(numout,*) ' Namelist namptr : set ptr parameters'
[2528]	476	WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) ln_diaptr = ', ln_diaptr
	477	WRITE(numout,*) ' Overturning heat & salt transport ln_ptrcomp = ', ln_ptrcomp
	478	WRITE(numout,*) ' T & S zonal mean and meridional stream function ln_diaznl = ', ln_diaznl
	479	WRITE(numout,*) ' Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins ln_subbas = ', ln_subbas
	480	WRITE(numout,*) ' Frequency of computation nn_fptr = ', nn_fptr
	481	WRITE(numout,*) ' Frequency of outputs nn_fwri = ', nn_fwri
[134]	482	ENDIF
[3294]	483
	484	IF( ln_diaptr) THEN
[3764]	485
	486	IF( nn_timing == 1 ) CALL timing_start('dia_ptr_init')
[3294]	487
	488	IF( ln_subbas ) THEN ; nptr = 5 ! Global, Atlantic, Pacific, Indian, Indo-Pacific
	489	ELSE ; nptr = 1 ! Global only
	490	ENDIF
[134]	491
[3294]	492	! ! allocate dia_ptr arrays
	493	IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' )
[2528]	494
[3294]	495	rc_pwatt = rc_pwatt * rau0 * rcp ! conversion from K.s-1 to PetaWatt
[2528]	496
[3294]	497	IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum
[1345]	498
[3294]	499	IF( ln_subbas ) THEN ! load sub-basin mask
	500	CALL iom_open( 'subbasins', inum )
	501	CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin
	502	CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin
	503	CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin
	504	CALL iom_close( inum )
	505	btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin
	506	WHERE( gphit(:,:) < -30._wp) ; btm30(:,:) = 0._wp ! mask out Southern Ocean
	507	ELSE WHERE ; btm30(:,:) = tmask(:,:,1)
	508	END WHERE
	509	ENDIF
	510	btmsk(:,:,1) = tmask_i(:,:) ! global ocean
[1340]	511
[3294]	512	DO jn = 1, nptr
	513	btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only
	514	END DO
[1340]	515
[3294]	516	IF( lk_vvl ) CALL ctl_stop( 'diaptr: error in vvl case as constant i-mean surface is used' )
[134]	517
[3294]	518	! ! i-sum of e1v*e3v surface and its inverse
	519	DO jn = 1, nptr
	520	sjk(:,:,jn) = ptr_tjk( tmask(:,:,:), btmsk(:,:,jn) )
	521	r1_sjk(:,:,jn) = 0._wp
	522	WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn)
	523	END DO
[1340]	524
[3294]	525	! Initialise arrays to zero because diatpr is called before they are first calculated
	526	! Note that this means diagnostics will not be exactly correct when model run is restarted.
	527	htr_adv(:) = 0._wp ; str_adv(:) = 0._wp ; htr_ldf(:) = 0._wp ; str_ldf(:) = 0._wp
	528
[1397]	529	#if defined key_mpp_mpi
[3294]	530	iglo (1) = jpjglo ! MPP case using MPI ('key_mpp_mpi')
	531	iloc (1) = nlcj
	532	iabsf(1) = njmppt(narea)
	533	iabsl(:) = iabsf(:) + iloc(:) - 1
	534	ihals(1) = nldj - 1
	535	ihale(1) = nlcj - nlej
	536	idid (1) = 2
	537	CALL flio_dom_set( jpnj, nproc/jpni, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom_ptr )
[1397]	538	#else
[3294]	539	nidom_ptr = FLIO_DOM_NONE
[1397]	540	#endif
[3764]	541	IF( nn_timing == 1 ) CALL timing_stop('dia_ptr_init')
	542	!
[3294]	543	ENDIF
[1559]	544	!
[134]	545	END SUBROUTINE dia_ptr_init
	546
	547
	548	SUBROUTINE dia_ptr_wri( kt )
	549	!!---------------------------------------------------------------------
	550	!! * ROUTINE dia_ptr_wri *
	551	!!
	552	!! ** Purpose : output of poleward fluxes
	553	!!
	554	!! ** Method : NetCDF file
	555	!!----------------------------------------------------------------------
[2715]	556	!!
[134]	557	INTEGER, INTENT(in) :: kt ! ocean time-step index
[508]	558	!!
[1340]	559	INTEGER, SAVE :: nhoridz, ndepidzt, ndepidzw
[2715]	560	INTEGER, SAVE :: ndim , ndim_atl , ndim_pac , ndim_ind , ndim_ipc
	561	INTEGER, SAVE :: ndim_atl_30 , ndim_pac_30 , ndim_ind_30 , ndim_ipc_30
	562	INTEGER, SAVE :: ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30
[2528]	563	!!
[2715]	564	CHARACTER (len=40) :: clhstnam, clop, clop_once, cl_comment ! temporary names
	565	INTEGER :: iline, it, itmod, ji, jj, jk !
[1636]	566	#if defined key_iomput
[2715]	567	INTEGER :: inum ! temporary logical unit
[1636]	568	#endif
[2715]	569	REAL(wp) :: zsto, zout, zdt, zjulian ! temporary scalars
[3294]	570	!!
	571	REAL(wp), POINTER, DIMENSION(:) :: zphi, zfoo ! 1D workspace
	572	REAL(wp), POINTER, DIMENSION(:,:) :: z_1 ! 2D workspace
	573	!!--------------------------------------------------------------------
	574	!
[4148]	575	CALL wrk_alloc( jpj , zphi , zfoo )
	576	CALL wrk_alloc( jpj , jpk, z_1 )
[1340]	577
[134]	578	! define time axis
[2528]	579	it = kt / nn_fptr
[1334]	580	itmod = kt - nit000 + 1
[1345]	581
[134]	582	! Initialization
	583	! --------------
	584	IF( kt == nit000 ) THEN
[2528]	585	niter = ( nit000 - 1 ) / nn_fptr
[1316]	586	zdt = rdt
[1559]	587	IF( nacc == 1 ) zdt = rdtmin
[2528]	588	!
	589	IF(lwp) THEN
	590	WRITE(numout,*)
	591	WRITE(numout,*) 'dia_ptr_wri : poleward transport and msf writing: initialization , niter = ', niter
	592	WRITE(numout,*) '~~~~~~~~~~~~'
	593	ENDIF
[134]	594
[2528]	595	! Reference latitude (used in plots)
[134]	596	! ------------------
	597	! ! =======================
	598	IF( cp_cfg == "orca" ) THEN ! ORCA configurations
	599	! ! =======================
	600	IF( jp_cfg == 05 ) iline = 192 ! i-line that passes near the North Pole
	601	IF( jp_cfg == 025 ) iline = 384 ! i-line that passes near the North Pole
[1345]	602	IF( jp_cfg == 1 ) iline = 96 ! i-line that passes near the North Pole
[134]	603	IF( jp_cfg == 2 ) iline = 48 ! i-line that passes near the North Pole
	604	IF( jp_cfg == 4 ) iline = 24 ! i-line that passes near the North Pole
[2715]	605	zphi(1:jpj) = 0._wp
[134]	606	DO ji = mi0(iline), mi1(iline)
[2715]	607	zphi(1:jpj) = gphiv(ji,:) ! if iline is in the local domain
[1340]	608	! Correct highest latitude for some configurations - will work if domain is parallelized in J ?
	609	IF( jp_cfg == 05 ) THEN
	610	DO jj = mj0(jpjdta), mj1(jpjdta)
[2528]	611	zphi( jj ) = zphi(mj0(jpjdta-1)) + ( zphi(mj0(jpjdta-1))-zphi(mj0(jpjdta-2)) ) * 0.5_wp
	612	zphi( jj ) = MIN( zphi(jj), 90._wp )
[1340]	613	END DO
	614	END IF
[1345]	615	IF( jp_cfg == 1 .OR. jp_cfg == 2 .OR. jp_cfg == 4 ) THEN
[1340]	616	DO jj = mj0(jpjdta-1), mj1(jpjdta-1)
[2528]	617	zphi( jj ) = 88.5_wp
[1340]	618	END DO
	619	DO jj = mj0(jpjdta ), mj1(jpjdta )
[2528]	620	zphi( jj ) = 89.5_wp
[1340]	621	END DO
	622	END IF
[134]	623	END DO
	624	! provide the correct zphi to all local domains
[1346]	625	#if defined key_mpp_mpi
	626	CALL mpp_sum( zphi, jpj, ncomm_znl )
	627	#endif
[134]	628	! ! =======================
[1559]	629	ELSE ! OTHER configurations
[134]	630	! ! =======================
[2715]	631	zphi(1:jpj) = gphiv(1,:) ! assume lat/lon coordinate, select the first i-line
[134]	632	!
	633	ENDIF
[1345]	634	!
	635	! Work only on westmost processor (will not work if mppini2 is used)
[1346]	636	#if defined key_mpp_mpi
[2528]	637	IF( l_znl_root ) THEN
[1346]	638	#endif
[1345]	639	!
	640	! OPEN netcdf file
	641	! ----------------
	642	! Define frequency of output and means
[2528]	643	zsto = nn_fptr * zdt
[1345]	644	IF( ln_mskland ) THEN ! put 1.e+20 on land (very expensive!!)
	645	clop = "ave(only(x))"
	646	clop_once = "once(only(x))"
	647	ELSE ! no use of the mask value (require less cpu time)
	648	clop = "ave(x)"
	649	clop_once = "once"
	650	ENDIF
[134]	651
[2528]	652	zout = nn_fwri * zdt
[2715]	653	zfoo(1:jpj) = 0._wp
[1340]	654
[2715]	655	CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian ) ! Compute julian date from starting date of the run
	656	zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment
[134]	657
[1636]	658	#if defined key_iomput
	659	! Requested by IPSL people, use by their postpro...
	660	IF(lwp) THEN
[2528]	661	CALL dia_nam( clhstnam, nn_fwri,' ' )
[1636]	662	CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
	663	WRITE(inum,*) clhstnam
	664	CLOSE(inum)
	665	ENDIF
	666	#endif
	667
[2528]	668	CALL dia_nam( clhstnam, nn_fwri, 'diaptr' )
[1345]	669	IF(lwp)WRITE( numout,*)" Name of diaptr NETCDF file : ", clhstnam
[134]	670
[1345]	671	! Horizontal grid : zphi()
	672	CALL histbeg(clhstnam, 1, zfoo, jpj, zphi, &
[2528]	673	1, 1, 1, jpj, niter, zjulian, zdt*nn_fptr, nhoridz, numptr, domain_id=nidom_ptr)
[4292]	674	! Vertical grids : gdept_1d, gdepw_1d
[1345]	675	CALL histvert( numptr, "deptht", "Vertical T levels", &
[4292]	676	& "m", jpk, gdept_1d, ndepidzt, "down" )
[1345]	677	CALL histvert( numptr, "depthw", "Vertical W levels", &
[4292]	678	& "m", jpk, gdepw_1d, ndepidzw, "down" )
[1345]	679	!
[2528]	680	CALL wheneq ( jpj*jpk, MIN(sjk(:,:,1), 1._wp), 1, 1., ndex , ndim ) ! Lat-Depth
	681	CALL wheneq ( jpj , MIN(sjk(:,1,1), 1._wp), 1, 1., ndex_h, ndim_h ) ! Lat
[1340]	682
[2528]	683	IF( ln_subbas ) THEN
	684	z_1(:,1) = 1._wp
	685	WHERE ( gphit(jpi/2,:) < -30._wp ) z_1(:,1) = 0._wp
[1345]	686	DO jk = 2, jpk
[2528]	687	z_1(:,jk) = z_1(:,1)
[1345]	688	END DO
[2528]	689	! ! Atlantic (jn=2)
	690	CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2) , 1._wp), 1, 1., ndex_atl , ndim_atl ) ! Lat-Depth
	691	CALL wheneq ( jpjjpk, MIN(sjk(:,:,2)z_1(:,:), 1._wp), 1, 1., ndex_atl_30 , ndim_atl_30 ) ! Lat-Depth
	692	CALL wheneq ( jpj , MIN(sjk(:,1,2)*z_1(:,1), 1._wp), 1, 1., ndex_h_atl_30, ndim_h_atl_30 ) ! Lat
	693	! ! Pacific (jn=3)
	694	CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3) , 1._wp), 1, 1., ndex_pac , ndim_pac ) ! Lat-Depth
	695	CALL wheneq ( jpjjpk, MIN(sjk(:,:,3)z_1(:,:), 1._wp), 1, 1., ndex_pac_30 , ndim_pac_30 ) ! Lat-Depth
	696	CALL wheneq ( jpj , MIN(sjk(:,1,3)*z_1(:,1), 1._wp), 1, 1., ndex_h_pac_30, ndim_h_pac_30 ) ! Lat
	697	! ! Indian (jn=4)
	698	CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4) , 1._wp), 1, 1., ndex_ind , ndim_ind ) ! Lat-Depth
	699	CALL wheneq ( jpjjpk, MIN(sjk(:,:,4)z_1(:,:), 1._wp), 1, 1., ndex_ind_30 , ndim_ind_30 ) ! Lat-Depth
	700	CALL wheneq ( jpj , MIN(sjk(:,1,4)*z_1(:,1), 1._wp), 1, 1., ndex_h_ind_30, ndim_h_ind_30 ) ! Lat
	701	! ! Indo-Pacific (jn=5)
	702	CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5) , 1._wp), 1, 1., ndex_ipc , ndim_ipc ) ! Lat-Depth
	703	CALL wheneq ( jpjjpk, MIN(sjk(:,:,5)z_1(:,:), 1._wp), 1, 1., ndex_ipc_30 , ndim_ipc_30 ) ! Lat-Depth
	704	CALL wheneq ( jpj , MIN(sjk(:,1,5)*z_1(:,1), 1._wp), 1, 1., ndex_h_ipc_30, ndim_h_ipc_30 ) ! Lat
[1345]	705	ENDIF
	706	!
[1340]	707	#if defined key_diaeiv
[1345]	708	cl_comment = ' (Bolus part included)'
[1340]	709	#else
[1345]	710	cl_comment = ' '
[1340]	711	#endif
[2715]	712	IF( ln_diaznl ) THEN ! Zonal mean T and S
[1345]	713	CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" , &
[1340]	714	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
[1345]	715	CALL histdef( numptr, "zosalglo", "Zonal Mean Salinity","PSU" , &
[1340]	716	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	717
[1345]	718	CALL histdef( numptr, "zosrfglo", "Zonal Mean Surface","m^2" , &
[1340]	719	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
[2715]	720	!
[1345]	721	IF (ln_subbas) THEN
	722	CALL histdef( numptr, "zotematl", "Zonal Mean Temperature: Atlantic","C" , &
	723	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	724	CALL histdef( numptr, "zosalatl", "Zonal Mean Salinity: Atlantic","PSU" , &
	725	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	726	CALL histdef( numptr, "zosrfatl", "Zonal Mean Surface: Atlantic","m^2" , &
	727	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
[1340]	728
[1345]	729	CALL histdef( numptr, "zotempac", "Zonal Mean Temperature: Pacific","C" , &
	730	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	731	CALL histdef( numptr, "zosalpac", "Zonal Mean Salinity: Pacific","PSU" , &
	732	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	733	CALL histdef( numptr, "zosrfpac", "Zonal Mean Surface: Pacific","m^2" , &
	734	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
	735
	736	CALL histdef( numptr, "zotemind", "Zonal Mean Temperature: Indian","C" , &
	737	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	738	CALL histdef( numptr, "zosalind", "Zonal Mean Salinity: Indian","PSU" , &
	739	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	740	CALL histdef( numptr, "zosrfind", "Zonal Mean Surface: Indian","m^2" , &
	741	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
	742
	743	CALL histdef( numptr, "zotemipc", "Zonal Mean Temperature: Pacific+Indian","C" , &
	744	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	745	CALL histdef( numptr, "zosalipc", "Zonal Mean Salinity: Pacific+Indian","PSU" , &
	746	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	747	CALL histdef( numptr, "zosrfipc", "Zonal Mean Surface: Pacific+Indian","m^2" , &
	748	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
	749	ENDIF
[1340]	750	ENDIF
[2715]	751	!
[1345]	752	! Meridional Stream-Function (Eulerian and Bolus)
	753	CALL histdef( numptr, "zomsfglo", "Meridional Stream-Function: Global"//TRIM(cl_comment),"Sv" , &
[406]	754	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
[1345]	755	IF( ln_subbas .AND. ln_diaznl ) THEN
	756	CALL histdef( numptr, "zomsfatl", "Meridional Stream-Function: Atlantic"//TRIM(cl_comment),"Sv" , &
	757	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
	758	CALL histdef( numptr, "zomsfpac", "Meridional Stream-Function: Pacific"//TRIM(cl_comment),"Sv" , &
	759	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
	760	CALL histdef( numptr, "zomsfind", "Meridional Stream-Function: Indian"//TRIM(cl_comment),"Sv" , &
	761	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
	762	CALL histdef( numptr, "zomsfipc", "Meridional Stream-Function: Indo-Pacific"//TRIM(cl_comment),"Sv" ,&
	763	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
	764	ENDIF
[2715]	765	!
[1345]	766	! Heat transport
	767	CALL histdef( numptr, "sophtadv", "Advective Heat Transport" , &
[406]	768	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
[1345]	769	CALL histdef( numptr, "sophtldf", "Diffusive Heat Transport" , &
	770	"PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	771	IF ( ln_ptrcomp ) THEN
	772	CALL histdef( numptr, "sophtove", "Overturning Heat Transport" , &
	773	"PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	774	END IF
	775	IF( ln_subbas ) THEN
	776	CALL histdef( numptr, "sohtatl", "Heat Transport Atlantic"//TRIM(cl_comment), &
	777	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	778	CALL histdef( numptr, "sohtpac", "Heat Transport Pacific"//TRIM(cl_comment) , &
	779	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	780	CALL histdef( numptr, "sohtind", "Heat Transport Indian"//TRIM(cl_comment) , &
	781	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	782	CALL histdef( numptr, "sohtipc", "Heat Transport Pacific+Indian"//TRIM(cl_comment), &
	783	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	784	ENDIF
[2715]	785	!
[1345]	786	! Salt transport
	787	CALL histdef( numptr, "sopstadv", "Advective Salt Transport" , &
[406]	788	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
[1345]	789	CALL histdef( numptr, "sopstldf", "Diffusive Salt Transport" , &
[406]	790	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
[1345]	791	IF ( ln_ptrcomp ) THEN
	792	CALL histdef( numptr, "sopstove", "Overturning Salt Transport" , &
	793	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	794	END IF
	795	#if defined key_diaeiv
	796	! Eddy induced velocity
	797	CALL histdef( numptr, "zomsfeiv", "Bolus Meridional Stream-Function: global", &
	798	"Sv" , 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
	799	CALL histdef( numptr, "sophteiv", "Bolus Advective Heat Transport", &
	800	"PW" , 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	801	CALL histdef( numptr, "sopsteiv", "Bolus Advective Salt Transport", &
[406]	802	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
[1345]	803	#endif
	804	IF( ln_subbas ) THEN
	805	CALL histdef( numptr, "sostatl", "Salt Transport Atlantic"//TRIM(cl_comment) , &
	806	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	807	CALL histdef( numptr, "sostpac", "Salt Transport Pacific"//TRIM(cl_comment) , &
	808	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	809	CALL histdef( numptr, "sostind", "Salt Transport Indian"//TRIM(cl_comment) , &
	810	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	811	CALL histdef( numptr, "sostipc", "Salt Transport Pacific+Indian"//TRIM(cl_comment), &
	812	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	813	ENDIF
[2715]	814	!
[1345]	815	CALL histend( numptr )
[2715]	816	!
[1345]	817	END IF
[1346]	818	#if defined key_mpp_mpi
[1345]	819	END IF
[1346]	820	#endif
[134]	821
[1346]	822	#if defined key_mpp_mpi
[2528]	823	IF( MOD( itmod, nn_fptr ) == 0 .AND. l_znl_root ) THEN
[1346]	824	#else
[2528]	825	IF( MOD( itmod, nn_fptr ) == 0 ) THEN
[1346]	826	#endif
[1345]	827	niter = niter + 1
[406]	828
[2528]	829	IF( ln_diaznl ) THEN
	830	CALL histwrite( numptr, "zosrfglo", niter, sjk (:,:,1) , ndim, ndex )
	831	CALL histwrite( numptr, "zotemglo", niter, tn_jk(:,:,1) , ndim, ndex )
	832	CALL histwrite( numptr, "zosalglo", niter, sn_jk(:,:,1) , ndim, ndex )
[1345]	833
[1340]	834	IF (ln_subbas) THEN
[2528]	835	CALL histwrite( numptr, "zosrfatl", niter, sjk(:,:,2), ndim_atl, ndex_atl )
	836	CALL histwrite( numptr, "zosrfpac", niter, sjk(:,:,3), ndim_pac, ndex_pac )
	837	CALL histwrite( numptr, "zosrfind", niter, sjk(:,:,4), ndim_ind, ndex_ind )
	838	CALL histwrite( numptr, "zosrfipc", niter, sjk(:,:,5), ndim_ipc, ndex_ipc )
[1340]	839
[2528]	840	CALL histwrite( numptr, "zotematl", niter, tn_jk(:,:,2) , ndim_atl, ndex_atl )
	841	CALL histwrite( numptr, "zosalatl", niter, sn_jk(:,:,2) , ndim_atl, ndex_atl )
	842	CALL histwrite( numptr, "zotempac", niter, tn_jk(:,:,3) , ndim_pac, ndex_pac )
	843	CALL histwrite( numptr, "zosalpac", niter, sn_jk(:,:,3) , ndim_pac, ndex_pac )
	844	CALL histwrite( numptr, "zotemind", niter, tn_jk(:,:,4) , ndim_ind, ndex_ind )
	845	CALL histwrite( numptr, "zosalind", niter, sn_jk(:,:,4) , ndim_ind, ndex_ind )
	846	CALL histwrite( numptr, "zotemipc", niter, tn_jk(:,:,5) , ndim_ipc, ndex_ipc )
	847	CALL histwrite( numptr, "zosalipc", niter, sn_jk(:,:,5) , ndim_ipc, ndex_ipc )
[1340]	848	END IF
	849	ENDIF
	850
[406]	851	! overturning outputs:
[2528]	852	CALL histwrite( numptr, "zomsfglo", niter, v_msf(:,:,1), ndim, ndex )
[1340]	853	IF( ln_subbas .AND. ln_diaznl ) THEN
[2528]	854	CALL histwrite( numptr, "zomsfatl", niter, v_msf(:,:,2) , ndim_atl_30, ndex_atl_30 )
	855	CALL histwrite( numptr, "zomsfpac", niter, v_msf(:,:,3) , ndim_pac_30, ndex_pac_30 )
	856	CALL histwrite( numptr, "zomsfind", niter, v_msf(:,:,4) , ndim_ind_30, ndex_ind_30 )
	857	CALL histwrite( numptr, "zomsfipc", niter, v_msf(:,:,5) , ndim_ipc_30, ndex_ipc_30 )
[406]	858	ENDIF
[1340]	859	#if defined key_diaeiv
[2528]	860	CALL histwrite( numptr, "zomsfeiv", niter, v_msf_eiv(:,:,1), ndim , ndex )
[1340]	861	#endif
[406]	862
[1345]	863	! heat transport outputs:
	864	IF( ln_subbas ) THEN
[2528]	865	CALL histwrite( numptr, "sohtatl", niter, htr(:,2) , ndim_h_atl_30, ndex_h_atl_30 )
	866	CALL histwrite( numptr, "sohtpac", niter, htr(:,3) , ndim_h_pac_30, ndex_h_pac_30 )
	867	CALL histwrite( numptr, "sohtind", niter, htr(:,4) , ndim_h_ind_30, ndex_h_ind_30 )
	868	CALL histwrite( numptr, "sohtipc", niter, htr(:,5) , ndim_h_ipc_30, ndex_h_ipc_30 )
	869	CALL histwrite( numptr, "sostatl", niter, str(:,2) , ndim_h_atl_30, ndex_h_atl_30 )
	870	CALL histwrite( numptr, "sostpac", niter, str(:,3) , ndim_h_pac_30, ndex_h_pac_30 )
	871	CALL histwrite( numptr, "sostind", niter, str(:,4) , ndim_h_ind_30, ndex_h_ind_30 )
	872	CALL histwrite( numptr, "sostipc", niter, str(:,5) , ndim_h_ipc_30, ndex_h_ipc_30 )
[1345]	873	ENDIF
[1340]	874
[2528]	875	CALL histwrite( numptr, "sophtadv", niter, htr_adv , ndim_h, ndex_h )
	876	CALL histwrite( numptr, "sophtldf", niter, htr_ldf , ndim_h, ndex_h )
	877	CALL histwrite( numptr, "sopstadv", niter, str_adv , ndim_h, ndex_h )
	878	CALL histwrite( numptr, "sopstldf", niter, str_ldf , ndim_h, ndex_h )
	879	IF( ln_ptrcomp ) THEN
	880	CALL histwrite( numptr, "sopstove", niter, str_ove(:) , ndim_h, ndex_h )
	881	CALL histwrite( numptr, "sophtove", niter, htr_ove(:) , ndim_h, ndex_h )
[1345]	882	ENDIF
[134]	883	#if defined key_diaeiv
[2528]	884	CALL histwrite( numptr, "sophteiv", niter, htr_eiv(:,1) , ndim_h, ndex_h )
	885	CALL histwrite( numptr, "sopsteiv", niter, str_eiv(:,1) , ndim_h, ndex_h )
[134]	886	#endif
[1345]	887	!
	888	ENDIF
[508]	889	!
[4148]	890	CALL wrk_dealloc( jpj , zphi , zfoo )
	891	CALL wrk_dealloc( jpj , jpk, z_1 )
[2715]	892	!
	893	END SUBROUTINE dia_ptr_wri
[134]	894
	895	!!======================================================================
	896	END MODULE diaptr

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

Download in other formats: