Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

diaptr.F90 @ 14586

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

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

New URL for NEMO forge! http://forge.nemo-ocean.eu

Context Navigation

source: branches/UKMO/dev_r5518_GO6_package_FOAMv14/NEMOGCM/NEMO/OPA_SRC/DIA/diaptr.F90 @ 14586

Download in other formats: