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 branches/2011/dev_NEMO_MERGE_2011/NEMOGCM/NEMO/OPA_SRC/DIA – NEMO

Context Navigation

source: branches/2011/dev_NEMO_MERGE_2011/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90 @ 3281

Last change on this file since 3281 was 3281, checked in by rblod, 12 years ago
Fix diaptr_init see ticket #912
Property svn:keywords set to `Id`
File size: 43.2 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
[3168]	31	USE timing ! preformance summary
[3186]	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
[1559]	46	! !! namelist namptr
	47	LOGICAL , PUBLIC :: ln_diaptr = .FALSE. !: Poleward transport flag (T) or not (F)
	48	LOGICAL , PUBLIC :: ln_subbas = .FALSE. !: Atlantic/Pacific/Indian basins calculation
	49	LOGICAL , PUBLIC :: ln_diaznl = .FALSE. !: Add zonal means and meridional stream functions
	50	LOGICAL , PUBLIC :: ln_ptrcomp = .FALSE. !: Add decomposition : overturning (and gyre, soon ...)
[2528]	51	INTEGER , PUBLIC :: nn_fptr = 15 !: frequency of ptr computation [time step]
	52	INTEGER , PUBLIC :: nn_fwri = 15 !: 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
[3255]	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	!
[3255]	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
[3168]	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
[3168]	233	ijpjjpk = jpj*jpk
[3208]	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
[2715]	261	ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk
	262	zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )
	263	CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
[1559]	264	p_fval(:,:) = RESHAPE( zwork, ish2 )
[1346]	265	#endif
[508]	266	!
[2715]	267	#if defined key_mpp_mpi
[3208]	268	CALL wrk_dealloc( jpj*jpk, zwork )
[2715]	269	#endif
	270	!
[134]	271	END FUNCTION ptr_vjk
	272
[1559]	273
[2528]	274	FUNCTION ptr_tjk( pta, pmsk ) RESULT ( p_fval )
[134]	275	!!----------------------------------------------------------------------
[1340]	276	!! * ROUTINE ptr_tjk *
[134]	277	!!
[2528]	278	!! ** Purpose : i-sum computation of e1te3t a tracer field
[134]	279	!!
[1340]	280	!! ** Method : - i-sum of mj(pta) using tmask
[134]	281	!!
[2528]	282	!! ** Action : - p_fval: i-sum of e1te3tpta
[508]	283	!!----------------------------------------------------------------------
[2715]	284	!!
[1340]	285	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! tracer flux array at T-point
[2528]	286	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask
[134]	287	!!
[2715]	288	INTEGER :: ji, jj, jk ! dummy loop arguments
	289	REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value
[1559]	290	#if defined key_mpp_mpi
	291	INTEGER, DIMENSION(1) :: ish
	292	INTEGER, DIMENSION(2) :: ish2
[2715]	293	INTEGER :: ijpjjpk
[1559]	294	#endif
[3168]	295	#if defined key_mpp_mpi
	296	REAL(wp), POINTER, DIMENSION(:) :: zwork ! mask flux array at V-point
	297	#endif
[134]	298	!!--------------------------------------------------------------------
[508]	299	!
[2715]	300	#if defined key_mpp_mpi
[3168]	301	ijpjjpk = jpj*jpk
[3208]	302	CALL wrk_alloc( jpj*jpk, zwork )
[2715]	303	#endif
	304
	305	p_fval => p_fval2d
	306
[2528]	307	p_fval(:,:) = 0._wp
	308	DO jk = 1, jpkm1
	309	DO jj = 2, jpjm1
	310	DO ji = nldi, nlei ! No vector optimisation here. Better use a mask ?
	311	p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * e1t(ji,jj) * fse3t(ji,jj,jk) * pmsk(ji,jj)
[134]	312	END DO
	313	END DO
[2528]	314	END DO
[1346]	315	#if defined key_mpp_mpi
	316	ish(1) = jpj*jpk ; ish2(1) = jpj ; ish2(2) = jpk
[2715]	317	zwork(1:ijpjjpk)= RESHAPE( p_fval, ish )
	318	CALL mpp_sum( zwork, ijpjjpk, ncomm_znl )
[2528]	319	p_fval(:,:)= RESHAPE( zwork, ish2 )
[1346]	320	#endif
[508]	321	!
[2715]	322	#if defined key_mpp_mpi
[3208]	323	CALL wrk_dealloc( jpj*jpk, zwork )
[2715]	324	#endif
	325	!
[1340]	326	END FUNCTION ptr_tjk
[134]	327
	328
	329	SUBROUTINE dia_ptr( kt )
	330	!!----------------------------------------------------------------------
	331	!! * ROUTINE dia_ptr *
	332	!!----------------------------------------------------------------------
[2528]	333	USE oce, vt => ua ! use ua as workspace
	334	USE oce, vs => ua ! use ua as workspace
[2715]	335	IMPLICIT none
[2528]	336	!!
[134]	337	INTEGER, INTENT(in) :: kt ! ocean time step index
[2528]	338	!
	339	INTEGER :: ji, jj, jk, jn ! dummy loop indices
	340	REAL(wp) :: zv ! local scalar
[134]	341	!!----------------------------------------------------------------------
[2528]	342	!
[3168]	343	IF( nn_timing == 1 ) CALL timing_start('dia_ptr')
	344	!
[2528]	345	IF( kt == nit000 .OR. MOD( kt, nn_fptr ) == 0 ) THEN
	346	!
	347	IF( MOD( kt, nn_fptr ) == 0 ) THEN
	348	!
	349	IF( ln_diaznl ) THEN ! i-mean temperature and salinity
	350	DO jn = 1, nptr
[2977]	351	tn_jk(:,:,jn) = ptr_tjk( tsn(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
[2528]	352	END DO
[1340]	353	ENDIF
[2528]	354	!
	355	! ! horizontal integral and vertical dz
	356	! ! eulerian velocity
	357	v_msf(:,:,1) = ptr_vjk( vn(:,:,:) )
	358	DO jn = 2, nptr
	359	v_msf(:,:,jn) = ptr_vjk( vn(:,:,:), btmsk(:,:,jn)*btm30(:,:) )
	360	END DO
[1340]	361	#if defined key_diaeiv
[2528]	362	DO jn = 1, nptr ! bolus velocity
	363	v_msf_eiv(:,:,jn) = ptr_vjk( v_eiv(:,:,:), btmsk(:,:,jn) ) ! here no btm30 for MSFeiv
	364	END DO
	365	! ! add bolus stream-function to the eulerian one
	366	v_msf(:,:,:) = v_msf(:,:,:) + v_msf_eiv(:,:,:)
[1340]	367	#endif
[2528]	368	!
	369	! ! Transports
[2977]	370	! ! local heat & salt transports at T-points ( tsn*mj[vn+v_eiv] )
[2528]	371	vt(:,:,jpk) = 0._wp ; vs(:,:,jpk) = 0._wp
	372	DO jk= 1, jpkm1
	373	DO jj = 2, jpj
	374	DO ji = 1, jpi
[1340]	375	#if defined key_diaeiv
[2571]	376	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]	377	#else
[2528]	378	zv = ( vn(ji,jj,jk) + vn(ji,jj-1,jk) ) * 0.5_wp
	379	#endif
[2977]	380	vt(:,jj,jk) = zv * tsn(:,jj,jk,jp_tem)
	381	vs(:,jj,jk) = zv * tsn(:,jj,jk,jp_sal)
[2528]	382	END DO
[1345]	383	END DO
[1340]	384	END DO
[2528]	385	!!gm useless as overlap areas are not used in ptr_vjk
[1775]	386	CALL lbc_lnk( vs, 'V', -1. ) ; CALL lbc_lnk( vt, 'V', -1. )
[2528]	387	!!gm
	388	! ! heat & salt advective transports (approximation)
	389	htr(:,1) = SUM( ptr_vjk( vt(:,:,:) ) , 2 ) * rc_pwatt ! SUM over jk + conversion
	390	str(:,1) = SUM( ptr_vjk( vs(:,:,:) ) , 2 ) * rc_ggram
	391	DO jn = 2, nptr
	392	htr(:,jn) = SUM( ptr_vjk( vt(:,:,:), btmsk(:,:,jn)btm30(:,:) ) , 2 ) rc_pwatt ! mask Southern Ocean
	393	str(:,jn) = SUM( ptr_vjk( vs(:,:,:), btmsk(:,:,jn)btm30(:,:) ) , 2 ) rc_ggram ! mask Southern Ocean
	394	END DO
[1345]	395
[2528]	396	IF( ln_ptrcomp ) THEN ! overturning transport
	397	htr_ove(:) = SUM( v_msf(:,:,1) * tn_jk(:,:,1), 2 ) * rc_pwatt ! SUM over jk + conversion
	398	str_ove(:) = SUM( v_msf(:,:,1) * sn_jk(:,:,1), 2 ) * rc_ggram
[1345]	399	END IF
[2528]	400	! ! Advective and diffusive transport
	401	htr_adv(:) = htr_adv(:) * rc_pwatt ! these are computed in tra_adv... and tra_ldf... routines
	402	htr_ldf(:) = htr_ldf(:) * rc_pwatt ! here just the conversion in PW and Gg
	403	str_adv(:) = str_adv(:) * rc_ggram
	404	str_ldf(:) = str_ldf(:) * rc_ggram
[1345]	405
[406]	406	#if defined key_diaeiv
[2528]	407	DO jn = 1, nptr ! Bolus component
	408	htr_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * tn_jk(:,:,jn), 2 ) * rc_pwatt ! SUM over jk
	409	str_eiv(:,jn) = SUM( v_msf_eiv(:,:,jn) * sn_jk(:,:,jn), 2 ) * rc_ggram ! SUM over jk
	410	END DO
[406]	411	#endif
[2528]	412	! ! "Meridional" Stream-Function
	413	DO jn = 1, nptr
	414	DO jk = 2, jpk
	415	v_msf (:,jk,jn) = v_msf (:,jk-1,jn) + v_msf (:,jk,jn) ! Eulerian j-Stream-Function
	416	#if defined key_diaeiv
	417	v_msf_eiv(:,jk,jn) = v_msf_eiv(:,jk-1,jn) + v_msf_eiv(:,jk,jn) ! Bolus j-Stream-Function
[1340]	418
[406]	419	#endif
[2528]	420	END DO
[1877]	421	END DO
[2528]	422	v_msf (:,:,:) = v_msf (:,:,:) * rc_sv ! converte in Sverdrups
[1877]	423	#if defined key_diaeiv
[2528]	424	v_msf_eiv(:,:,:) = v_msf_eiv(:,:,:) * rc_sv
[1877]	425	#endif
[406]	426	ENDIF
[1559]	427	!
	428	CALL dia_ptr_wri( kt ) ! outputs
	429	!
[406]	430	ENDIF
[508]	431	!
[3171]	432	#if defined key_mpp_mpi
[3168]	433	IF( kt == nitend .AND. l_znl_root ) CALL histclo( numptr ) ! Close the file
[3171]	434	#else
	435	IF( kt == nitend ) CALL histclo( numptr ) ! Close the file
	436	#endif
[1559]	437	!
[3168]	438	IF( nn_timing == 1 ) CALL timing_stop('dia_ptr')
	439	!
[134]	440	END SUBROUTINE dia_ptr
	441
	442
	443	SUBROUTINE dia_ptr_init
	444	!!----------------------------------------------------------------------
	445	!! * ROUTINE dia_ptr_init *
	446	!!
	447	!! ** Purpose : Initialization, namelist read
	448	!!----------------------------------------------------------------------
[2528]	449	INTEGER :: jn ! dummy loop indices
	450	INTEGER :: inum, ierr ! local integers
[1397]	451	#if defined key_mpp_mpi
[1559]	452	INTEGER, DIMENSION(1) :: iglo, iloc, iabsf, iabsl, ihals, ihale, idid
[1397]	453	#endif
[1559]	454	!!
[2528]	455	NAMELIST/namptr/ ln_diaptr, ln_diaznl, ln_subbas, ln_ptrcomp, nn_fptr, nn_fwri
[134]	456	!!----------------------------------------------------------------------
[3168]	457	IF( nn_timing == 1 ) CALL timing_start('dia_ptr_init')
[134]	458
[2528]	459	REWIND( numnam ) ! Read Namelist namptr : poleward transport parameters
	460	READ ( numnam, namptr )
[134]	461
[2528]	462	IF(lwp) THEN ! Control print
[134]	463	WRITE(numout,*)
	464	WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
	465	WRITE(numout,*) '~~~~~~~~~~~~'
[1559]	466	WRITE(numout,*) ' Namelist namptr : set ptr parameters'
[2528]	467	WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) ln_diaptr = ', ln_diaptr
	468	WRITE(numout,*) ' Overturning heat & salt transport ln_ptrcomp = ', ln_ptrcomp
	469	WRITE(numout,*) ' T & S zonal mean and meridional stream function ln_diaznl = ', ln_diaznl
	470	WRITE(numout,*) ' Global (F) or glo/Atl/Pac/Ind/Indo-Pac basins ln_subbas = ', ln_subbas
	471	WRITE(numout,*) ' Frequency of computation nn_fptr = ', nn_fptr
	472	WRITE(numout,*) ' Frequency of outputs nn_fwri = ', nn_fwri
[134]	473	ENDIF
[3281]	474
	475	IF( ln_diaptr) THEN
	476
	477	IF( ln_subbas ) THEN ; nptr = 5 ! Global, Atlantic, Pacific, Indian, Indo-Pacific
	478	ELSE ; nptr = 1 ! Global only
	479	ENDIF
[134]	480
[3281]	481	! ! allocate dia_ptr arrays
	482	IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' )
[2528]	483
[3281]	484	rc_pwatt = rc_pwatt * rau0 * rcp ! conversion from K.s-1 to PetaWatt
[3168]	485
[3281]	486	IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum
[2528]	487
[3281]	488	IF( ln_subbas ) THEN ! load sub-basin mask
	489	CALL iom_open( 'subbasins', inum )
	490	CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin
	491	CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin
	492	CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin
	493	CALL iom_close( inum )
	494	btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin
	495	WHERE( gphit(:,:) < -30._wp) ; btm30(:,:) = 0._wp ! mask out Southern Ocean
	496	ELSE WHERE ; btm30(:,:) = tmask(:,:,1)
	497	END WHERE
	498	ENDIF
	499	btmsk(:,:,1) = tmask_i(:,:) ! global ocean
[1686]	500
[3281]	501	DO jn = 1, nptr
	502	btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only
	503	END DO
[1340]	504
[3281]	505	IF( lk_vvl ) CALL ctl_stop( 'diaptr: error in vvl case as constant i-mean surface is used' )
[134]	506
[3281]	507	! ! i-sum of e1v*e3v surface and its inverse
	508	DO jn = 1, nptr
	509	sjk(:,:,jn) = ptr_tjk( tmask(:,:,:), btmsk(:,:,jn) )
	510	r1_sjk(:,:,jn) = 0._wp
	511	WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn)
	512	END DO
[1340]	513
[3255]	514	! Initialise arrays to zero because diatpr is called before they are first calculated
	515	! Note that this means diagnostics will not be exactly correct when model run is restarted.
	516	htr_adv(:) = 0._wp ; str_adv(:) = 0._wp ; htr_ldf(:) = 0._wp ; str_ldf(:) = 0._wp
	517
[1397]	518	#if defined key_mpp_mpi
[3281]	519	iglo (1) = jpjglo ! MPP case using MPI ('key_mpp_mpi')
	520	iloc (1) = nlcj
	521	iabsf(1) = njmppt(narea)
	522	iabsl(:) = iabsf(:) + iloc(:) - 1
	523	ihals(1) = nldj - 1
	524	ihale(1) = nlcj - nlej
	525	idid (1) = 2
	526	CALL flio_dom_set( jpnj, nproc/jpni, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom_ptr )
[1397]	527	#else
[3281]	528	nidom_ptr = FLIO_DOM_NONE
[1397]	529	#endif
[3281]	530	ENDIF
[1559]	531	!
[3168]	532	IF( nn_timing == 1 ) CALL timing_stop('dia_ptr_init')
	533	!
[134]	534	END SUBROUTINE dia_ptr_init
	535
	536
	537	SUBROUTINE dia_ptr_wri( kt )
	538	!!---------------------------------------------------------------------
	539	!! * ROUTINE dia_ptr_wri *
	540	!!
	541	!! ** Purpose : output of poleward fluxes
	542	!!
	543	!! ** Method : NetCDF file
	544	!!----------------------------------------------------------------------
[2715]	545	!!
[134]	546	INTEGER, INTENT(in) :: kt ! ocean time-step index
[508]	547	!!
[1340]	548	INTEGER, SAVE :: nhoridz, ndepidzt, ndepidzw
[2715]	549	INTEGER, SAVE :: ndim , ndim_atl , ndim_pac , ndim_ind , ndim_ipc
	550	INTEGER, SAVE :: ndim_atl_30 , ndim_pac_30 , ndim_ind_30 , ndim_ipc_30
	551	INTEGER, SAVE :: ndim_h, ndim_h_atl_30, ndim_h_pac_30, ndim_h_ind_30, ndim_h_ipc_30
[2528]	552	!!
[2715]	553	CHARACTER (len=40) :: clhstnam, clop, clop_once, cl_comment ! temporary names
	554	INTEGER :: iline, it, itmod, ji, jj, jk !
[1636]	555	#if defined key_iomput
[2715]	556	INTEGER :: inum ! temporary logical unit
[1636]	557	#endif
[2715]	558	REAL(wp) :: zsto, zout, zdt, zjulian ! temporary scalars
[3168]	559	!!
	560	REAL(wp), POINTER, DIMENSION(:) :: zphi, zfoo ! 1D workspace
	561	REAL(wp), POINTER, DIMENSION(:,:) :: z_1 ! 2D workspace
	562	!!--------------------------------------------------------------------
	563	!
	564	CALL wrk_alloc( jpi , zphi , zfoo )
	565	CALL wrk_alloc( jpi , jpk, z_1 )
[1340]	566
[134]	567	! define time axis
[2528]	568	it = kt / nn_fptr
[1334]	569	itmod = kt - nit000 + 1
[1345]	570
[134]	571	! Initialization
	572	! --------------
	573	IF( kt == nit000 ) THEN
[2528]	574	niter = ( nit000 - 1 ) / nn_fptr
[1316]	575	zdt = rdt
[1559]	576	IF( nacc == 1 ) zdt = rdtmin
[2528]	577	!
	578	IF(lwp) THEN
	579	WRITE(numout,*)
	580	WRITE(numout,*) 'dia_ptr_wri : poleward transport and msf writing: initialization , niter = ', niter
	581	WRITE(numout,*) '~~~~~~~~~~~~'
	582	ENDIF
[134]	583
[2528]	584	! Reference latitude (used in plots)
[134]	585	! ------------------
	586	! ! =======================
	587	IF( cp_cfg == "orca" ) THEN ! ORCA configurations
	588	! ! =======================
	589	IF( jp_cfg == 05 ) iline = 192 ! i-line that passes near the North Pole
	590	IF( jp_cfg == 025 ) iline = 384 ! i-line that passes near the North Pole
[1345]	591	IF( jp_cfg == 1 ) iline = 96 ! i-line that passes near the North Pole
[134]	592	IF( jp_cfg == 2 ) iline = 48 ! i-line that passes near the North Pole
	593	IF( jp_cfg == 4 ) iline = 24 ! i-line that passes near the North Pole
[2715]	594	zphi(1:jpj) = 0._wp
[134]	595	DO ji = mi0(iline), mi1(iline)
[2715]	596	zphi(1:jpj) = gphiv(ji,:) ! if iline is in the local domain
[1340]	597	! Correct highest latitude for some configurations - will work if domain is parallelized in J ?
	598	IF( jp_cfg == 05 ) THEN
	599	DO jj = mj0(jpjdta), mj1(jpjdta)
[2528]	600	zphi( jj ) = zphi(mj0(jpjdta-1)) + ( zphi(mj0(jpjdta-1))-zphi(mj0(jpjdta-2)) ) * 0.5_wp
	601	zphi( jj ) = MIN( zphi(jj), 90._wp )
[1340]	602	END DO
	603	END IF
[1345]	604	IF( jp_cfg == 1 .OR. jp_cfg == 2 .OR. jp_cfg == 4 ) THEN
[1340]	605	DO jj = mj0(jpjdta-1), mj1(jpjdta-1)
[2528]	606	zphi( jj ) = 88.5_wp
[1340]	607	END DO
	608	DO jj = mj0(jpjdta ), mj1(jpjdta )
[2528]	609	zphi( jj ) = 89.5_wp
[1340]	610	END DO
	611	END IF
[134]	612	END DO
	613	! provide the correct zphi to all local domains
[1346]	614	#if defined key_mpp_mpi
	615	CALL mpp_sum( zphi, jpj, ncomm_znl )
	616	#endif
[134]	617	! ! =======================
[1559]	618	ELSE ! OTHER configurations
[134]	619	! ! =======================
[2715]	620	zphi(1:jpj) = gphiv(1,:) ! assume lat/lon coordinate, select the first i-line
[134]	621	!
	622	ENDIF
[1345]	623	!
	624	! Work only on westmost processor (will not work if mppini2 is used)
[1346]	625	#if defined key_mpp_mpi
[2528]	626	IF( l_znl_root ) THEN
[1346]	627	#endif
[1345]	628	!
	629	! OPEN netcdf file
	630	! ----------------
	631	! Define frequency of output and means
[2528]	632	zsto = nn_fptr * zdt
[1345]	633	IF( ln_mskland ) THEN ! put 1.e+20 on land (very expensive!!)
	634	clop = "ave(only(x))"
	635	clop_once = "once(only(x))"
	636	ELSE ! no use of the mask value (require less cpu time)
	637	clop = "ave(x)"
	638	clop_once = "once"
	639	ENDIF
[134]	640
[2528]	641	zout = nn_fwri * zdt
[2715]	642	zfoo(1:jpj) = 0._wp
[1340]	643
[2715]	644	CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian ) ! Compute julian date from starting date of the run
	645	zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment
[134]	646
[1636]	647	#if defined key_iomput
	648	! Requested by IPSL people, use by their postpro...
	649	IF(lwp) THEN
[2528]	650	CALL dia_nam( clhstnam, nn_fwri,' ' )
[1636]	651	CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea )
	652	WRITE(inum,*) clhstnam
	653	CLOSE(inum)
	654	ENDIF
	655	#endif
	656
[2528]	657	CALL dia_nam( clhstnam, nn_fwri, 'diaptr' )
[1345]	658	IF(lwp)WRITE( numout,*)" Name of diaptr NETCDF file : ", clhstnam
[134]	659
[1345]	660	! Horizontal grid : zphi()
	661	CALL histbeg(clhstnam, 1, zfoo, jpj, zphi, &
[2528]	662	1, 1, 1, jpj, niter, zjulian, zdt*nn_fptr, nhoridz, numptr, domain_id=nidom_ptr)
[1345]	663	! Vertical grids : gdept_0, gdepw_0
	664	CALL histvert( numptr, "deptht", "Vertical T levels", &
[2528]	665	& "m", jpk, gdept_0, ndepidzt, "down" )
[1345]	666	CALL histvert( numptr, "depthw", "Vertical W levels", &
[2528]	667	& "m", jpk, gdepw_0, ndepidzw, "down" )
[1345]	668	!
[2528]	669	CALL wheneq ( jpj*jpk, MIN(sjk(:,:,1), 1._wp), 1, 1., ndex , ndim ) ! Lat-Depth
	670	CALL wheneq ( jpj , MIN(sjk(:,1,1), 1._wp), 1, 1., ndex_h, ndim_h ) ! Lat
[1340]	671
[2528]	672	IF( ln_subbas ) THEN
	673	z_1(:,1) = 1._wp
	674	WHERE ( gphit(jpi/2,:) < -30._wp ) z_1(:,1) = 0._wp
[1345]	675	DO jk = 2, jpk
[2528]	676	z_1(:,jk) = z_1(:,1)
[1345]	677	END DO
[2528]	678	! ! Atlantic (jn=2)
	679	CALL wheneq ( jpj*jpk, MIN(sjk(:,:,2) , 1._wp), 1, 1., ndex_atl , ndim_atl ) ! Lat-Depth
	680	CALL wheneq ( jpjjpk, MIN(sjk(:,:,2)z_1(:,:), 1._wp), 1, 1., ndex_atl_30 , ndim_atl_30 ) ! Lat-Depth
	681	CALL wheneq ( jpj , MIN(sjk(:,1,2)*z_1(:,1), 1._wp), 1, 1., ndex_h_atl_30, ndim_h_atl_30 ) ! Lat
	682	! ! Pacific (jn=3)
	683	CALL wheneq ( jpj*jpk, MIN(sjk(:,:,3) , 1._wp), 1, 1., ndex_pac , ndim_pac ) ! Lat-Depth
	684	CALL wheneq ( jpjjpk, MIN(sjk(:,:,3)z_1(:,:), 1._wp), 1, 1., ndex_pac_30 , ndim_pac_30 ) ! Lat-Depth
	685	CALL wheneq ( jpj , MIN(sjk(:,1,3)*z_1(:,1), 1._wp), 1, 1., ndex_h_pac_30, ndim_h_pac_30 ) ! Lat
	686	! ! Indian (jn=4)
	687	CALL wheneq ( jpj*jpk, MIN(sjk(:,:,4) , 1._wp), 1, 1., ndex_ind , ndim_ind ) ! Lat-Depth
	688	CALL wheneq ( jpjjpk, MIN(sjk(:,:,4)z_1(:,:), 1._wp), 1, 1., ndex_ind_30 , ndim_ind_30 ) ! Lat-Depth
	689	CALL wheneq ( jpj , MIN(sjk(:,1,4)*z_1(:,1), 1._wp), 1, 1., ndex_h_ind_30, ndim_h_ind_30 ) ! Lat
	690	! ! Indo-Pacific (jn=5)
	691	CALL wheneq ( jpj*jpk, MIN(sjk(:,:,5) , 1._wp), 1, 1., ndex_ipc , ndim_ipc ) ! Lat-Depth
	692	CALL wheneq ( jpjjpk, MIN(sjk(:,:,5)z_1(:,:), 1._wp), 1, 1., ndex_ipc_30 , ndim_ipc_30 ) ! Lat-Depth
	693	CALL wheneq ( jpj , MIN(sjk(:,1,5)*z_1(:,1), 1._wp), 1, 1., ndex_h_ipc_30, ndim_h_ipc_30 ) ! Lat
[1345]	694	ENDIF
	695	!
[1340]	696	#if defined key_diaeiv
[1345]	697	cl_comment = ' (Bolus part included)'
[1340]	698	#else
[1345]	699	cl_comment = ' '
[1340]	700	#endif
[2715]	701	IF( ln_diaznl ) THEN ! Zonal mean T and S
[1345]	702	CALL histdef( numptr, "zotemglo", "Zonal Mean Temperature","C" , &
[1340]	703	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
[1345]	704	CALL histdef( numptr, "zosalglo", "Zonal Mean Salinity","PSU" , &
[1340]	705	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	706
[1345]	707	CALL histdef( numptr, "zosrfglo", "Zonal Mean Surface","m^2" , &
[1340]	708	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
[2715]	709	!
[1345]	710	IF (ln_subbas) THEN
	711	CALL histdef( numptr, "zotematl", "Zonal Mean Temperature: Atlantic","C" , &
	712	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	713	CALL histdef( numptr, "zosalatl", "Zonal Mean Salinity: Atlantic","PSU" , &
	714	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	715	CALL histdef( numptr, "zosrfatl", "Zonal Mean Surface: Atlantic","m^2" , &
	716	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
[1340]	717
[1345]	718	CALL histdef( numptr, "zotempac", "Zonal Mean Temperature: Pacific","C" , &
	719	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	720	CALL histdef( numptr, "zosalpac", "Zonal Mean Salinity: Pacific","PSU" , &
	721	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	722	CALL histdef( numptr, "zosrfpac", "Zonal Mean Surface: Pacific","m^2" , &
	723	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
	724
	725	CALL histdef( numptr, "zotemind", "Zonal Mean Temperature: Indian","C" , &
	726	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	727	CALL histdef( numptr, "zosalind", "Zonal Mean Salinity: Indian","PSU" , &
	728	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	729	CALL histdef( numptr, "zosrfind", "Zonal Mean Surface: Indian","m^2" , &
	730	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
	731
	732	CALL histdef( numptr, "zotemipc", "Zonal Mean Temperature: Pacific+Indian","C" , &
	733	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	734	CALL histdef( numptr, "zosalipc", "Zonal Mean Salinity: Pacific+Indian","PSU" , &
	735	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop, zsto, zout )
	736	CALL histdef( numptr, "zosrfipc", "Zonal Mean Surface: Pacific+Indian","m^2" , &
	737	1, jpj, nhoridz, jpk, 1, jpk, ndepidzt, 32, clop_once, zsto, zout )
	738	ENDIF
[1340]	739	ENDIF
[2715]	740	!
[1345]	741	! Meridional Stream-Function (Eulerian and Bolus)
	742	CALL histdef( numptr, "zomsfglo", "Meridional Stream-Function: Global"//TRIM(cl_comment),"Sv" , &
[406]	743	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
[1345]	744	IF( ln_subbas .AND. ln_diaznl ) THEN
	745	CALL histdef( numptr, "zomsfatl", "Meridional Stream-Function: Atlantic"//TRIM(cl_comment),"Sv" , &
	746	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
	747	CALL histdef( numptr, "zomsfpac", "Meridional Stream-Function: Pacific"//TRIM(cl_comment),"Sv" , &
	748	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
	749	CALL histdef( numptr, "zomsfind", "Meridional Stream-Function: Indian"//TRIM(cl_comment),"Sv" , &
	750	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
	751	CALL histdef( numptr, "zomsfipc", "Meridional Stream-Function: Indo-Pacific"//TRIM(cl_comment),"Sv" ,&
	752	1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
	753	ENDIF
[2715]	754	!
[1345]	755	! Heat transport
	756	CALL histdef( numptr, "sophtadv", "Advective Heat Transport" , &
[406]	757	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
[1345]	758	CALL histdef( numptr, "sophtldf", "Diffusive Heat Transport" , &
	759	"PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	760	IF ( ln_ptrcomp ) THEN
	761	CALL histdef( numptr, "sophtove", "Overturning Heat Transport" , &
	762	"PW",1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	763	END IF
	764	IF( ln_subbas ) THEN
	765	CALL histdef( numptr, "sohtatl", "Heat Transport Atlantic"//TRIM(cl_comment), &
	766	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	767	CALL histdef( numptr, "sohtpac", "Heat Transport Pacific"//TRIM(cl_comment) , &
	768	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	769	CALL histdef( numptr, "sohtind", "Heat Transport Indian"//TRIM(cl_comment) , &
	770	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	771	CALL histdef( numptr, "sohtipc", "Heat Transport Pacific+Indian"//TRIM(cl_comment), &
	772	"PW", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	773	ENDIF
[2715]	774	!
[1345]	775	! Salt transport
	776	CALL histdef( numptr, "sopstadv", "Advective Salt Transport" , &
[406]	777	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
[1345]	778	CALL histdef( numptr, "sopstldf", "Diffusive Salt Transport" , &
[406]	779	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
[1345]	780	IF ( ln_ptrcomp ) THEN
	781	CALL histdef( numptr, "sopstove", "Overturning Salt Transport" , &
	782	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	783	END IF
	784	#if defined key_diaeiv
	785	! Eddy induced velocity
	786	CALL histdef( numptr, "zomsfeiv", "Bolus Meridional Stream-Function: global", &
	787	"Sv" , 1, jpj, nhoridz, jpk, 1, jpk, ndepidzw, 32, clop, zsto, zout )
	788	CALL histdef( numptr, "sophteiv", "Bolus Advective Heat Transport", &
	789	"PW" , 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	790	CALL histdef( numptr, "sopsteiv", "Bolus Advective Salt Transport", &
[406]	791	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
[1345]	792	#endif
	793	IF( ln_subbas ) THEN
	794	CALL histdef( numptr, "sostatl", "Salt Transport Atlantic"//TRIM(cl_comment) , &
	795	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	796	CALL histdef( numptr, "sostpac", "Salt Transport Pacific"//TRIM(cl_comment) , &
	797	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	798	CALL histdef( numptr, "sostind", "Salt Transport Indian"//TRIM(cl_comment) , &
	799	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	800	CALL histdef( numptr, "sostipc", "Salt Transport Pacific+Indian"//TRIM(cl_comment), &
	801	"Giga g/s", 1, jpj, nhoridz, 1, 1, 1, -99, 32, clop, zsto, zout )
	802	ENDIF
[2715]	803	!
[1345]	804	CALL histend( numptr )
[2715]	805	!
[1345]	806	END IF
[1346]	807	#if defined key_mpp_mpi
[1345]	808	END IF
[1346]	809	#endif
[134]	810
[1346]	811	#if defined key_mpp_mpi
[2528]	812	IF( MOD( itmod, nn_fptr ) == 0 .AND. l_znl_root ) THEN
[1346]	813	#else
[2528]	814	IF( MOD( itmod, nn_fptr ) == 0 ) THEN
[1346]	815	#endif
[1345]	816	niter = niter + 1
[406]	817
[2528]	818	IF( ln_diaznl ) THEN
	819	CALL histwrite( numptr, "zosrfglo", niter, sjk (:,:,1) , ndim, ndex )
	820	CALL histwrite( numptr, "zotemglo", niter, tn_jk(:,:,1) , ndim, ndex )
	821	CALL histwrite( numptr, "zosalglo", niter, sn_jk(:,:,1) , ndim, ndex )
[1345]	822
[1340]	823	IF (ln_subbas) THEN
[2528]	824	CALL histwrite( numptr, "zosrfatl", niter, sjk(:,:,2), ndim_atl, ndex_atl )
	825	CALL histwrite( numptr, "zosrfpac", niter, sjk(:,:,3), ndim_pac, ndex_pac )
	826	CALL histwrite( numptr, "zosrfind", niter, sjk(:,:,4), ndim_ind, ndex_ind )
	827	CALL histwrite( numptr, "zosrfipc", niter, sjk(:,:,5), ndim_ipc, ndex_ipc )
[1340]	828
[2528]	829	CALL histwrite( numptr, "zotematl", niter, tn_jk(:,:,2) , ndim_atl, ndex_atl )
	830	CALL histwrite( numptr, "zosalatl", niter, sn_jk(:,:,2) , ndim_atl, ndex_atl )
	831	CALL histwrite( numptr, "zotempac", niter, tn_jk(:,:,3) , ndim_pac, ndex_pac )
	832	CALL histwrite( numptr, "zosalpac", niter, sn_jk(:,:,3) , ndim_pac, ndex_pac )
	833	CALL histwrite( numptr, "zotemind", niter, tn_jk(:,:,4) , ndim_ind, ndex_ind )
	834	CALL histwrite( numptr, "zosalind", niter, sn_jk(:,:,4) , ndim_ind, ndex_ind )
	835	CALL histwrite( numptr, "zotemipc", niter, tn_jk(:,:,5) , ndim_ipc, ndex_ipc )
	836	CALL histwrite( numptr, "zosalipc", niter, sn_jk(:,:,5) , ndim_ipc, ndex_ipc )
[1340]	837	END IF
	838	ENDIF
	839
[406]	840	! overturning outputs:
[2528]	841	CALL histwrite( numptr, "zomsfglo", niter, v_msf(:,:,1), ndim, ndex )
[1340]	842	IF( ln_subbas .AND. ln_diaznl ) THEN
[2528]	843	CALL histwrite( numptr, "zomsfatl", niter, v_msf(:,:,2) , ndim_atl_30, ndex_atl_30 )
	844	CALL histwrite( numptr, "zomsfpac", niter, v_msf(:,:,3) , ndim_pac_30, ndex_pac_30 )
	845	CALL histwrite( numptr, "zomsfind", niter, v_msf(:,:,4) , ndim_ind_30, ndex_ind_30 )
	846	CALL histwrite( numptr, "zomsfipc", niter, v_msf(:,:,5) , ndim_ipc_30, ndex_ipc_30 )
[406]	847	ENDIF
[1340]	848	#if defined key_diaeiv
[2528]	849	CALL histwrite( numptr, "zomsfeiv", niter, v_msf_eiv(:,:,1), ndim , ndex )
[1340]	850	#endif
[406]	851
[1345]	852	! heat transport outputs:
	853	IF( ln_subbas ) THEN
[2528]	854	CALL histwrite( numptr, "sohtatl", niter, htr(:,2) , ndim_h_atl_30, ndex_h_atl_30 )
	855	CALL histwrite( numptr, "sohtpac", niter, htr(:,3) , ndim_h_pac_30, ndex_h_pac_30 )
	856	CALL histwrite( numptr, "sohtind", niter, htr(:,4) , ndim_h_ind_30, ndex_h_ind_30 )
	857	CALL histwrite( numptr, "sohtipc", niter, htr(:,5) , ndim_h_ipc_30, ndex_h_ipc_30 )
	858	CALL histwrite( numptr, "sostatl", niter, str(:,2) , ndim_h_atl_30, ndex_h_atl_30 )
	859	CALL histwrite( numptr, "sostpac", niter, str(:,3) , ndim_h_pac_30, ndex_h_pac_30 )
	860	CALL histwrite( numptr, "sostind", niter, str(:,4) , ndim_h_ind_30, ndex_h_ind_30 )
	861	CALL histwrite( numptr, "sostipc", niter, str(:,5) , ndim_h_ipc_30, ndex_h_ipc_30 )
[1345]	862	ENDIF
[1340]	863
[2528]	864	CALL histwrite( numptr, "sophtadv", niter, htr_adv , ndim_h, ndex_h )
	865	CALL histwrite( numptr, "sophtldf", niter, htr_ldf , ndim_h, ndex_h )
	866	CALL histwrite( numptr, "sopstadv", niter, str_adv , ndim_h, ndex_h )
	867	CALL histwrite( numptr, "sopstldf", niter, str_ldf , ndim_h, ndex_h )
	868	IF( ln_ptrcomp ) THEN
	869	CALL histwrite( numptr, "sopstove", niter, str_ove(:) , ndim_h, ndex_h )
	870	CALL histwrite( numptr, "sophtove", niter, htr_ove(:) , ndim_h, ndex_h )
[1345]	871	ENDIF
[134]	872	#if defined key_diaeiv
[2528]	873	CALL histwrite( numptr, "sophteiv", niter, htr_eiv(:,1) , ndim_h, ndex_h )
	874	CALL histwrite( numptr, "sopsteiv", niter, str_eiv(:,1) , ndim_h, ndex_h )
[134]	875	#endif
[1345]	876	!
	877	ENDIF
[508]	878	!
[3168]	879	CALL wrk_dealloc( jpi , zphi , zfoo )
	880	CALL wrk_dealloc( jpi , jpk, z_1 )
[2715]	881	!
	882	END SUBROUTINE dia_ptr_wri
[134]	883
	884	!!======================================================================
	885	END MODULE diaptr

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

Download in other formats: