Context Navigation

diaptr.F90 @ 12344

Last change on this file since 12344 was 12340, checked in by acc, 4 years ago

Branch 2019/dev_r11943_MERGE_2019. This commit introduces basic do loop macro
substitution to the 2019 option 1, merge branch. These changes have been SETTE
tested. The only addition is the do_loop_substitute.h90 file in the OCE directory but
the macros defined therein are used throughout the code to replace identifiable, 2D-
and 3D- nested loop opening and closing statements with single-line alternatives. Code
indents are also adjusted accordingly.

The following explanation is taken from comments in the new header file:

This header file contains preprocessor definitions and macros used in the do-loop
substitutions introduced between version 4.0 and 4.2. The primary aim of these macros
is to assist in future applications of tiling to improve performance. This is expected
to be achieved by alternative versions of these macros in selected locations. The
initial introduction of these macros simply replaces all identifiable nested 2D- and
3D-loops with single line statements (and adjusts indenting accordingly). Do loops
are identifiable if they comform to either:

DO jk = ....

DO jj = .... DO jj = ...

DO ji = .... DO ji = ...
. OR .
. .

END DO END DO

END DO END DO

END DO

and white-space variants thereof.

Additionally, only loops with recognised jj and ji loops limits are treated; these are:
Lower limits of 1, 2 or fs_2
Upper limits of jpi, jpim1 or fs_jpim1 (for ji) or jpj, jpjm1 or fs_jpjm1 (for jj)

The macro naming convention takes the form: DO_2D_BT_LR where:

B is the Bottom offset from the PE's inner domain;
T is the Top offset from the PE's inner domain;
L is the Left offset from the PE's inner domain;
R is the Right offset from the PE's inner domain

So, given an inner domain of 2,jpim1 and 2,jpjm1, a typical example would replace:

DO jj = 2, jpj

DO ji = 1, jpim1
.
.

END DO

END DO

with:

DO_2D_01_10
.
.
END_2D

similar conventions apply to the 3D loops macros. jk loop limits are retained
through macro arguments and are not restricted. This includes the possibility of
strides for which an extra set of DO_3DS macros are defined.

In the example definition below the inner PE domain is defined by start indices of
(kIs, kJs) and end indices of (kIe, KJe)

#define DO_2D_00_00 DO jj = kJs, kJe ; DO ji = kIs, kIe
#define END_2D END DO ; END DO

TO DO:

Only conventional nested loops have been identified and replaced by this step. There are constructs such as:

DO jk = 2, jpkm1

z2d(:,:) = z2d(:,:) + e3w(:,:,jk,Kmm) * z3d(:,:,jk) * wmask(:,:,jk)

END DO

which may need to be considered.

Property svn:keywords set to Id

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

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

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

Context Navigation

source: NEMO/branches/2019/dev_r11943_MERGE_2019/src/OCE/DIA/diaptr.F90 @ 12344

Download in other formats: