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

Context Navigation

source: branches/2016/dev_r7233_CMIP6_diags_trunk_version/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90 @ 7236

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

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

Download in other formats: