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

Context Navigation

source: NEMO/trunk/src/OCE/DIA/diaptr.F90 @ 12649

Last change on this file since 12649 was 12489, checked in by davestorkey, 4 years ago

Preparation for new timestepping scheme #2390.
Main changes:

Initial euler timestep now handled in stp and not in TRA/DYN routines.
Renaming of all timestep parameters. In summary, the namelist parameter is now rn_Dt and the current timestep is rDt (and rDt_ice, rDt_trc etc).
Renaming of a few miscellaneous parameters, eg. atfp -> rn_atfp (namelist parameter used everywhere) and rau0 -> rho0.

This version gives bit-comparable results to the previous version of the trunk.

Property svn:keywords set to Id

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

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

Download in other formats: