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 NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA – NEMO

Context Navigation

source: NEMO/branches/2020/r12377_ticket2386/src/OCE/DIA/diaptr.F90 @ 13694

Last change on this file since 13694 was 13694, checked in by andmirek, 3 years ago
Ticket #2386: merge with trunk rev 13688
Property svn:keywords set to `Id`
File size: 27.5 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
[7646]	11	!! 3.6 ! 2016-06 (T. Graham) Addition of diagnostics for CMIP6
[12276]	12	!! 4.0 ! 2010-08 ( C. Ethe, J. Deshayes ) Improvment
[134]	13	!!----------------------------------------------------------------------
[508]	14
	15	!!----------------------------------------------------------------------
[134]	16	!! dia_ptr : Poleward Transport Diagnostics module
	17	!! dia_ptr_init : Initialization, namelist read
[5147]	18	!! ptr_sjk : "zonal" mean computation of a field - tracer or flux array
	19	!! ptr_sj : "zonal" and vertical sum computation of a "meridional" flux array
	20	!! (Generic interface to ptr_sj_3d, ptr_sj_2d)
[134]	21	!!----------------------------------------------------------------------
[2528]	22	USE oce ! ocean dynamics and active tracers
	23	USE dom_oce ! ocean space and time domain
	24	USE phycst ! physical constants
[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
[508]	38	PUBLIC dia_ptr ! call in step module
[7646]	39	PUBLIC dia_ptr_hst ! called from tra_ldf/tra_adv routines
[134]	40
[12276]	41	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_adv, hstr_ldf, hstr_eiv !: Heat/Salt TRansports(adv, diff, Bolus.)
	42	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hstr_ove, hstr_btr, hstr_vtr !: heat Salt TRansports(overturn, baro, merional)
[1345]	43
[13694]	44	LOGICAL, PUBLIC :: l_diaptr !: tracers trend flag
[2715]	45
[2528]	46	REAL(wp) :: rc_sv = 1.e-6_wp ! conversion from m3/s to Sverdrup
[12511]	47	REAL(wp) :: rc_pwatt = 1.e-15_wp ! conversion from W to PW (further x rho0 x Cp)
	48	REAL(wp) :: rc_ggram = 1.e-9_wp ! conversion from g to Gg (further x rho0)
[134]	49
[12276]	50	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk ! T-point basin interior masks
	51	REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: btmsk34 ! mask out Southern Ocean (=0 south of 34°S)
[2715]	52
[12276]	53	REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:) :: p_fval1d
	54	REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d
[2715]	55
[13694]	56	LOGICAL :: ll_init = .TRUE. !: tracers trend flag
[13540]	57
[134]	58	!! * Substitutions
[12377]	59	# include "do_loop_substitute.h90"
[13540]	60	# include "domzgr_substitute.h90"
[134]	61	!!----------------------------------------------------------------------
[9598]	62	!! NEMO/OCE 4.0 , NEMO Consortium (2018)
[7753]	63	!! $Id$
[10068]	64	!! Software governed by the CeCILL license (see ./LICENSE)
[134]	65	!!----------------------------------------------------------------------
	66	CONTAINS
	67
[12377]	68	SUBROUTINE dia_ptr( kt, Kmm, pvtr )
[5147]	69	!!----------------------------------------------------------------------
	70	!! * ROUTINE dia_ptr *
	71	!!----------------------------------------------------------------------
[12377]	72	INTEGER , INTENT(in) :: kt ! ocean time-step index
	73	INTEGER , INTENT(in) :: Kmm ! time level index
[5147]	74	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport
	75	!
	76	INTEGER :: ji, jj, jk, jn ! dummy loop indices
[7646]	77	REAL(wp) :: zsfc,zvfc ! local scalar
[5147]	78	REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace
	79	REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask ! 3D workspace
[12276]	80	REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace
[5147]	81	REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace
[12276]	82	REAL(wp), DIMENSION(jpj) :: zvsum, ztsum, zssum ! 1D workspace
[7646]	83	!
	84	!overturning calculation
[13694]	85	REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse
	86	REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: zt_jk, zs_jk ! i-mean T and S, j-Stream-Function
[7646]	87
[13694]	88	REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: z4d1, z4d2
	89	REAL(wp), DIMENSION(:,:,: ), ALLOCATABLE :: z3dtr
[5147]	90	!!----------------------------------------------------------------------
	91	!
[9124]	92	IF( ln_timing ) CALL timing_start('dia_ptr')
[12377]	93
[13694]	94	IF( kt == nit000 .AND. ll_init ) CALL dia_ptr_init ! -> will define l_diaptr and nbasin
[5147]	95	!
[13694]	96	IF( .NOT. l_diaptr ) THEN
	97	IF( ln_timing ) CALL timing_stop('dia_ptr')
	98	RETURN
	99	ENDIF
	100	!
	101	ALLOCATE( z3dtr(jpi,jpj,nbasin) )
	102	!
[5147]	103	IF( PRESENT( pvtr ) ) THEN
[12276]	104	IF( iom_use( 'zomsf' ) ) THEN ! effective MSF
[13694]	105	ALLOCATE( z4d1(jpi,jpj,jpk,nbasin) )
	106	DO jn = 1, nbasin ! by sub-basins
[12276]	107	z4d1(1,:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) ) ! zonal cumulative effective transport excluding closed seas
	108	DO jk = jpkm1, 1, -1
	109	z4d1(1,:,jk,jn) = z4d1(1,:,jk+1,jn) - z4d1(1,:,jk,jn) ! effective j-Stream-Function (MSF)
[5147]	110	END DO
	111	DO ji = 1, jpi
[12276]	112	z4d1(ji,:,:,jn) = z4d1(1,:,:,jn)
[5147]	113	ENDDO
	114	END DO
[12276]	115	CALL iom_put( 'zomsf', z4d1 * rc_sv )
[13694]	116	DEALLOCATE( z4d1 )
[5147]	117	ENDIF
[12276]	118	IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. &
	119	& iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN
[7646]	120	! define fields multiplied by scalar
	121	zmask(:,:,:) = 0._wp
	122	zts(:,:,:,:) = 0._wp
[13540]	123	DO_3D( 1, 0, 1, 1, 1, jpkm1 )
[12377]	124	zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm)
	125	zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc
	126	zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc !Tracers averaged onto V grid
	127	zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc
	128	END_3D
[7646]	129	ENDIF
[12276]	130	IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN
[13694]	131	DO jn = 1, nbasin
	132	ALLOCATE( sjk(jpj,jpk,nbasin), r1_sjk(jpj,jpk,nbasin), v_msf(jpj,jpk,nbasin), &
	133	& zt_jk(jpj,jpk,nbasin), zs_jk(jpj,jpk,nbasin) )
[12276]	134	sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
	135	r1_sjk(:,:,jn) = 0._wp
	136	WHERE( sjk(:,:,jn) /= 0._wp ) r1_sjk(:,:,jn) = 1._wp / sjk(:,:,jn)
	137	! i-mean T and S, j-Stream-Function, basin
	138	zt_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
	139	zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn)
	140	v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,jn) )
	141	hstr_ove(:,jp_tem,jn) = SUM( v_msf(:,:,jn)*zt_jk(:,:,jn), 2 )
	142	hstr_ove(:,jp_sal,jn) = SUM( v_msf(:,:,jn)*zs_jk(:,:,jn), 2 )
[13694]	143	DEALLOCATE( sjk, r1_sjk, v_msf, zt_jk, zs_jk )
[12276]	144	!
	145	ENDDO
[13694]	146	DO jn = 1, nbasin
[12276]	147	z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
	148	DO ji = 1, jpi
	149	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
	150	ENDDO
	151	ENDDO
	152	CALL iom_put( 'sophtove', z3dtr )
[13694]	153	DO jn = 1, nbasin
[12276]	154	z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
	155	DO ji = 1, jpi
	156	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
	157	ENDDO
	158	ENDDO
	159	CALL iom_put( 'sopstove', z3dtr )
	160	ENDIF
[11993]	161
[12276]	162	IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN
	163	! Calculate barotropic heat and salt transport here
[13694]	164	DO jn = 1, nbasin
	165	ALLOCATE( sjk(jpj,1,nbasin), r1_sjk(jpj,1,nbasin) )
[12276]	166	sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) )
	167	r1_sjk(:,1,jn) = 0._wp
	168	WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn)
	169	!
	170	zvsum(:) = ptr_sj( pvtr(:,:,:), btmsk34(:,:,jn) )
	171	ztsum(:) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) )
	172	zssum(:) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) )
	173	hstr_btr(:,jp_tem,jn) = zvsum(:) * ztsum(:) * r1_sjk(:,1,jn)
	174	hstr_btr(:,jp_sal,jn) = zvsum(:) * zssum(:) * r1_sjk(:,1,jn)
[13694]	175	DEALLOCATE( sjk, r1_sjk )
[12276]	176	!
[7646]	177	ENDDO
[13694]	178	DO jn = 1, nbasin
[12276]	179	z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
	180	DO ji = 1, jpi
	181	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
	182	ENDDO
[7646]	183	ENDDO
[12276]	184	CALL iom_put( 'sophtbtr', z3dtr )
[13694]	185	DO jn = 1, nbasin
[12276]	186	z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
	187	DO ji = 1, jpi
	188	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
[7646]	189	ENDDO
[12276]	190	ENDDO
	191	CALL iom_put( 'sopstbtr', z3dtr )
	192	ENDIF
[5147]	193	!
	194	ELSE
	195	!
[12276]	196	zmask(:,:,:) = 0._wp
	197	zts(:,:,:,:) = 0._wp
	198	IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface
[13694]	199	ALLOCATE( z4d1(jpi,jpj,jpk,nbasin), z4d2(jpi,jpj,jpk,nbasin) )
[13540]	200	DO_3D( 1, 1, 1, 1, 1, jpkm1 )
[12377]	201	zsfc = e1t(ji,jj) * e3t(ji,jj,jk,Kmm)
	202	zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc
	203	zts(ji,jj,jk,jp_tem) = ts(ji,jj,jk,jp_tem,Kmm) * zsfc
	204	zts(ji,jj,jk,jp_sal) = ts(ji,jj,jk,jp_sal,Kmm) * zsfc
	205	END_3D
[12276]	206	!
[13694]	207	DO jn = 1, nbasin
[5147]	208	zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) )
[13694]	209	DO ji = 1, jpi
	210	zmask(ji,:,:) = zmask(1,:,:)
	211	ENDDO
[12276]	212	z4d1(:,:,:,jn) = zmask(:,:,:)
	213	ENDDO
	214	CALL iom_put( 'zosrf', z4d1 )
	215	!
[13694]	216	DO jn = 1, nbasin
[12276]	217	z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) &
	218	& / MAX( z4d1(1,:,:,jn), 10.e-15 )
[5147]	219	DO ji = 1, jpi
[12276]	220	z4d2(ji,:,:,jn) = z4d2(1,:,:,jn)
[5147]	221	ENDDO
[12276]	222	ENDDO
	223	CALL iom_put( 'zotem', z4d2 )
	224	!
[13694]	225	DO jn = 1, nbasin
[12276]	226	z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) &
	227	& / MAX( z4d1(1,:,:,jn), 10.e-15 )
[5147]	228	DO ji = 1, jpi
[12276]	229	z4d2(ji,:,:,jn) = z4d2(1,:,:,jn)
[5147]	230	ENDDO
[12276]	231	ENDDO
	232	CALL iom_put( 'zosal', z4d2 )
[13694]	233	DEALLOCATE( z4d1, z4d2 )
[12276]	234	!
[5147]	235	ENDIF
	236	!
	237	! ! Advective and diffusive heat and salt transport
[12276]	238	IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN
	239	!
[13694]	240	DO jn = 1, nbasin
[12276]	241	z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
	242	DO ji = 1, jpi
	243	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
	244	ENDDO
[11993]	245	ENDDO
[12276]	246	CALL iom_put( 'sophtadv', z3dtr )
[13694]	247	DO jn = 1, nbasin
[12276]	248	z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
	249	DO ji = 1, jpi
	250	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
	251	ENDDO
[11993]	252	ENDDO
[12276]	253	CALL iom_put( 'sopstadv', z3dtr )
	254	ENDIF
	255	!
	256	IF( iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) ) THEN
	257	!
[13694]	258	DO jn = 1, nbasin
[12276]	259	z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
[11989]	260	DO ji = 1, jpi
[12276]	261	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
[11989]	262	ENDDO
[12276]	263	ENDDO
	264	CALL iom_put( 'sophtldf', z3dtr )
[13694]	265	DO jn = 1, nbasin
[12276]	266	z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
[11989]	267	DO ji = 1, jpi
[12276]	268	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
[11989]	269	ENDDO
[12276]	270	ENDDO
	271	CALL iom_put( 'sopstldf', z3dtr )
[11989]	272	ENDIF
	273	!
[12276]	274	IF( iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) ) THEN
	275	!
[13694]	276	DO jn = 1, nbasin
[12276]	277	z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
[7646]	278	DO ji = 1, jpi
[12276]	279	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
[7646]	280	ENDDO
[12276]	281	ENDDO
	282	CALL iom_put( 'sophteiv', z3dtr )
[13694]	283	DO jn = 1, nbasin
[12276]	284	z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
[7646]	285	DO ji = 1, jpi
[12276]	286	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
[7646]	287	ENDDO
[12276]	288	ENDDO
	289	CALL iom_put( 'sopsteiv', z3dtr )
[11993]	290	ENDIF
[12276]	291	!
	292	IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN
	293	zts(:,:,:,:) = 0._wp
[13540]	294	DO_3D( 1, 0, 1, 1, 1, jpkm1 )
[12377]	295	zvfc = e1v(ji,jj) * e3v(ji,jj,jk,Kmm)
	296	zts(ji,jj,jk,jp_tem) = (ts(ji,jj,jk,jp_tem,Kmm)+ts(ji,jj+1,jk,jp_tem,Kmm)) * 0.5 * zvfc !Tracers averaged onto V grid
	297	zts(ji,jj,jk,jp_sal) = (ts(ji,jj,jk,jp_sal,Kmm)+ts(ji,jj+1,jk,jp_sal,Kmm)) * 0.5 * zvfc
	298	END_3D
[12276]	299	CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) )
	300	CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) )
[13694]	301	DO jn = 1, nbasin
[12276]	302	z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW)
	303	DO ji = 1, jpi
	304	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
	305	ENDDO
	306	ENDDO
	307	CALL iom_put( 'sophtvtr', z3dtr )
[13694]	308	DO jn = 1, nbasin
[12276]	309	z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg)
	310	DO ji = 1, jpi
	311	z3dtr(ji,:,jn) = z3dtr(1,:,jn)
	312	ENDDO
	313	ENDDO
	314	CALL iom_put( 'sopstvtr', z3dtr )
[7646]	315	ENDIF
[5147]	316	!
[12276]	317	IF( iom_use( 'uocetr_vsum_cumul' ) ) THEN
	318	CALL iom_get_var( 'uocetr_vsum_op', z2d ) ! get uocetr_vsum_op from xml
	319	z2d(:,:) = ptr_ci_2d( z2d(:,:) )
	320	CALL iom_put( 'uocetr_vsum_cumul', z2d )
	321	ENDIF
	322	!
[5147]	323	ENDIF
	324	!
[13694]	325	DEALLOCATE( z3dtr )
	326	!
[9124]	327	IF( ln_timing ) CALL timing_stop('dia_ptr')
[5147]	328	!
	329	END SUBROUTINE dia_ptr
	330
	331
	332	SUBROUTINE dia_ptr_init
	333	!!----------------------------------------------------------------------
	334	!! * ROUTINE dia_ptr_init *
	335	!!
[13694]	336	!! ** Purpose : Initialization
[5147]	337	!!----------------------------------------------------------------------
[12377]	338	INTEGER :: inum, jn ! local integers
[5147]	339	!!
[12276]	340	REAL(wp), DIMENSION(jpi,jpj) :: zmsk
[5147]	341	!!----------------------------------------------------------------------
[13694]	342
	343	! l_diaptr is defined with iom_use
	344	! --> dia_ptr_init must be done after the call to iom_init
	345	! --> cannot be .TRUE. without cpp key: key_iom --> nbasin define by iom_init is initialized
	346	l_diaptr = iom_use( 'zomsf' ) .OR. iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. &
	347	& iom_use( 'zosrf' ) .OR. iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. &
	348	& iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) .OR. iom_use( 'sophtadv' ) .OR. &
	349	& iom_use( 'sopstadv' ) .OR. iom_use( 'sophtldf' ) .OR. iom_use( 'sopstldf' ) .OR. &
	350	& iom_use( 'sophteiv' ) .OR. iom_use( 'sopsteiv' ) .OR. iom_use( 'sopstvtr' ) .OR. &
	351	& iom_use( 'sophtvtr' ) .OR. iom_use( 'uocetr_vsum_cumul' )
[12377]	352
[5147]	353	IF(lwp) THEN ! Control print
	354	WRITE(numout,*)
	355	WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization'
	356	WRITE(numout,*) '~~~~~~~~~~~~'
[12377]	357	WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) l_diaptr = ', l_diaptr
[5147]	358	ENDIF
	359
[12377]	360	IF( l_diaptr ) THEN
[5147]	361	!
	362	IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' )
[13694]	363	!
[12511]	364	rc_pwatt = rc_pwatt * rho0_rcp ! conversion from K.s-1 to PetaWatt
	365	rc_ggram = rc_ggram * rho0 ! conversion from m3/s to Gg/s
[5147]	366
	367	IF( lk_mpp ) CALL mpp_ini_znl( numout ) ! Define MPI communicator for zonal sum
	368
[12276]	369	btmsk(:,:,1) = tmask_i(:,:)
[13694]	370	IF( nbasin == 5 ) THEN ! nbasin has been initialized in iom_init to define the axis "basin"
	371	CALL iom_open( 'subbasins', inum )
	372	CALL iom_get( inum, jpdom_global, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin
	373	CALL iom_get( inum, jpdom_global, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin
	374	CALL iom_get( inum, jpdom_global, 'indmsk', btmsk(:,:,4) ) ! Indian basin
	375	CALL iom_close( inum )
	376	btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin
	377	ENDIF
	378	DO jn = 2, nbasin
	379	btmsk(:,:,jn) = btmsk(:,:,jn) * tmask_i(:,:) ! interior domain only
[5147]	380	END DO
[12276]	381	! JD : modification so that overturning streamfunction is available in Atlantic at 34S to compare with observations
	382	WHERE( gphit(:,:)*tmask_i(:,:) < -34._wp)
	383	zmsk(:,:) = 0._wp ! mask out Southern Ocean
	384	ELSE WHERE
	385	zmsk(:,:) = ssmask(:,:)
	386	END WHERE
	387	btmsk34(:,:,1) = btmsk(:,:,1)
[13694]	388	DO jn = 2, nbasin
	389	btmsk34(:,:,jn) = btmsk(:,:,jn) * zmsk(:,:) ! interior domain only
[12276]	390	ENDDO
[5147]	391
	392	! Initialise arrays to zero because diatpr is called before they are first calculated
	393	! Note that this means diagnostics will not be exactly correct when model run is restarted.
[12276]	394	hstr_adv(:,:,:) = 0._wp
	395	hstr_ldf(:,:,:) = 0._wp
	396	hstr_eiv(:,:,:) = 0._wp
	397	hstr_ove(:,:,:) = 0._wp
	398	hstr_btr(:,:,:) = 0._wp !
	399	hstr_vtr(:,:,:) = 0._wp !
[7753]	400	!
[12377]	401	ll_init = .FALSE.
	402	!
[5147]	403	ENDIF
	404	!
	405	END SUBROUTINE dia_ptr_init
	406
[9124]	407
[12377]	408	SUBROUTINE dia_ptr_hst( ktra, cptr, pvflx )
[7646]	409	!!----------------------------------------------------------------------
	410	!! * ROUTINE dia_ptr_hst *
	411	!!----------------------------------------------------------------------
	412	!! Wrapper for heat and salt transport calculations to calculate them for each basin
	413	!! Called from all advection and/or diffusion routines
	414	!!----------------------------------------------------------------------
	415	INTEGER , INTENT(in ) :: ktra ! tracer index
	416	CHARACTER(len=3) , INTENT(in) :: cptr ! transport type 'adv'/'ldf'/'eiv'
[12377]	417	REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pvflx ! 3D input array of advection/diffusion
[7646]	418	INTEGER :: jn !
[5147]	419
[12276]	420	!
[7646]	421	IF( cptr == 'adv' ) THEN
[12276]	422	IF( ktra == jp_tem ) THEN
[13694]	423	DO jn = 1, nbasin
[12377]	424	hstr_adv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
[12276]	425	ENDDO
	426	ENDIF
	427	IF( ktra == jp_sal ) THEN
[13694]	428	DO jn = 1, nbasin
[12377]	429	hstr_adv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
[12276]	430	ENDDO
	431	ENDIF
[7646]	432	ENDIF
[12276]	433	!
[7646]	434	IF( cptr == 'ldf' ) THEN
[12276]	435	IF( ktra == jp_tem ) THEN
[13694]	436	DO jn = 1, nbasin
[12377]	437	hstr_ldf(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
[12276]	438	ENDDO
	439	ENDIF
	440	IF( ktra == jp_sal ) THEN
[13694]	441	DO jn = 1, nbasin
[12377]	442	hstr_ldf(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
[12276]	443	ENDDO
	444	ENDIF
[7646]	445	ENDIF
[12276]	446	!
[7646]	447	IF( cptr == 'eiv' ) THEN
[12276]	448	IF( ktra == jp_tem ) THEN
[13694]	449	DO jn = 1, nbasin
[12377]	450	hstr_eiv(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
[12276]	451	ENDDO
	452	ENDIF
	453	IF( ktra == jp_sal ) THEN
[13694]	454	DO jn = 1, nbasin
[12377]	455	hstr_eiv(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
[12276]	456	ENDDO
	457	ENDIF
[7646]	458	ENDIF
	459	!
[12276]	460	IF( cptr == 'vtr' ) THEN
	461	IF( ktra == jp_tem ) THEN
[13694]	462	DO jn = 1, nbasin
[12377]	463	hstr_vtr(:,jp_tem,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
[12276]	464	ENDDO
[7646]	465	ENDIF
[12276]	466	IF( ktra == jp_sal ) THEN
[13694]	467	DO jn = 1, nbasin
[12377]	468	hstr_vtr(:,jp_sal,jn) = ptr_sj( pvflx(:,:,:), btmsk(:,:,jn) )
[12276]	469	ENDDO
[7646]	470	ENDIF
	471	ENDIF
[12276]	472	!
[7646]	473	END SUBROUTINE dia_ptr_hst
	474
	475
[2715]	476	FUNCTION dia_ptr_alloc()
	477	!!----------------------------------------------------------------------
	478	!! * ROUTINE dia_ptr_alloc *
	479	!!----------------------------------------------------------------------
	480	INTEGER :: dia_ptr_alloc ! return value
[5147]	481	INTEGER, DIMENSION(3) :: ierr
[2715]	482	!!----------------------------------------------------------------------
	483	ierr(:) = 0
	484	!
[13694]	485	! nbasin has been initialized in iom_init to define the axis "basin"
	486	!
[12276]	487	IF( .NOT. ALLOCATED( btmsk ) ) THEN
[13694]	488	ALLOCATE( btmsk(jpi,jpj,nbasin) , btmsk34(jpi,jpj,nbasin), &
	489	& hstr_adv(jpj,jpts,nbasin), hstr_eiv(jpj,jpts,nbasin), &
	490	& hstr_ove(jpj,jpts,nbasin), hstr_btr(jpj,jpts,nbasin), &
	491	& hstr_ldf(jpj,jpts,nbasin), hstr_vtr(jpj,jpts,nbasin), STAT=ierr(1) )
[12276]	492	!
	493	ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), Stat=ierr(2))
[2715]	494	!
[12276]	495	dia_ptr_alloc = MAXVAL( ierr )
	496	CALL mpp_sum( 'diaptr', dia_ptr_alloc )
	497	ENDIF
[2715]	498	!
	499	END FUNCTION dia_ptr_alloc
	500
	501
[12377]	502	FUNCTION ptr_sj_3d( pvflx, pmsk ) RESULT ( p_fval )
[134]	503	!!----------------------------------------------------------------------
[5147]	504	!! * ROUTINE ptr_sj_3d *
[134]	505	!!
[2528]	506	!! ** Purpose : i-k sum computation of a j-flux array
[134]	507	!!
[12377]	508	!! ** Method : - i-k sum of pvflx using the interior 2D vmask (vmask_i).
	509	!! pvflx is supposed to be a masked flux (i.e. * vmaske1ve3v)
[134]	510	!!
[12377]	511	!! ** Action : - p_fval: i-k-mean poleward flux of pvflx
[508]	512	!!----------------------------------------------------------------------
[12377]	513	REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pvflx ! mask flux array at V-point
[12276]	514	REAL(wp), INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask
[5147]	515	!
[508]	516	INTEGER :: ji, jj, jk ! dummy loop arguments
	517	INTEGER :: ijpj ! ???
[2715]	518	REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
[134]	519	!!--------------------------------------------------------------------
[508]	520	!
[2715]	521	p_fval => p_fval1d
	522
[389]	523	ijpj = jpj
[2528]	524	p_fval(:) = 0._wp
[13540]	525	DO_3D( 0, 0, 0, 0, 1, jpkm1 )
[12377]	526	p_fval(jj) = p_fval(jj) + pvflx(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj)
	527	END_3D
[1346]	528	#if defined key_mpp_mpi
[10425]	529	CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl)
[1346]	530	#endif
[508]	531	!
[5147]	532	END FUNCTION ptr_sj_3d
[134]	533
	534
[12377]	535	FUNCTION ptr_sj_2d( pvflx, pmsk ) RESULT ( p_fval )
[134]	536	!!----------------------------------------------------------------------
[5147]	537	!! * ROUTINE ptr_sj_2d *
[134]	538	!!
[12377]	539	!! ** Purpose : "zonal" and vertical sum computation of a j-flux array
[134]	540	!!
[12377]	541	!! ** Method : - i-k sum of pvflx using the interior 2D vmask (vmask_i).
	542	!! pvflx is supposed to be a masked flux (i.e. * vmaske1ve3v)
[134]	543	!!
[12377]	544	!! ** Action : - p_fval: i-k-mean poleward flux of pvflx
[508]	545	!!----------------------------------------------------------------------
[12377]	546	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pvflx ! mask flux array at V-point
[12276]	547	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask
[5147]	548	!
[2715]	549	INTEGER :: ji,jj ! dummy loop arguments
	550	INTEGER :: ijpj ! ???
	551	REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value
[134]	552	!!--------------------------------------------------------------------
[508]	553	!
[2715]	554	p_fval => p_fval1d
	555
[389]	556	ijpj = jpj
[2528]	557	p_fval(:) = 0._wp
[13540]	558	DO_2D( 0, 0, 0, 0 )
[12377]	559	p_fval(jj) = p_fval(jj) + pvflx(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj)
	560	END_2D
[1346]	561	#if defined key_mpp_mpi
[10425]	562	CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl )
[1346]	563	#endif
[508]	564	!
[5147]	565	END FUNCTION ptr_sj_2d
[134]	566
[12276]	567	FUNCTION ptr_ci_2d( pva ) RESULT ( p_fval )
	568	!!----------------------------------------------------------------------
	569	!! * ROUTINE ptr_ci_2d *
	570	!!
	571	!! ** Purpose : "meridional" cumulated sum computation of a j-flux array
	572	!!
	573	!! ** Method : - j cumulated sum of pva using the interior 2D vmask (umask_i).
	574	!!
	575	!! ** Action : - p_fval: j-cumulated sum of pva
	576	!!----------------------------------------------------------------------
	577	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point
	578	!
	579	INTEGER :: ji,jj,jc ! dummy loop arguments
	580	INTEGER :: ijpj ! ???
	581	REAL(wp), DIMENSION(jpi,jpj) :: p_fval ! function value
	582	!!--------------------------------------------------------------------
	583	!
	584	ijpj = jpj ! ???
	585	p_fval(:,:) = 0._wp
	586	DO jc = 1, jpnj ! looping over all processors in j axis
[13540]	587	DO_2D( 0, 0, 0, 0 )
[12377]	588	p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj)
	589	END_2D
[13540]	590	CALL lbc_lnk( 'diaptr', p_fval, 'U', -1.0_wp )
[12276]	591	END DO
	592	!
	593	END FUNCTION ptr_ci_2d
[134]	594
[12276]	595
	596
[5147]	597	FUNCTION ptr_sjk( pta, pmsk ) RESULT ( p_fval )
[134]	598	!!----------------------------------------------------------------------
[5147]	599	!! * ROUTINE ptr_sjk *
[134]	600	!!
[5147]	601	!! ** Purpose : i-sum computation of an array
[134]	602	!!
[12377]	603	!! ** Method : - i-sum of field using the interior 2D vmask (pmsk).
[134]	604	!!
[12377]	605	!! ** Action : - p_fval: i-sum of masked field
[508]	606	!!----------------------------------------------------------------------
[2715]	607	!!
	608	IMPLICIT none
[12276]	609	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,jpk) :: pta ! mask flux array at V-point
	610	REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask
[134]	611	!!
[2715]	612	INTEGER :: ji, jj, jk ! dummy loop arguments
	613	REAL(wp), POINTER, DIMENSION(:,:) :: p_fval ! return function value
[1559]	614	#if defined key_mpp_mpi
	615	INTEGER, DIMENSION(1) :: ish
	616	INTEGER, DIMENSION(2) :: ish2
[2715]	617	INTEGER :: ijpjjpk
[5147]	618	REAL(wp), DIMENSION(jpj*jpk) :: zwork ! mask flux array at V-point
[1559]	619	#endif
[134]	620	!!--------------------------------------------------------------------
[1559]	621	!
[2715]	622	p_fval => p_fval2d
	623
[2528]	624	p_fval(:,:) = 0._wp
[508]	625	!
[13540]	626	DO_3D( 0, 0, 0, 0, 1, jpkm1 )
[12377]	627	p_fval(jj,jk) = p_fval(jj,jk) + pta(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj)
	628	END_3D
[508]	629	!
[1346]	630	#if defined key_mpp_mpi
[4292]	631	ijpjjpk = jpj*jpk
[2715]	632	ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk
	633	zwork(1:ijpjjpk) = RESHAPE( p_fval, ish )
[10425]	634	CALL mpp_sum( 'diaptr', zwork, ijpjjpk, ncomm_znl )
[1559]	635	p_fval(:,:) = RESHAPE( zwork, ish2 )
[1346]	636	#endif
[508]	637	!
[5147]	638	END FUNCTION ptr_sjk
[134]	639
[1559]	640
[134]	641	!!======================================================================
	642	END MODULE diaptr

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

Download in other formats: