Context Navigation

← Previous Revision
Next Revision →
Normal
Revision Log

traadv.F90

Last change on this file was 15127, checked in by cetlod, 3 years ago
dev_PISCO : merge with trunk@15119
Property svn:keywords set to `Id`
File size: 18.1 KB

Rev	Line
[458]	1	MODULE traadv
	2	!!==============================================================================
	3	!! * MODULE traadv *
[14072]	4	!! Ocean active tracers: advection trend
[458]	5	!!==============================================================================
[2528]	6	!! History : 2.0 ! 2005-11 (G. Madec) Original code
	7	!! 3.3 ! 2010-09 (C. Ethe, G. Madec) merge TRC-TRA + switch from velocity to transport
[5836]	8	!! 3.6 ! 2011-06 (G. Madec) Addition of Mixed Layer Eddy parameterisation
[14072]	9	!! 3.7 ! 2014-05 (G. Madec) Add 2nd/4th order cases for CEN and FCT schemes
[5836]	10	!! - ! 2014-12 (G. Madec) suppression of cross land advection option
[7646]	11	!! 3.6 ! 2015-06 (E. Clementi) Addition of Stokes drift in case of wave coupling
[458]	12	!!----------------------------------------------------------------------
[503]	13
	14	!!----------------------------------------------------------------------
[5836]	15	!! tra_adv : compute ocean tracer advection trend
[9019]	16	!! tra_adv_init : control the different options of advection scheme
[458]	17	!!----------------------------------------------------------------------
[5836]	18	USE oce ! ocean dynamics and active tracers
	19	USE dom_oce ! ocean space and time domain
[15127]	20	! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
[14090]	21	USE domtile
[5836]	22	USE domvvl ! variable vertical scale factors
[9019]	23	USE sbcwave ! wave module
	24	USE sbc_oce ! surface boundary condition: ocean
[9531]	25	USE traadv_cen ! centered scheme (tra_adv_cen routine)
	26	USE traadv_fct ! FCT scheme (tra_adv_fct routine)
	27	USE traadv_mus ! MUSCL scheme (tra_adv_mus routine)
	28	USE traadv_ubs ! UBS scheme (tra_adv_ubs routine)
	29	USE traadv_qck ! QUICKEST scheme (tra_adv_qck routine)
	30	USE tramle ! Mixed Layer Eddy transport (tra_mle_trp routine)
	31	USE ldftra ! Eddy Induced transport (ldf_eiv_trp routine)
[5836]	32	USE ldfslp ! Lateral diffusion: slopes of neutral surfaces
[9019]	33	USE trd_oce ! trends: ocean variables
[14072]	34	USE trdtra ! trends manager: tracers
	35	USE diaptr ! Poleward heat transport
[5147]	36	!
[5836]	37	USE in_out_manager ! I/O manager
	38	USE iom ! I/O module
	39	USE prtctl ! Print control
	40	USE lib_mpp ! MPP library
	41	USE timing ! Timing
	42
[458]	43	IMPLICIT NONE
	44	PRIVATE
	45
[9019]	46	PUBLIC tra_adv ! called by step.F90
	47	PUBLIC tra_adv_init ! called by nemogcm.F90
[2715]	48
[5836]	49	! !!* Namelist namtra_adv *
[9526]	50	LOGICAL :: ln_traadv_OFF ! no advection on T and S
[5836]	51	LOGICAL :: ln_traadv_cen ! centered scheme flag
	52	INTEGER :: nn_cen_h, nn_cen_v ! =2/4 : horizontal and vertical choices of the order of CEN scheme
	53	LOGICAL :: ln_traadv_fct ! FCT scheme flag
	54	INTEGER :: nn_fct_h, nn_fct_v ! =2/4 : horizontal and vertical choices of the order of FCT scheme
	55	LOGICAL :: ln_traadv_mus ! MUSCL scheme flag
	56	LOGICAL :: ln_mus_ups ! use upstream scheme in vivcinity of river mouths
	57	LOGICAL :: ln_traadv_ubs ! UBS scheme flag
	58	INTEGER :: nn_ubs_v ! =2/4 : vertical choice of the order of UBS scheme
	59	LOGICAL :: ln_traadv_qck ! QUICKEST scheme flag
[458]	60
[15127]	61	INTEGER, PUBLIC :: nadv ! choice of the type of advection scheme
[9019]	62	! ! associated indices:
[15127]	63	INTEGER, PARAMETER, PUBLIC :: np_NO_adv = 0 ! no T-S advection
	64	INTEGER, PARAMETER, PUBLIC :: np_CEN = 1 ! 2nd/4th order centered scheme
	65	INTEGER, PARAMETER, PUBLIC :: np_FCT = 2 ! 2nd/4th order Flux Corrected Transport scheme
	66	INTEGER, PARAMETER, PUBLIC :: np_MUS = 3 ! MUSCL scheme
	67	INTEGER, PARAMETER, PUBLIC :: np_UBS = 4 ! 3rd order Upstream Biased Scheme
	68	INTEGER, PARAMETER, PUBLIC :: np_QCK = 5 ! QUICK scheme
[13982]	69
	70	!! * Substitutions
	71	# include "do_loop_substitute.h90"
[13237]	72	# include "domzgr_substitute.h90"
[458]	73	!!----------------------------------------------------------------------
[9598]	74	!! NEMO/OCE 4.0 , NEMO Consortium (2018)
[2528]	75	!! $Id$
[10068]	76	!! Software governed by the CeCILL license (see ./LICENSE)
[458]	77	!!----------------------------------------------------------------------
	78	CONTAINS
	79
[12377]	80	SUBROUTINE tra_adv( kt, Kbb, Kmm, pts, Krhs )
[458]	81	!!----------------------------------------------------------------------
	82	!! * ROUTINE tra_adv *
	83	!!
	84	!! ** Purpose : compute the ocean tracer advection trend.
	85	!!
[12377]	86	!! ** Method : - Update (uu(:,:,:,Krhs),vv(:,:,:,Krhs)) with the advection term following nadv
[458]	87	!!----------------------------------------------------------------------
[12377]	88	INTEGER , INTENT(in) :: kt ! ocean time-step index
	89	INTEGER , INTENT(in) :: Kbb, Kmm, Krhs ! time level indices
	90	REAL(wp), DIMENSION(jpi,jpj,jpk,jpts,jpt), INTENT(inout) :: pts ! active tracers and RHS of tracer equation
[2528]	91	!
[13982]	92	INTEGER :: ji, jj, jk ! dummy loop index
[15127]	93	! TEMP: [tiling] This change not necessary and can be A2D(nn_hls) after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
[13982]	94	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zuu, zvv, zww ! 3D workspace
	95	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds
[15127]	96	! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
[13982]	97	LOGICAL :: lskip
[458]	98	!!----------------------------------------------------------------------
[2715]	99	!
[9019]	100	IF( ln_timing ) CALL timing_start('tra_adv')
[3294]	101	!
[13982]	102	lskip = .FALSE.
	103
[15127]	104	! TEMP: [tiling] These changes not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
	105	IF( .NOT. l_istiled .OR. ntile == 1 ) THEN ! Do only on the first tile
[13982]	106	ALLOCATE( zuu(jpi,jpj,jpk), zvv(jpi,jpj,jpk), zww(jpi,jpj,jpk) )
[7646]	107	ENDIF
[13982]	108
[15127]	109	! TEMP: [tiling] These changes not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
	110	IF( ln_tile .AND. nadv == np_FCT ) THEN
	111	IF( ntile == 1 ) THEN
	112	CALL dom_tile_stop( ldhold=.TRUE. )
	113	ELSE
	114	lskip = .TRUE.
[13982]	115	ENDIF
[4292]	116	ENDIF
[13982]	117	IF( .NOT. lskip ) THEN
	118	! !== effective transport ==!
	119	IF( ln_wave .AND. ln_sdw ) THEN
[15127]	120	DO_3D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )
[13982]	121	zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * ( uu(ji,jj,jk,Kmm) + usd(ji,jj,jk) )
	122	zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * ( vv(ji,jj,jk,Kmm) + vsd(ji,jj,jk) )
[15127]	123	END_3D
	124	DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
[13982]	125	zww(ji,jj,jk) = e1e2t(ji,jj) * ( ww(ji,jj,jk) + wsd(ji,jj,jk) )
	126	END_3D
	127	ELSE
[15127]	128	DO_3D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )
[13982]	129	zuu(ji,jj,jk) = e2u (ji,jj) * e3u(ji,jj,jk,Kmm) * uu(ji,jj,jk,Kmm) ! eulerian transport only
	130	zvv(ji,jj,jk) = e1v (ji,jj) * e3v(ji,jj,jk,Kmm) * vv(ji,jj,jk,Kmm)
[15127]	131	END_3D
	132	DO_3D_OVR( nn_hls-1, nn_hls-1, nn_hls-1, nn_hls-1, 1, jpkm1 )
[13982]	133	zww(ji,jj,jk) = e1e2t(ji,jj) * ww(ji,jj,jk)
	134	END_3D
	135	ENDIF
	136	!
	137	IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections
[15127]	138	DO_3D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1, 1, jpkm1 )
[13982]	139	zuu(ji,jj,jk) = zuu(ji,jj,jk) + un_td(ji,jj,jk)
	140	zvv(ji,jj,jk) = zvv(ji,jj,jk) + vn_td(ji,jj,jk)
	141	END_3D
	142	ENDIF
	143	!
[15127]	144	DO_2D_OVR( nn_hls, nn_hls-1, nn_hls, nn_hls-1 )
[13982]	145	zuu(ji,jj,jpk) = 0._wp ! no transport trough the bottom
	146	zvv(ji,jj,jpk) = 0._wp
	147	zww(ji,jj,jpk) = 0._wp
	148	END_2D
	149	!
	150	IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad ) &
[15127]	151	& CALL ldf_eiv_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm, Krhs ) ! add the eiv transport (if necessary)
[13982]	152	!
[15127]	153	IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zuu, zvv, zww, 'TRA', Kmm ) ! add the mle transport (if necessary)
[13982]	154	!
[15127]	155	! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
	156	IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only on the last tile
[13982]	157	CALL iom_put( "uocetr_eff", zuu ) ! output effective transport
	158	CALL iom_put( "vocetr_eff", zvv )
	159	CALL iom_put( "wocetr_eff", zww )
	160	ENDIF
	161	!
[15127]	162	!!gm ???
	163	! TEMP: [tiling] This copy-in not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
[13982]	164	CALL dia_ptr( kt, Kmm, zvv(A2D(nn_hls),:) ) ! diagnose the effective MSF
[15127]	165	!!gm ???
[13982]	166	!
[12377]	167
[13982]	168	IF( l_trdtra ) THEN !* Save ta and sa trends
	169	ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) )
	170	ztrdt(:,:,:) = pts(:,:,:,jp_tem,Krhs)
	171	ztrds(:,:,:) = pts(:,:,:,jp_sal,Krhs)
	172	ENDIF
	173	!
	174	SELECT CASE ( nadv ) !== compute advection trend and add it to general trend ==!
	175	!
	176	CASE ( np_CEN ) ! Centered scheme : 2nd / 4th order
[15127]	177	CALL tra_adv_cen ( kt, nit000, 'TRA', zuu, zvv, zww, Kmm, pts, jpts, Krhs, nn_cen_h, nn_cen_v )
[13982]	178	CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order
[15127]	179	CALL tra_adv_fct ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_fct_h, nn_fct_v )
[13982]	180	CASE ( np_MUS ) ! MUSCL
[15127]	181	CALL tra_adv_mus( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, ln_mus_ups )
[13982]	182	CASE ( np_UBS ) ! UBS
[15127]	183	CALL tra_adv_ubs ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs, nn_ubs_v )
[13982]	184	CASE ( np_QCK ) ! QUICKEST
[15127]	185	CALL tra_adv_qck ( kt, nit000, 'TRA', rDt, zuu, zvv, zww, Kbb, Kmm, pts, jpts, Krhs )
[13982]	186	!
	187	END SELECT
	188	!
	189	IF( l_trdtra ) THEN ! save the advective trends for further diagnostics
	190	DO jk = 1, jpkm1
	191	ztrdt(:,:,jk) = pts(:,:,jk,jp_tem,Krhs) - ztrdt(:,:,jk)
	192	ztrds(:,:,jk) = pts(:,:,jk,jp_sal,Krhs) - ztrds(:,:,jk)
	193	END DO
	194	CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_tem, jptra_totad, ztrdt )
	195	CALL trd_tra( kt, Kmm, Krhs, 'TRA', jp_sal, jptra_totad, ztrds )
	196	DEALLOCATE( ztrdt, ztrds )
	197	ENDIF
	198
[15127]	199	! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
	200	IF( ln_tile .AND. .NOT. l_istiled ) CALL dom_tile_start( ldhold=.TRUE. )
[7646]	201	ENDIF
	202	! ! print mean trends (used for debugging)
[13982]	203	IF(sn_cfctl%l_prtctl) CALL prt_ctl( tab3d_1=pts(:,:,:,jp_tem,Krhs), clinfo1=' adv - Ta: ', mask1=tmask, &
[12377]	204	& tab3d_2=pts(:,:,:,jp_sal,Krhs), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' )
[13982]	205
[15127]	206	! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
	207	IF( .NOT. l_istiled .OR. ntile == nijtile ) THEN ! Do only for the full domain
[13982]	208	DEALLOCATE( zuu, zvv, zww )
	209	ENDIF
[503]	210	!
[9019]	211	IF( ln_timing ) CALL timing_stop( 'tra_adv' )
[2715]	212	!
[458]	213	END SUBROUTINE tra_adv
	214
	215
[2528]	216	SUBROUTINE tra_adv_init
[458]	217	!!---------------------------------------------------------------------
[2528]	218	!! * ROUTINE tra_adv_init *
[14072]	219	!!
	220	!! ** Purpose : Control the consistency between namelist options for
[503]	221	!! tracer advection schemes and set nadv
[458]	222	!!----------------------------------------------------------------------
[5836]	223	INTEGER :: ioptio, ios ! Local integers
	224	!
[9526]	225	NAMELIST/namtra_adv/ ln_traadv_OFF, & ! No advection
[9019]	226	& ln_traadv_cen , nn_cen_h, nn_cen_v, & ! CEN
	227	& ln_traadv_fct , nn_fct_h, nn_fct_v, & ! FCT
	228	& ln_traadv_mus , ln_mus_ups, & ! MUSCL
	229	& ln_traadv_ubs , nn_ubs_v, & ! UBS
	230	& ln_traadv_qck ! QCK
[458]	231	!!----------------------------------------------------------------------
[5836]	232	!
	233	! !== Namelist ==!
[4147]	234	READ ( numnam_ref, namtra_adv, IOSTAT = ios, ERR = 901)
[11536]	235	901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_adv in reference namelist' )
[5836]	236	!
[4147]	237	READ ( numnam_cfg, namtra_adv, IOSTAT = ios, ERR = 902 )
[11536]	238	902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namtra_adv in configuration namelist' )
[6140]	239	IF(lwm) WRITE( numond, namtra_adv )
	240	!
[5836]	241	IF(lwp) THEN ! Namelist print
[458]	242	WRITE(numout,*)
[2528]	243	WRITE(numout,*) 'tra_adv_init : choice/control of the tracer advection scheme'
[9019]	244	WRITE(numout,*) '~~~~~~~~~~~~'
[1601]	245	WRITE(numout,*) ' Namelist namtra_adv : chose a advection scheme for tracers'
[9526]	246	WRITE(numout,*) ' No advection on T & S ln_traadv_OFF = ', ln_traadv_OFF
[5836]	247	WRITE(numout,*) ' centered scheme ln_traadv_cen = ', ln_traadv_cen
	248	WRITE(numout,*) ' horizontal 2nd/4th order nn_cen_h = ', nn_fct_h
	249	WRITE(numout,*) ' vertical 2nd/4th order nn_cen_v = ', nn_fct_v
	250	WRITE(numout,*) ' Flux Corrected Transport scheme ln_traadv_fct = ', ln_traadv_fct
	251	WRITE(numout,*) ' horizontal 2nd/4th order nn_fct_h = ', nn_fct_h
	252	WRITE(numout,*) ' vertical 2nd/4th order nn_fct_v = ', nn_fct_v
	253	WRITE(numout,*) ' MUSCL scheme ln_traadv_mus = ', ln_traadv_mus
	254	WRITE(numout,*) ' + upstream scheme near river mouths ln_mus_ups = ', ln_mus_ups
	255	WRITE(numout,*) ' UBS scheme ln_traadv_ubs = ', ln_traadv_ubs
	256	WRITE(numout,*) ' vertical 2nd/4th order nn_ubs_v = ', nn_ubs_v
	257	WRITE(numout,*) ' QUICKEST scheme ln_traadv_qck = ', ln_traadv_qck
[2528]	258	ENDIF
[6140]	259	!
[9019]	260	! !== Parameter control & set nadv ==!
[14072]	261	ioptio = 0
[9526]	262	IF( ln_traadv_OFF ) THEN ; ioptio = ioptio + 1 ; nadv = np_NO_adv ; ENDIF
	263	IF( ln_traadv_cen ) THEN ; ioptio = ioptio + 1 ; nadv = np_CEN ; ENDIF
	264	IF( ln_traadv_fct ) THEN ; ioptio = ioptio + 1 ; nadv = np_FCT ; ENDIF
	265	IF( ln_traadv_mus ) THEN ; ioptio = ioptio + 1 ; nadv = np_MUS ; ENDIF
	266	IF( ln_traadv_ubs ) THEN ; ioptio = ioptio + 1 ; nadv = np_UBS ; ENDIF
	267	IF( ln_traadv_qck ) THEN ; ioptio = ioptio + 1 ; nadv = np_QCK ; ENDIF
[5836]	268	!
[9019]	269	IF( ioptio /= 1 ) CALL ctl_stop( 'tra_adv_init: Choose ONE advection option in namelist namtra_adv' )
[5836]	270	!
	271	IF( ln_traadv_cen .AND. ( nn_cen_h /= 2 .AND. nn_cen_h /= 4 ) & ! Centered
	272	.AND. ( nn_cen_v /= 2 .AND. nn_cen_v /= 4 ) ) THEN
	273	CALL ctl_stop( 'tra_adv_init: CEN scheme, choose 2nd or 4th order' )
	274	ENDIF
	275	IF( ln_traadv_fct .AND. ( nn_fct_h /= 2 .AND. nn_fct_h /= 4 ) & ! FCT
	276	.AND. ( nn_fct_v /= 2 .AND. nn_fct_v /= 4 ) ) THEN
	277	CALL ctl_stop( 'tra_adv_init: FCT scheme, choose 2nd or 4th order' )
	278	ENDIF
[15127]	279	! TEMP: [tiling] This change not necessary after all lbc_lnks removed in the nn_hls = 2 case in tra_adv_fct
	280	IF( ln_traadv_fct .AND. ln_tile ) THEN
	281	CALL ctl_warn( 'tra_adv_init: FCT scheme does not yet work with tiling' )
	282	ENDIF
[5836]	283	IF( ln_traadv_ubs .AND. ( nn_ubs_v /= 2 .AND. nn_ubs_v /= 4 ) ) THEN ! UBS
	284	CALL ctl_stop( 'tra_adv_init: UBS scheme, choose 2nd or 4th order' )
	285	ENDIF
	286	IF( ln_traadv_ubs .AND. nn_ubs_v == 4 ) THEN
	287	CALL ctl_warn( 'tra_adv_init: UBS scheme, only 2nd FCT scheme available on the vertical. It will be used' )
	288	ENDIF
	289	IF( ln_isfcav ) THEN ! ice-shelf cavities
[6140]	290	IF( ln_traadv_cen .AND. nn_cen_v == 4 .OR. & ! NO 4th order with ISF
	291	& ln_traadv_fct .AND. nn_fct_v == 4 ) CALL ctl_stop( 'tra_adv_init: 4th order COMPACT scheme not allowed with ISF' )
[5836]	292	ENDIF
	293	!
[14072]	294	! !== Print the choice ==!
[9019]	295	IF(lwp) THEN
[503]	296	WRITE(numout,*)
[6140]	297	SELECT CASE ( nadv )
[9190]	298	CASE( np_NO_adv ) ; WRITE(numout,*) ' ==>>> NO T-S advection'
	299	CASE( np_CEN ) ; WRITE(numout,*) ' ==>>> CEN scheme is used. Horizontal order: ', nn_cen_h, &
	300	& ' Vertical order: ', nn_cen_v
	301	CASE( np_FCT ) ; WRITE(numout,*) ' ==>>> FCT scheme is used. Horizontal order: ', nn_fct_h, &
	302	& ' Vertical order: ', nn_fct_v
	303	CASE( np_MUS ) ; WRITE(numout,*) ' ==>>> MUSCL scheme is used'
	304	CASE( np_UBS ) ; WRITE(numout,*) ' ==>>> UBS scheme is used'
	305	CASE( np_QCK ) ; WRITE(numout,*) ' ==>>> QUICKEST scheme is used'
[6140]	306	END SELECT
[458]	307	ENDIF
[503]	308	!
[9531]	309	CALL tra_mle_init !== initialisation of the Mixed Layer Eddy parametrisation (MLE) ==!
[4245]	310	!
[2528]	311	END SUBROUTINE tra_adv_init
[458]	312
	313	!!======================================================================
	314	END MODULE traadv

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/2021/dev_r14383_PISCES_NEWDEV_PISCO/src/OCE/TRA/traadv.F90

Download in other formats: