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/2019/dev_r12072_MERGE_OPTION2_2019/src/OCE/DIA – NEMO

Context Navigation

source: NEMO/branches/2019/dev_r12072_MERGE_OPTION2_2019/src/OCE/DIA/diaptr.F90 @ 12203

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

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

Download in other formats: