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

Context Navigation

source: branches/2013/dev_LOCEAN_2013/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90 @ 4234

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

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

Download in other formats: