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/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/DIA – NEMO

Context Navigation

source: NEMO/branches/UKMO/NEMO_4.0.2_ENHANCE-02_ISF_nemo/src/OCE/DIA/diaptr.F90 @ 12708

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

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

Download in other formats: