diff --git a/ROMS/Adjoint/ad_main2d.F b/ROMS/Adjoint/ad_main2d.F index f2cf85adc..74d442d9e 100644 --- a/ROMS/Adjoint/ad_main2d.F +++ b/ROMS/Adjoint/ad_main2d.F @@ -9,10 +9,18 @@ SUBROUTINE ad_main2d (RunInterval) ! See License_ROMS.md ! !======================================================================= ! ! -! This subroutine is the main driver for adjoint ROMS when ! -! configurated as shallow water (barotropic) ocean model only. It ! -! advances backward the adjoint model for all nested grids, if ! -! any, by the specified time interval (seconds), RunInterval. ! +! This routine is the main driver for ROMS adjoint model (ADM) ! +! when configured as a 2D barotropic shallow water ocean model. It ! +! advances backward the ADM for all nested grids, if any, by the ! +! specified time interval (seconds), RunInterval. ! +! ! +# if defined STEP2D_FB_LF_AM3 +! Numerical 2D time-stepping kernel: FB AB3-AM4 ! +# elif defined STEP2D_FB_LF_AM3 +! Numerical 2D time-stepping kernel: FB LF-AM3 ! +# else +! Numerical 2D time-stepping kernel: LF-AM3 (Legacy scheme) ! +# endif ! ! !======================================================================= ! @@ -25,6 +33,12 @@ SUBROUTINE ad_main2d (RunInterval) USE mod_fourdvar # endif USE mod_iounits +# ifdef SENSITIVITY_4DVAR + USE mod_ncparam +# endif +# ifdef NESTING + USE mod_nesting +# endif USE mod_scalars USE mod_stepping # ifdef SO_SEMI @@ -36,7 +50,10 @@ SUBROUTINE ad_main2d (RunInterval) USE adsen_force_mod, ONLY : adsen_force # endif USE ad_diag_mod, ONLY : ad_diag -# if defined WEAK_CONSTRAINT || defined FORCING_SV +# ifdef WEAK_CONSTRAINT + USE ad_force_dual_mod, ONLY : ad_force_dual +# endif +# ifdef FORCING_SV USE ad_forcing_mod, ONLY : ad_forcing # endif # ifdef ADJUST_WSTRESS @@ -53,6 +70,13 @@ SUBROUTINE ad_main2d (RunInterval) USE ad_misfit_mod, ONLY : ad_misfit # endif # endif +# ifdef NESTING + USE nesting_mod, ONLY : nesting + USE ad_nesting_mod, ONLY : ad_nesting +# ifndef ONE_WAY + USE nesting_mod, ONLY : do_twoway +# endif +# endif # ifdef ADJUST_BOUNDARY USE ad_obc_adjust_mod, ONLY : ad_obc_adjust # endif @@ -65,7 +89,7 @@ SUBROUTINE ad_main2d (RunInterval) USE ad_set_vbc_mod, ONLY : ad_set_vbc USE ad_step2d_mod, ONLY : ad_step2d # ifdef FLOATS_NOT_YET -!! USE ad_step_floats_mod, ONLY : tl_step_floats +!! USE ad_step_floats_mod, ONLY : ad_step_floats # endif USE dateclock_mod, ONLY : time_string # ifdef TIDE_GENERATING_FORCES @@ -74,7 +98,7 @@ SUBROUTINE ad_main2d (RunInterval) # ifdef WEAK_CONSTRAINT USE frc_weak_mod, ONLY : frc_ADgather, frc_clear # endif -# ifdef AIR_OCEAN_NOT_YET && defined MCT_LIB +# if defined ATM_COUPLING_NOT_YET && defined MCT_LIB USE mct_coupler_mod, ONLY : ocn2atm_coupling # endif # if defined WAV_COUPLING_NOT_YET && defined MCT_LIB @@ -97,14 +121,19 @@ SUBROUTINE ad_main2d (RunInterval) ! ! Local variable declarations. ! - logical:: backward = .TRUE. -! - integer :: ng, tile - integer :: next_indx1 + logical :: backward = .TRUE. + logical :: ad_advance + logical :: DoNestLayer, Time_Step + integer :: Nsteps, Rsteps + integer :: ig, il, is, istep, ng, nl, tile + integer :: my_iif, next_indx1 # ifdef FLOATS_NOT_YET integer :: Lend, Lstr, chunk_size # endif - integer :: ksav, ktmp + integer :: ks, kt +# ifdef NESTING + integer :: icount, itcount +# endif ! real(r8) :: HalfDT, MaxDT, my_StepTime ! @@ -112,100 +141,465 @@ SUBROUTINE ad_main2d (RunInterval) & __FILE__ ! !======================================================================= -! Time-step adjoint vertically integrated equations. +! Time-step adjoint 2D primitive equations backwards. !======================================================================= -! - my_StepTime=0.0_r8 - MaxDT=MAXVAL(dt) - STEP_LOOP : DO WHILE (my_StepTime.le.(RunInterval+0.5_r8*MaxDT)) - - my_StepTime=my_StepTime+MaxDT +# ifdef NESTING +! +! Compute nonlinear model timestepping sequence and load it into +! StepInfo array. The sequence of values are reversed to timestep +! the adjoint model backwards. +! + CALL nlm_step_sequence (RunInterval, icount) + IF (FoundError(exit_flag, NoError, __LINE__, & + & __FILE__)) RETURN +# endif +! +! Initialize. +! + Time_Step=.TRUE. + DoNestLayer=.TRUE. +# ifdef NESTING + itcount=icount+1 +# endif +! + KERNEL_LOOP : DO WHILE (Time_Step) ! -! Set time clock. +! In nesting applications, the number of nesting layers (NestLayers) is +! used to facilitate refinement grids and composite/refinament grids +! combinations. Otherwise, the solution it is looped once for a single +! grid application (NestLayers = 1). ! + nl=0 +# ifdef NESTING DO ng=1,Ngrids - iic(ng)=iic(ng)-1 - time(ng)=time(ng)-dt(ng) - tdays(ng)=time(ng)*sec2day - CALL time_string (time(ng), time_code(ng)) + TwoWayInterval(ng)=dt(1) END DO +# endif +! + NEST_LAYER : DO WHILE (DoNestLayer) + +# ifdef NESTING +! +! Determine current nested layer (nl), number of timesteps (Nsteps) +! to execute for grids in current nested layer, number of timesteps +! (Rsteps) to complete the RunInterval time window, and timestep +! counter (step_counter) for each grid. Their values are reversed +! from the saved nonlinear model time stepping sequence. +! + itcount=itcount-1 ! count backwards for adjoint + IF (itcount.gt.0) THEN + nl=StepInfo(itcount,1) + Nsteps=StepInfo(itcount,2) + IF (itcount.eq.icount) Nsteps=1 + Rsteps=StepInfo(itcount,3) + DO ng=1,Ngrids + step_counter(ng)=StepInfo(itcount,ng+3) + END DO + ELSE + nl=0 + END IF +# else +! +! Determine number of time steps to compute in each nested grid layer +! based on the specified time interval (seconds), RunInterval. Non +! nesting applications have NestLayers=1. Notice that RunInterval is +! set in the calling driver. Its value may span the full period of the +! simulation, a multi-model coupling interval (RunInterval > ifac*dt), +! or just a single step (RunInterval=0). +! + CALL ntimesteps (iADM, RunInterval, nl, Nsteps, Rsteps) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +# endif +! + IF ((nl.le.0).or.(nl.gt.NestLayers)) EXIT +! +! Time-step governing equations for Nsteps. +! + STEP_LOOP : DO istep=Nsteps,1,-1 +! +! Set time indices and time clock. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) +# ifdef JEDI + jic(ng)=jic(ng)-1 + time4jedi(ng)=time4jedi(ng)-dt(ng) +# endif + tdays(ng)=time(ng)*sec2day + IF (step_counter(ng).eq.1) Time_Step=.FALSE. + IF ((iic(ng).eq.ntstart(ng)).and.(ng.eq.Ngrids)) THEN + ad_advance=.FALSE. +# ifdef NESTING + DO ng=1,Ngrids + TwoWayInterval(ng)=0.0_r8 + END DO +# endif + ELSE + ad_advance=.TRUE. + END IF + END DO ! !----------------------------------------------------------------------- ! Read in required data, if any, from input NetCDF files. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - CALL ad_get_data (ng) - IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN - END DO + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + CALL ad_get_data (ng) + IF (FoundError(exit_flag, NoError, & + & __LINE__, MyFile)) RETURN + END DO ! !----------------------------------------------------------------------- ! Process input data, if any: time interpolate between snapshots. -! If appropriate, compute and report diagnostics. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 ! irreversible - CALL ad_set_data (ng, tile) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ad_set_data (ng, tile) # ifdef AD_AVERAGES - CALL ad_set_avg (ng, tile) + CALL ad_set_avg (ng, tile) # endif # ifdef TIDE_GENERATING_FORCES - CALL equilibrium_tide (ng, tile, iADM) + CALL equilibrium_tide (ng, tile, iADM) # endif # ifdef DIAGNOSTICS -!! CALL ad_set_diags (ng, tile) +!! CALL ad_set_diags (ng, tile) +# endif + END DO + END DO + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! +! Avoid time-stepping if additional delayed IO time-step. +! + ADVANCE : IF (ad_advance) THEN + +# ifdef FLOATS_NOT_YET +! +!----------------------------------------------------------------------- +! Compute Lagrangian drifters trajectories: Split all the drifters +! between all the computational threads, except in distributed-memory +! and serial configurations. In distributed-memory, the parallel node +! containing the drifter is selected internally since the state +! variables do not have a global scope. +!----------------------------------------------------------------------- +! +! Shift floats time indices. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (Lfloats(Ng)) THEN + nfp1(ng)=MOD(nfp1(ng)+1,NFT+1) + nf (ng)=MOD(nf (ng)+1,NFT+1) + nfm1(ng)=MOD(nfm1(ng)+1,NFT+1) + nfm2(ng)=MOD(nfm2(ng)+1,NFT+1) + nfm3(ng)=MOD(nfm3(ng)+1,NFT+1) +! +# ifdef _OPENMP + chunk_size=(Nfloats(ng)+numthreads-1)/numthreads + Lstr=1+MyThread*chunk_size + Lend=MIN(Nfloats(ng),Lstr+chunk_size-1) +# else + Lstr=1 + Lend=Nfloats(ng) +# endif + CALL ad_step_floats (ng, Lstr, Lend) + END IF + END DO # endif - CALL ad_diag (ng, tile) - END DO - END DO - IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + +# ifdef NESTING +! +!----------------------------------------------------------------------- +! If donor to a finer grid, extract data for the external contact +! points. This is the latest solution for the coarser grid. +! +! It is stored in the REFINED structure so it can be used for the +! space-time interpolation when "nputD" argument is used above. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (DonorToFiner(ng)) THEN + CALL ad_nesting (ng, iADM, ngetD) + END IF + END DO + +# ifndef ONE_WAY +! +!----------------------------------------------------------------------- +! If refinement grids, perform two-way coupling between fine and +! coarse grids. Correct coarse grid tracers values at the refinement +! grid with refined accumulated fluxes. Then, replace coarse grid +! state variable with averaged refined grid values (two-way nesting). +! Update coarse grid depth variables. +! +! The two-way exchange of infomation between nested grids needs to be +! done at the correct time-step and in the right sequence. +!----------------------------------------------------------------------- +! + DO il=1,NestLayers + DO ig=1,GridsInLayer(il) + ng=GridNumber(ig,il) + IF (do_twoway(iADM,nl,il,ng,istep)) THEN + CALL ad_nesting (ng, iADM, n2way) + END IF + END DO + END DO +# endif +# endif + +# ifdef NESTING +! +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine CORRECTOR STEP section (KNEW INDEX). +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL ad_nesting (ng, iADM, n2dCS) + END IF + END DO + +# if defined MASKING && defined WET_DRY +! +! If nesting and wetting and drying, scale horizontal interpolation +! weights to account for land/sea masking in contact areas. This needs +! to be done at very time-step since the Land/Sea masking is time +! dependent. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + CALL ad_nesting (ng, iADM, nmask) + END DO +# endif +# endif + +# ifdef STEP2D_FB_AB3_AM4 +! +!----------------------------------------------------------------------- +! Solve adjoint vertically integrated primitive equations for the +! free-surface and barotropic momentum components using a generalized +! Forward-Backward, 3rd-order Adams-Bashforth / 4th-order Adams-Moulton +! (FB AB3-AM4) time stepping scheme (Shchepetkin and McWilliams, 2009). +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + iif(ng)=1 + nfast(ng)=1 + + IF (MOD(knew(ng),2).eq.0) THEN ! zig-zag + DO tile=first_tile(ng),last_tile(ng),+1 ! processing + CALL ad_step2d (ng, tile) ! sequence + END DO + ELSE + DO tile=last_tile(ng),first_tile(ng),-1 + CALL ad_step2d (ng, tile) + END DO + END IF + +!^ kstp(ng)=knew(ng) +!^ knew(ng)=kstp(ng)+1 +!^ IF (knew(ng).gt.4) knew(ng)=1 +!^ + knew(ng)=kstp(ng) + kstp(ng)=knew(ng)-1 + IF (kstp(ng).lt.1) kstp(ng)=4 + END DO + +# else + +# ifdef STEP2D_FB_LF_AM3 +! +!----------------------------------------------------------------------- +! Solve adjoint vertically integrated primitive equations for +! free-surface and momentum components using a predictor-corrector +! LeapFrog / 3rd-order Adams-Moulton with a Forward-Backward +! feeback (FB LF-AM3) stepping scheme (Shchepetkin and McWilliams, +! 2009). +!----------------------------------------------------------------------- +! +! Corrector AM3 substep with FB-feedback. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + iif(ng)=1 + + DO tile=first_tile(ng),last_tile(ng),+1 + CALL tl_step2d (ng, tile) + END DO + +!^ knew(ng)=3-kstp(ng) +!^ next_kstp(ng)=knew(ng) +!^ + knew(ng)=next_kstp(ng) + kstp(ng)=3-knew(ng) + END DO +! +! Predictor LF substep with FB-feedback. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + iif(ng)=1 + + DO tile=last_tile(ng),first_tile(ng),-1 + CALL ad_step2d (ng, tile) + END DO + +!^ kstp(ng)=next_kstp(ng) +!^ knew(ng)=3 +!^ +!^ HGA/AMM: Need to compute the adjoint of the indices + + END DO + +# else +! +!----------------------------------------------------------------------- +! Solve adjoint vertically integrated primitive equations for +! free-surface and momentum components using a predictor-corrector +! LeapFrog with 3rd-order Adams-Moulton (LF-AM3) time stepping scheme +! (ROMS legacy 2D kernel). +!----------------------------------------------------------------------- +! +! Corrector step - Apply 2D adjoint time-step corrector scheme. Notice +! ============== that there is not need for a corrector step during +! the auxiliary (nfast+1) time-step. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + iif(ng)=1 + nfast(ng)=1 + + IF (iif(ng).lt.(nfast(ng)+1)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ad_step2d (ng, tile) + END DO + END IF +! +! Set time indices for adjoint predictor step. +! + next_indx1=3-indx1(ng) + IF (.not.PREDICTOR_2D_STEP(ng)) THEN + PREDICTOR_2D_STEP(ng)=.TRUE. +!^ knew(ng)=next_indx1 +!^ kstp(ng)=3-knew(ng) +!^ krhs(ng)=3 +!^ + kt=knew(ng) + ks=kstp(ng) + knew(ng)=krhs(ng) + kstp(ng)=kt + krhs(ng)=ks +!^ IF (my_iif.lt.(nfast(ng)+1)) indx1(ng)=next_indx1 + END IF + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine PREDICTOR STEP section. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL ad_nesting (ng, iADM, n2dPS) + END IF + END DO +# endif +! +! Predictor step - Advance adjoint barotropic equations using 2D +! ============== time-step predictor scheme. No actual time- +! stepping is performed during the auxiliary (nfast+1) time-step. +! It is needed to finalize the fast-time averaging of 2D fields, +! if any, and compute the new time-evolving depths. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=last_tile(ng),first_tile(ng),-1 + CALL ad_step2d (ng, tile) + END DO +! +! Set time indices for next adjoint corrector step. The +! PREDICTOR_2D_STEP switch it is assumed to be false before the +! first time-step. +! + IF (PREDICTOR_2D_STEP(ng).and. & + & my_iif.le.(nfast(ng)+1)) THEN + PREDICTOR_2D_STEP(ng)=.FALSE. +!^ IF (FIRST_2D_STEP) THEN +!^ kstp(ng)=indx1(ng) +!^ ELSE +!^ kstp(ng)=3-indx1(ng) +!^ END IF +!^ knew(ng)=3 +!^ krhs(ng)=indx1(ng) +!^ + ks=knew(ng) + knew(ng)=krhs(ng) + krhs(ng)=ks + END IF + END DO +# endif + +# endif + END IF ADVANCE # if (defined FOUR_DVAR && !defined I4DVAR_ANA_SENSITIVITY) && \ defined OBSERVATIONS ! !----------------------------------------------------------------------- ! If appropriate, read observation and model state at observation -! locations. Then, compute adjoint misfit forcing terms. +! locations. Then, compute adjoint forcing terms due to observations. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) # ifdef SENSITIVITY_4DVAR - IF (.not.Lsen4DVAR(ng)) THEN +# ifdef RBL4DVAR_FCT_SENSITIVITY + IF (.not.Lsen4DVAR(ng).and.LsenFCT(ng)) THEN +# else + IF (.not.Lsen4DVAR(ng)) THEN +# endif # endif - HalfDT=0.5_r8*dt(ng) - IF (((time(ng)-HalfDT).le.ObsTime(ng)).and. & - & (ObsTime(ng).lt.(time(ng)+HalfDT))) THEN - ProcessObs(ng)=.TRUE. - CALL obs_read (ng, iADM, backward) - IF (FoundError(exit_flag, NoError, & - & __LINE__, MyFile)) RETURN - ELSE - ProcessObs(ng)=.FALSE. - END IF + HalfDT=0.5_r8*dt(ng) + IF (((time(ng)-HalfDT).le.ObsTime(ng)).and. & + & (ObsTime(ng).lt.(time(ng)+HalfDT))) THEN + ProcessObs(ng)=.TRUE. + CALL obs_read (ng, iADM, backward) + ELSE + ProcessObs(ng)=.FALSE. + END IF ! # ifdef SP4DVAR ! ! Skip assimilation of obs on first timestep unless inter=Nsaddle. ! - IF ((iic(ng).ne.ntstart(ng)).or.Lsadd(ng)) THEN + IF ((iic(ng).ne.ntstart(ng)).or.Lsadd(ng)) THEN # endif - DO tile=first_tile(ng),last_tile(ng),+1 + + DO tile=first_tile(ng),last_tile(ng),+1 # ifdef WEAK_CONSTRAINT - CALL ad_htobs (ng, tile, iADM) + CALL ad_htobs (ng, tile, iADM) # else - CALL ad_misfit (ng, tile, iADM) + CALL ad_misfit (ng, tile, iADM) # endif - END DO - IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + END DO + IF (FoundError(exit_flag, NoError, & + & __LINE__, MyFile)) RETURN # ifdef SENSITIVITY_4DVAR - END IF + END IF # endif # ifdef SP4DVAR - END IF + END IF # endif - END DO + END DO # endif # ifdef WEAK_CONSTRAINT @@ -215,100 +609,43 @@ SUBROUTINE ad_main2d (RunInterval) ! forcing to adjoint solution. Read next impulse record, if available. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (ProcessObs(ng)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL ad_forcing (ng, tile, knew(ng), nnew(ng)) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ProcessObs(ng)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ad_force_dual (ng, tile, kstp(ng), nstp(ng)) + END DO + END IF END DO - END IF - END DO # endif -! -! Avoid time-stepping if additional delayed IO time-step. -! - TIME_STEP: IF (MINVAL(iic).ne.MINVAL(ntstart)) THEN -# ifdef FLOATS_NOT_YET +# ifdef NESTING ! !----------------------------------------------------------------------- -! Compute Lagrangian drifters trajectories. +! If refinement grid, interpolate (space, time) state variables +! contact points from donor grid extracted data. !----------------------------------------------------------------------- ! -! Shift floats time indices. -! - DO ng=1,Ngrids - IF (Lfloats(Ng)) THEN - nfp1(ng)=MOD(nfp1(ng)+1,NFT+1) - nf (ng)=MOD(nf (ng)+1,NFT+1) - nfm1(ng)=MOD(nfm1(ng)+1,NFT+1) - nfm2(ng)=MOD(nfm2(ng)+1,NFT+1) - nfm3(ng)=MOD(nfm3(ng)+1,NFT+1) -! -# ifdef _OPENMP - chunk_size=(Nfloats(ng)+numthreads-1)/numthreads - Lstr=1+MyThread*chunk_size - Lend=MIN(Nfloats(ng),Lstr+chunk_size-1) -# else - Lstr=1 - Lend=Nfloats(ng) -# endif - CALL ad_step_floats (ng, Lstr, Lend) - END IF - END DO + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (RefinedGrid(ng).and.(RefineScale(ng).gt.0)) THEN + CALL ad_nesting (ng, iADM, nputD) + END IF + END DO # endif + +# ifdef NESTING ! -!----------------------------------------------------------------------- -! Solve the vertically integrated primitive equations for the -! free-surface and momentum components. -!----------------------------------------------------------------------- -! -! Corrector step - Apply 2D time-step corrector scheme. Notice that -! ============== there is not need for a corrector step during the -! auxiliary (nfast+1) time-step. +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for 3D kernel free-surface. ! - DO ng=1,Ngrids - iif(ng)=1 - nfast(ng)=1 - IF (iif(ng).lt.(nfast(ng)+1)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL ad_step2d (ng, tile) - END DO - END IF -! -! Set time indices for corrector step. -! - next_indx1=3-indx1(ng) - IF (.not.PREDICTOR_2D_STEP(ng)) THEN - PREDICTOR_2D_STEP(ng)=.TRUE. - ktmp=knew(ng) - ksav=kstp(ng) - knew(ng)=krhs(ng) - kstp(ng)=ktmp - krhs(ng)=ksav - END IF - END DO -! -! Predictor step - Advance barotropic equations using 2D time-step -! ============== predictor scheme. -! - DO ng=1,Ngrids - DO tile=last_tile(ng),first_tile(ng),-1 - CALL ad_step2d (ng, tile) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL ad_nesting (ng, iADM, nzeta) + END IF END DO -! -! Set time indices for predictor step. The PREDICTOR_2D_STEP switch -! it is assumed to be false before the first time-step. -! - IF (PREDICTOR_2D_STEP(ng).and. & - & (iic(ng).ne.ntend(ng))) THEN - PREDICTOR_2D_STEP(ng)=.FALSE. - ksav=knew(ng) - knew(ng)=krhs(ng) - krhs(ng)=ksav - END IF - END DO - - END IF TIME_STEP +# endif # ifdef SO_SEMI ! @@ -318,181 +655,229 @@ SUBROUTINE ad_main2d (RunInterval) ! dynamical propagator. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (MOD(iic(ng)-1,nADJ(ng)).eq.0) THEN - SOrec(ng)=SOrec(ng)+1 - DO tile=first_tile(ng),last_tile(ng),+1 - CALL ad_pack (ng, tile, Nstr(ng), Nend(ng), & - & STORAGE(ng)%so_state(:,SOrec(ng))) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (MOD(iic(ng)-1,nADJ(ng)).eq.0) THEN + SOrec(ng)=SOrec(ng)+1 + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ad_pack (ng, tile, Nstr(ng), Nend(ng), & + & STORAGE(ng)%so_state(:,SOrec(ng))) + END DO + END IF + END DO +# endif + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for bottom stress variables. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL ad_nesting (ng, iADM, nbstr) + END IF END DO - END IF - END DO # endif ! !----------------------------------------------------------------------- -! Set vertical boundary conditions. Process tidal forcing. +! Set adjoint fields for vertical boundary conditions. Process tidal +! forcing, if any. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=first_tile(ng),last_tile(ng),+1 # if defined SSH_TIDES_NOT_YET || defined UV_TIDES_NOT_YET - CALL ad_set_tides (ng, tile) + CALL ad_set_tides (ng, tile) # endif - CALL ad_set_vbc (ng, tile) - END DO - END DO + CALL ad_set_vbc (ng, tile) + END DO + END DO # if defined WAV_COUPLING_NOT_YET && defined MCT_LIB ! !----------------------------------------------------------------------- -! Couple to waves model every CoupleSteps(Iwaves,ng) timesteps: get +! Couple to waves model every CoupleSteps(Iwaves) timesteps: get ! waves/sea fluxes. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF ((iic(ng).ne.ntstart(ng)).and. & - & MOD(iic(ng)-1,CoupleSteps(Iwaves,ng)).eq.0) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL ocn2wav_coupling (ng, tile) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF ((iic(ng).ne.ntstart(ng)).and. & + & MOD(iic(ng)-1,CoupleSteps(Iwaves,ng)).eq.0) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ocn2wav_coupling (ng, tile) + END DO + END IF END DO - END IF - END DO # endif -# if defined ATM_COUPLING_NOT_YET && defined MCT_LIB +# ifdef ADJUST_WSTRESS ! !----------------------------------------------------------------------- -! Couple to atmospheric model every CoupleSteps(Iatmos) timesteps: get -! air/sea fluxes. +! Interpolate surface forcing increments and adjust surface forcing. +! Skip first timestep. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF ((iic(ng).ne.ntstart(ng)).and. & - & MOD(iic(ng)-1,CoupleSteps(Iatmos,ng)).eq.0) THEN - DO tile=last_tile(ng),first_tile(ng),-1 - CALL ocn2atm_coupling (ng, tile) +# ifdef RBL4DVAR_FCT_SENSITIVITY + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (.not.Lsen4DVAR(ng)) THEN ! ignore in forecast + IF (iic(ng).ne.ntstart(ng)) THEN ! interval + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ad_frc_adjust (ng, tile, Lfout(ng)) + END DO + END IF + END IF END DO - END IF - END DO +# else + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (iic(ng).ne.ntstart(ng)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ad_frc_adjust (ng, tile, Lfout(ng)) + END DO + END IF + END DO +# endif # endif -# ifdef AD_OUTPUT_STATE + +# ifdef ADJUST_BOUNDARY ! !----------------------------------------------------------------------- -! Set full adjoint output arrays. Due to the predictor/corrector and -! multiple time level schemes, pieces of the adjoint solution are in -! two-time levels and need to be added in the "_sol" arrays for output -! purposes. +! Interpolate open boundary increments and adjust open boundaries. +! Skip first timestep. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (iic(ng).ne.ntend(ng)) THEN - DO tile=last_tile(ng),first_tile(ng),-1 - CALL ad_out_fields (ng, tile, iADM) +# ifdef RBL4DVAR_FCT_SENSITIVITY + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (.not.Lsen4DVAR(ng)) THEN ! ignore in forecast + IF (iic(ng).ne.ntstart(ng)) THEN ! interval + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ad_obc_adjust (ng, tile, Lbout(ng)) + END DO + END IF + END IF END DO - DO tile=first_tile(ng),last_tile(ng),+1 - CALL ad_out_zeta (ng, tile, iADM) +# else + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (iic(ng).ne.ntstart(ng)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ad_obc_adjust (ng, tile, Lbout(ng)) + END DO + END IF END DO - END IF - END DO +# endif # endif + +# if defined ATM_COUPLING_NOT_YET && defined MCT_LIB ! !----------------------------------------------------------------------- -! If not a restart, initialize all time levels and compute other -! initial fields. +! Couple to atmospheric model every CoupleSteps(Iatmos) timesteps: get +! air/sea fluxes. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (iic(ng).eq.ntend(ng)) THEN -! -! Initialize other state variables. -! - DO tile=last_tile(ng),first_tile(ng),-1 - CALL ad_ini_fields (ng, tile, iADM) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF ((iic(ng).ne.ntstart(ng)).and. & + & MOD(iic(ng)-1,CoupleSteps(Iatmos,ng)).eq.0) THEN + DO tile=last_tile(ng),first_tile(ng),-1 + CALL ocn2atm_coupling (ng, tile) + END DO + END IF END DO +# endif ! -! Initialize free-surface. +!----------------------------------------------------------------------- +! Compute and report diagnostics. If appropriate, accumulate time- +! averaged output data which needs a irreversible loop in shared-memory +! jobs. +!----------------------------------------------------------------------- ! - DO tile=first_tile(ng),last_tile(ng),+1 - CALL ad_ini_zeta (ng, tile, iADM) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=first_tile(ng),last_tile(ng),+1 ! irreversible + CALL ad_diag (ng, tile) +# ifdef AD_AVERAGES + CALL ad_set_avg (ng, tile) +# endif + END DO END DO - END IF - END DO + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN # ifdef FORCING_SV ! !----------------------------------------------------------------------- -! Compute adjoint forcing for forcing singular vectors. +! Compute the adjoint forcing for the forcing singular vectors. !----------------------------------------------------------------------- ! - IF (iic(ng).ne.ntend(ng)) THEN - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 - CALL ad_forcing (ng, tile, kstp(ng), knew(ng), nstp(ng)) - END DO - END DO - ELSE - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 - CALL ad_forcing (ng, tile, kstp(ng), krhs(ng), nstp(ng)) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ad_forcing (ng, tile, kstp(ng), nstp(ng)) + END DO END DO - END DO - END IF # endif -# ifdef ADJUST_WSTRESS +# ifdef AD_OUTPUT_STATE ! !----------------------------------------------------------------------- -! Interpolate surface forcing increments and adjust surface forcing. -! Skip first timestep. +! Set full adjoint output arrays. Due to the exact discrete adjoint, +! the predictor/corrector time-stepping scheme with multiple time +! levels, pieces of the adjoint solution are in two-time levels and +! need to be added in the "_sol" arrays for output purposes. !----------------------------------------------------------------------- ! -# ifdef RBL4DVAR_FCT_SENSITIVITY - DO ng=1,Ngrids - IF (.not.Lsen4DVAR(ng)) THEN ! ignore in forecast interval - IF (iic(ng).ne.ntstart(ng)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL ad_frc_adjust (ng, tile, Lfout(ng)) - END DO - END IF - END IF - END DO -# else - DO ng=1,Ngrids - IF (iic(ng).ne.ntstart(ng)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL ad_frc_adjust (ng, tile, Lfout(ng)) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (iic(ng).ne.ntend(ng)) THEN + DO tile=last_tile(ng),first_tile(ng),-1 + CALL ad_out_fields (ng, tile, iADM) + END DO + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ad_out_zeta (ng, tile, iADM) + END DO + END IF END DO - END IF - END DO -# endif # endif -# ifdef ADJUST_BOUNDARY +# ifndef FORCING_SV ! !----------------------------------------------------------------------- -! Interpolate open boundary increments and adjust open boundaries. -! Skip first timestep. +! If not a restart, initialize all time levels and compute other +! initial fields. !----------------------------------------------------------------------- ! -# ifdef RBL4DVAR_FCT_SENSITIVITY - DO ng=1,Ngrids - IF (.not.Lsen4DVAR(ng)) THEN ! ignore in forecast interval - IF (iic(ng).ne.ntstart(ng)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL ad_obc_adjust (ng, tile, Lbout(ng)) - END DO - END IF - END IF - END DO -# else - DO ng=1,Ngrids - IF (iic(ng).ne.ntstart(ng)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL ad_obc_adjust (ng, tile, Lbout(ng)) - END DO - END IF - END DO + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (iic(ng).eq.ntend(ng)) THEN +# ifdef NESTING +! +! Extract donor grid initial data at contact points and store it in +! REFINED structure so it can be used for the space-time interpolation. +! + IF (RefinedGrid(ng)) THEN + CALL ad_nesting (ng, iADM, ngetD) + END IF # endif +! +! Adjoint of initialize other state variables. +! + DO tile=last_tile(ng),first_tile(ng),-1 + CALL ad_ini_fields (ng, tile, iADM) + END DO +! +! Adjoint of initialize free-surface and compute initial level +! thicknesses and depths. +! + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ad_ini_zeta (ng, tile, iADM) + END DO + END IF + END DO # endif # if defined WEAK_CONSTRAINT && !defined SP4DVAR @@ -501,23 +886,27 @@ SUBROUTINE ad_main2d (RunInterval) ! Gather weak constraint forcing to storage arrays. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (iic(ng).ne.ntstart(ng)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL frc_ADgather (ng, tile) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (iic(ng).ne.ntstart(ng)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL frc_ADgather (ng, tile) + END DO + END IF END DO - END IF - END DO # endif ! !----------------------------------------------------------------------- -! If appropriate, write out fields into output NetCDF files. +! If appropriate, write out fields into output NetCDF files. Notice +! that IO data is written in delayed and serial mode. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - CALL ad_output (ng) - IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN - END DO + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + CALL ad_output (ng) + IF (FoundError(exit_flag, NoError, & + & __LINE__, MyFile)) RETURN + END DO # if defined WEAK_CONSTRAINT && !defined SP4DVAR ! @@ -525,43 +914,65 @@ SUBROUTINE ad_main2d (RunInterval) ! Copy storage arrays index 1 into index 2, and clear index 1. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (MOD(iic(ng)-1,nADJ(ng)).eq.0) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL frc_clear (ng, tile) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (MOD(iic(ng)-1,nADJ(ng)).eq.0) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL frc_clear (ng, tile) + END DO + END IF END DO - END IF - END DO # endif -# if defined AD_SENSITIVITY || defined I4DVAR_ANA_SENSITIVITY || \ - defined OPT_OBSERVATIONS || defined SENSITIVITY_4DVAR +# if (defined AD_SENSITIVITY || defined I4DVAR_ANA_SENSITIVITY || \ + defined OPT_OBSERVATIONS || defined SENSITIVITY_4DVAR) && \ + !defined OBS_SPACE ! !----------------------------------------------------------------------- ! Add appropriate forcing terms to the adjoint model. The form of the ! forcing depends on the functional whose sensitivity is required. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) # ifdef SENSITIVITY_4DVAR - IF (Lsen4DVAR(ng)) THEN + IF (Lsen4DVAR(ng)) THEN # endif # if !defined AD_IMPULSE - IF ((DendS(ng).ge.tdays(ng)).and. & - & (tdays(ng).ge.DstrS(ng))) THEN + IF ((DendS(ng).ge.tdays(ng)).and. & + & (tdays(ng).ge.DstrS(ng))) THEN # endif - DO tile=first_tile(ng),last_tile(ng),+1 - CALL adsen_force (ng, tile) - END DO + DO tile=first_tile(ng),last_tile(ng),+1 + CALL adsen_force (ng, tile) + END DO # if !defined AD_IMPULSE - END IF + END IF # endif # ifdef SENSITIVITY_4DVAR - END IF + END IF # endif - END DO + END DO # endif - END DO STEP_LOOP +! +!----------------------------------------------------------------------- +! Set adjoint time indices and time clock. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + iic(ng)=iic(ng)-1 +# ifndef NESTING + step_counter(ng)=step_counter(ng)-1 +# endif + time(ng)=time(ng)-dt(ng) + CALL time_string (time(ng), time_code(ng)) + END DO + + END DO STEP_LOOP + + END DO NEST_LAYER + + END DO KERNEL_LOOP ! RETURN END SUBROUTINE ad_main2d diff --git a/ROMS/Adjoint/ad_main3d.F b/ROMS/Adjoint/ad_main3d.F index 3c55a8ead..d90d9a525 100644 --- a/ROMS/Adjoint/ad_main3d.F +++ b/ROMS/Adjoint/ad_main3d.F @@ -14,6 +14,14 @@ SUBROUTINE ad_main3d (RunInterval) ! backwards the adjoint model equations for all nested grids, if ! ! any, by the specified time interval (seconds), RunInterval. ! ! ! +# if defined STEP2D_FB_LF_AM3 +! Numerical 2D time-stepping kernel: FB AB3-AM4 ! +# elif defined STEP2D_FB_LF_AM3 +! Numerical 2D time-stepping kernel: FB LF-AM3 ! +# else +! Numerical 2D time-stepping kernel: LF-AM3 (Legacy scheme) ! +# endif +! ! !======================================================================= ! USE mod_param @@ -56,7 +64,7 @@ SUBROUTINE ad_main3d (RunInterval) # ifdef BVF_MIXING_NOT_YET !! USE ad_bvf_mix_mod, ONLY : ad_bvf_mix # endif - USE ad_diag_mod, ONLY : ad_diag + USE ad_diag_mod, ONLY : ad_diag # if defined ADJUST_STFLUX || defined ADJUST_WSTRESS USE ad_frc_adjust_mod, ONLY : ad_frc_adjust # endif @@ -119,7 +127,9 @@ SUBROUTINE ad_main3d (RunInterval) !! USE ad_set_tides_mod, ONLY : ad_set_tides # endif USE ad_set_vbc_mod, ONLY : ad_set_vbc +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) USE ad_set_zeta_mod, ONLY : ad_set_zeta +# endif USE ad_step2d_mod, ONLY : ad_step2d # ifndef TS_FIXED USE ad_step3d_t_mod, ONLY : ad_step3d_t @@ -135,15 +145,15 @@ SUBROUTINE ad_main3d (RunInterval) # ifdef TIDE_GENERATING_FORCES USE equilibrium_tide_mod, ONLY : equilibrium_tide # endif -# ifdef WEAK_CONSTRAINT - USE frc_weak_mod, ONLY : frc_ADgather, frc_clear -# endif # if defined ATM_COUPLING_NOT_YET && defined MCT_LIB USE mct_coupler_mod, ONLY : ocn2atm_coupling # endif # if defined WAV_COUPLING_NOT_YET && defined MCT_LIB USE mct_coupler_mod, ONLY : ocn2wav_coupling # endif +# ifdef WEAK_CONSTRAINT + USE frc_weak_mod, ONLY : frc_ADgather, frc_clear +# endif # if (defined FOUR_DVAR && !defined I4DVAR_ANA_SENSITIVITY) && \ defined OBSERVATIONS USE obs_read_mod, ONLY : obs_read @@ -507,12 +517,7 @@ SUBROUTINE ad_main3d (RunInterval) CALL ad_step3d_uv (ng, tile) END DO END DO -! -!----------------------------------------------------------------------- -! Adjoint of recompute depths and thicknesses using the new time -! filtered free-surface. This call was moved from "ad_step2d" to here. -!----------------------------------------------------------------------- -! + # ifdef NESTING ! ! If nesting, determine vertical indices and vertical interpolation @@ -523,12 +528,21 @@ SUBROUTINE ad_main3d (RunInterval) CALL ad_nesting (ng, iADM, nzwgt) END DO # endif + +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) +! +!----------------------------------------------------------------------- +! Adjoint of recompute depths and thicknesses using the new time +! filtered free-surface. This call was moved from "ad_step2d" to here. +!----------------------------------------------------------------------- +! DO ig=1,GridsInLayer(nl) ng=GridNumber(ig,nl) DO tile=last_tile(ng),first_tile(ng),-1 CALL ad_set_depth (ng, tile, iADM) END DO END DO +# endif # ifdef NESTING ! @@ -556,6 +570,127 @@ SUBROUTINE ad_main3d (RunInterval) END DO # endif # endif + +# ifdef STEP2D_FB_AB3_AM4 +! +!----------------------------------------------------------------------- +! Solve the vertically integrated primitive equations for the +! free-surface and barotropic momentum components using a generalized +! Forward-Backward, 3rd-order Adams-Bashforth / 4th-order Adams-Moulton +! (FB AB3-AM4) time stepping scheme (Shchepetkin and McWilliams, 2009). +!----------------------------------------------------------------------- +! + LOOP_2D : DO my_iif=MAXVAL(nfast),1,-1 + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine Corrector step section. +! If refinement, check mass flux conservation between coarse and +! fine grids during debugging. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL ad_nesting (ng, iADM, n2dCS) + END IF + END DO +# endif + + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (my_iif.le.nfast(ng)) THEN + iif(ng)=my_iif +!^ kstp(ng)=knew(ng) +!^ knew(ng)=kstp(ng)+1 +!^ IF (knew(ng).gt.4) knew(ng)=1 +!^ + knew(ng)=kstp(ng) + kstp(ng)=knew(ng)-1 + IF (kstp(ng).lt.1) kstp(ng)=4 + + IF (MOD(knew(ng),2).eq.0) THEN ! zig-zag + DO tile=first_tile(ng),last_tile(ng),+1 ! processing + CALL ad_step2d (ng, tile) ! sequence + END DO + ELSE + DO tile=last_tile(ng),first_tile(ng),-1 + CALL ad_step2d (ng, tile) + END DO + END IF + END IF + END DO + + END DO LOOP_2D +# else + +# ifdef STEP2D_FB_LF_AM3 +! +!----------------------------------------------------------------------- +! Solve the vertically integrated primitive equations for the +! free-surface and barotropic momentum components using a predictor- +! corrector LeapFrog / 3rd-order Adams-Moulton with a Forward-Backward +! feeback (FB LF-AM3) stepping scheme (Shchepetkin and McWilliams, +! 2009). +!----------------------------------------------------------------------- +! + LOOP_2D : DO my_iif=MAXVAL(nfast),1,-1 + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine Corrector step section. +! If refinement, check mass flux conservation between coarse and +! fine grids during debugging. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL ad_nesting (ng, iADM, n2dCS) + END IF + END DO +# endif +! +! Corrector AM3 substep with FB-feedback. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (my_iif.le.nfast(ng)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ad_step2d (ng, tile) + END DO + +!^ knew(ng)=3-kstp(ng) +!^ next_kstp(ng)=knew(ng) +!^ + knew(ng)=next_kstp(ng) + kstp(ng)=3-knew(ng) + END IF + END DO +! +! Predictor LF substep with FB-feedback. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (my_iif.le.nfast(ng)) THEN + iif(ng)=my_iif + DO tile=last_tile(ng),first_tile(ng),-1 + CALL ad_step2d (ng, tile) + END DO + +!^ kstp(ng)=next_kstp(ng) +!^ knew(ng)=3 +!^ +!^ HGA: Need to compute the adjoint of the indices + + END IF + END DO + + END DO LOOP_2D + +# else ! !----------------------------------------------------------------------- ! Solve adjoint vertically integrated primitive equations for the @@ -564,7 +699,7 @@ SUBROUTINE ad_main3d (RunInterval) ! LOOP_2D : DO my_iif=MAXVAL(nfast)+1,1,-1 -# ifdef NESTING +# ifdef NESTING ! ! If composite or mosaic grids, process additional points in the ! contact zone between connected grids for the state variables @@ -581,7 +716,7 @@ SUBROUTINE ad_main3d (RunInterval) CALL ad_nesting (ng, iADM, nmflx) END IF END DO -# endif +# endif ! ! Corrector step - Apply 2D adjoint time-step corrector scheme. Notice ! ============== that there is not need for a corrector step during @@ -614,7 +749,7 @@ SUBROUTINE ad_main3d (RunInterval) END IF END DO -# ifdef NESTING +# ifdef NESTING ! ! If composite or mosaic grids, process additional points in the @@ -632,7 +767,7 @@ SUBROUTINE ad_main3d (RunInterval) CALL ad_nesting (ng, iADM, nmflx) END IF END DO -# endif +# endif ! ! Predictor step - Advance adjoint barotropic equations using 2D ! ============== time-step predictor scheme. No actual time- @@ -670,7 +805,8 @@ SUBROUTINE ad_main3d (RunInterval) END DO END DO LOOP_2D - +# endif +# endif END IF ADVANCE # if (defined FOUR_DVAR && !defined I4DVAR_ANA_SENSITIVITY) && \ @@ -805,6 +941,9 @@ SUBROUTINE ad_main3d (RunInterval) END IF END DO # endif + +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) || \ + defined DIAGNOSTICS ! !----------------------------------------------------------------------- ! Set adjoint free-surface to it time-averaged value. @@ -813,12 +952,15 @@ SUBROUTINE ad_main3d (RunInterval) DO ig=1,GridsInLayer(nl) ng=GridNumber(ig,nl) DO tile=first_tile(ng),last_tile(ng),+1 -# ifdef DIAGNOSTICS +# ifdef DIAGNOSTICS !! CALL set_diags (ng, tile) -# endif +# endif +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) CALL ad_set_zeta (ng, tile) +# endif END DO END DO +# endif ! !----------------------------------------------------------------------- ! Compute adjoint vertical mixing coefficients for momentum and diff --git a/ROMS/Adjoint/ad_set_data.F b/ROMS/Adjoint/ad_set_data.F index d6f6580de..71a53fa87 100644 --- a/ROMS/Adjoint/ad_set_data.F +++ b/ROMS/Adjoint/ad_set_data.F @@ -1182,7 +1182,11 @@ SUBROUTINE ad_set_data_tile (ng, tile, & ! ! Set forward free-surface. ! +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + DO k=1,4 +# else DO k=1,3 +# endif CALL set_2dfldr_tile (ng, tile, iADM, idFsur, & & LBi, UBi, LBj, UBj, & & OCEAN(ng)%zetaG, & @@ -1201,7 +1205,11 @@ SUBROUTINE ad_set_data_tile (ng, tile, & ! ! Set forward 2D momentum. ! +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + DO k=1,4 +# else DO k=1,3 +# endif CALL set_2dfldr_tile (ng, tile, iADM, idUbar, & & LBi, UBi, LBj, UBj, & & OCEAN(ng)%ubarG, & diff --git a/ROMS/Adjoint/ad_set_zeta.F b/ROMS/Adjoint/ad_set_zeta.F index c7cadedac..fc1304fb9 100644 --- a/ROMS/Adjoint/ad_set_zeta.F +++ b/ROMS/Adjoint/ad_set_zeta.F @@ -1,7 +1,8 @@ #include "cppdefs.h" MODULE ad_set_zeta_mod -#if defined ADJOINT && defined SOLVE3D +#if defined ADJOINT && defined SOLVE3D && \ + !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) ! !git $Id$ !================================================== Hernan G. Arango === @@ -85,7 +86,7 @@ SUBROUTINE ad_set_zeta_tile (ng, tile, & real(r8), intent(out) :: ad_zeta_sol(LBi:,LBj:) # else real(r8), intent(inout) :: ad_Zt_avg1(LBi:UBi,LBj:UBj) - real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,3) + real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:) real(r8), intent(out) :: ad_zeta_sol(LBi:UBi,LBj:UBj) # endif diff --git a/ROMS/Adjoint/ad_step2d.F b/ROMS/Adjoint/ad_step2d.F index 53f5edcf3..62d1f890d 100644 --- a/ROMS/Adjoint/ad_step2d.F +++ b/ROMS/Adjoint/ad_step2d.F @@ -8,16 +8,27 @@ ! See License_ROMS.md ! !======================================================================= ! ! -! This subroutine performs a fast (predictor or corrector) time-step ! -! for the free-surface and 2D momentum adjoint equations. ! +! This module timesteps the Adjoint Model (ADM) vertically-integrated ! +! primitive (2D shallow-water) equations for the free-surface and 2D ! +! momentum. In 3D applications, the ROMS numerical kernel is split ! +! between baroclinic and barotropic dynamics. The barotropic engine ! +! uses a smaller timestep in this routine to resolve fast gravity ! +! wave processes. ! # ifdef SOLVE3D +! ! ! It also calculates the time filtering variables over all fast-time ! ! steps to damp high frequency signals in 3D applications. ! # endif ! ! !======================================================================= ! -# include "ad_step2d_LF_AM3.h" +# if defined STEP2D_FB_AB3_AM4 +# include "ad_step2d_FB.h" +# elif defined STEP2D_FB_LF_AM3 +# include "ad_step2d_FB_LF_AM3.h" +# else +# include "ad_step2d_LF_AM3.h" +# endif #else MODULE ad_step2d_mod END MODULE ad_step2d_mod diff --git a/ROMS/Adjoint/ad_step2d_FB.h b/ROMS/Adjoint/ad_step2d_FB.h index 8cbda9aad..e1b5c60c5 100644 --- a/ROMS/Adjoint/ad_step2d_FB.h +++ b/ROMS/Adjoint/ad_step2d_FB.h @@ -156,7 +156,7 @@ & FORCES(ng) % Pair, & # endif #else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET & COUPLING(ng) % rhoA, & & COUPLING(ng) % ad_rhoA, & & COUPLING(ng) % rhoS, & @@ -254,7 +254,7 @@ & Pair, & # endif #else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET & rhoA, ad_rhoA, & & rhoS, ad_rhoS, & # endif @@ -357,7 +357,7 @@ real(r8), intent(in ) :: Pair(LBi:,LBj:) # endif # else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET real(r8), intent(in ) :: rhoA(LBi:,LBj:) real(r8), intent(in ) :: rhoS(LBi:,LBj:) real(r8), intent(inout) :: ad_rhoA(LBi:,LBj:) @@ -474,7 +474,7 @@ real(r8), intent(in ) :: Pair(LBi:UBi,LBj:UBj) # endif # else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET real(r8), intent(in ) :: rhoA(LBi:UBi,LBj:UBj) real(r8), intent(in ) :: rhoS(LBi:UBi,LBj:UBj) real(r8), intent(inout) :: ad_rhoA(LBi:UBi,LBj:UBj) @@ -571,7 +571,7 @@ real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: grad #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta2 -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzetaSA #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rubar @@ -615,7 +615,7 @@ real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_grad #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rzeta2 -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rzetaSA #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rzeta @@ -666,7 +666,7 @@ ad_grad=IniVal #endif ad_rzeta2=IniVal -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D ad_rzetaSA=IniVal #endif ad_rzeta=IniVal @@ -924,7 +924,7 @@ & bkw0*zeta(i,j,kstp)+ & & bkw1*zeta(i,j,kbak)+ & & bkw2*zeta(i,j,kold) -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j) rzeta2(i,j)=rzeta(i,j)*zwrk(i,j) rzetaSA(i,j)=zwrk(i,j)*(rhoS(i,j)-rhoA(i,j)) @@ -2059,7 +2059,7 @@ END IF ! cff1=0.5*g -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D cff2=0.333333333333_r8 # endif ! @@ -2080,7 +2080,7 @@ !^ & h(i,j ))* & !^ & (tl_rzeta(i,j-1)- & !^ & tl_rzeta(i,j ))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (tl_h(i,j-1)- & !^ & tl_h(i,j ))* & !^ & (rzetaSA(i,j-1)+ & @@ -2114,7 +2114,7 @@ ad_rzeta(i,j )=ad_rzeta(i,j )-adfac2 ad_rzeta2(i,j-1)=ad_rzeta2(i,j-1)+adfac ad_rzeta2(i,j )=ad_rzeta2(i,j )-adfac -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D adfac3=adfac*(rzetaSA(i,j-1)+ & & rzetaSA(i,j )+ & & cff2*(rhoA(i,j-1)- & @@ -2149,7 +2149,7 @@ !^ & h(i ,j))* & !^ & (tl_rzeta(i-1,j)- & !^ & tl_rzeta(i ,j))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (tl_h(i-1,j)- & !^ & tl_h(i ,j))* & !^ & (rzetaSA(i-1,j)+ & @@ -2183,7 +2183,7 @@ ad_rzeta(i ,j)=ad_rzeta(i ,j)-adfac2 ad_rzeta2(i-1,j)=ad_rzeta2(i-1,j)+adfac ad_rzeta2(i ,j)=ad_rzeta2(i ,j)-adfac -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D adfac3=adfac*(rzetaSA(i-1,j)+ & & rzetaSA(i ,j)+ & & cff2*(rhoA(i-1,j)- & @@ -2211,7 +2211,7 @@ ! DO j=JstrV-1,Jend DO i=IstrU-1,Iend -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ tl_rzetaSA(i,j)=tl_zwrk(i,j)* & !^ & (rhoS(i,j)-rhoA(i,j))+ & !^ & zwrk(i,j)* & @@ -3354,7 +3354,7 @@ !----------------------------------------------------------------------- ! cff1=0.5_r8*g -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D cff2=0.333333333333_r8 #endif #if defined ATM_PRESS && !defined SOLVE3D @@ -3409,7 +3409,7 @@ !^ & h(i,j ))* & !^ & (tl_rzeta(i,j-1)- & !^ & tl_rzeta(i,j ))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (tl_h(i,j-1)- & !^ & tl_h(i,j ))* & !^ & (rzetaSA(i,j-1)+ & @@ -3443,7 +3443,7 @@ ad_rzeta(i,j )=ad_rzeta(i,j )-adfac2 ad_rzeta2(i,j-1)=ad_rzeta2(i,j-1)+adfac ad_rzeta2(i,j )=ad_rzeta2(i,j )-adfac -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D adfac3=adfac*(rzetaSA(i,j-1)+ & & rzetaSA(i,j )+ & & cff2*(rhoA(i,j-1)- & @@ -3511,7 +3511,7 @@ !^ & h(i ,j))* & !^ & (tl_rzeta(i-1,j)- & !^ & tl_rzeta(i ,j))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (tl_h(i-1,j)- & !^ & tl_h(i ,j))* & !^ & (rzetaSA(i-1,j)+ & @@ -3545,7 +3545,7 @@ ad_rzeta(i ,j)=ad_rzeta(i ,j)-adfac2 ad_rzeta2(i-1,j)=ad_rzeta2(i-1,j)+adfac ad_rzeta2(i ,j)=ad_rzeta2(i ,j)-adfac -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D adfac3=adfac*(rzetaSA(i-1,j)+ & & rzetaSA(i ,j)+ & & cff2*(rhoA(i-1,j)- & @@ -3705,7 +3705,7 @@ DO j=JstrV-1,Jend DO i=IstrU-1,Iend fac=dtfast(ng)*pm(i,j)*pn(i,j) -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ tl_rzetaSA(i,j)=tl_zwrk(i,j)*(rhoS(i,j)-rhoA(i,j))+ & !^ & zwrk(i,j)*(tl_rhoS(i,j)-tl_rhoA(i,j)) !^ diff --git a/ROMS/Adjoint/ad_step2d_FB_LF_AM3.h b/ROMS/Adjoint/ad_step2d_FB_LF_AM3.h index 31f9db46f..541089e0d 100644 --- a/ROMS/Adjoint/ad_step2d_FB_LF_AM3.h +++ b/ROMS/Adjoint/ad_step2d_FB_LF_AM3.h @@ -145,7 +145,7 @@ & FORCES(ng) % Pair, & # endif #else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET & COUPLING(ng) % rhoA, & & COUPLING(ng) % ad_rhoA, & & COUPLING(ng) % rhoS, & @@ -236,7 +236,7 @@ & Pair, & # endif #else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET & rhoA, ad_rhoA, & & rhoS, ad_rhoS, & # endif @@ -332,7 +332,7 @@ real(r8), intent(inout) :: Pair(LBi:,LBj:) # endif # else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET real(r8), intent(in ) :: rhoA(LBi:,LBj:) real(r8), intent(in ) :: rhoS(LBi:,LBj:) real(r8), intent(inout) :: ad_rhoA(LBi:,LBj:) @@ -443,7 +443,7 @@ real(r8), intent(in ) :: Pair(LBi:UBi,LBj:UBj) # endif # else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET real(r8), intent(in ) :: rhoA(LBi:UBi,LBj:UBj) real(r8), intent(in ) :: rhoS(LBi:UBi,LBj:UBj) real(r8), intent(inout) :: ad_rhoA(LBi:UBi,LBj:UBj) @@ -545,7 +545,7 @@ real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rvbar real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta2 -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzetaSA #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: zeta_new @@ -583,7 +583,7 @@ real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_grad #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rzeta2 -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rzetaSA #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_rzeta @@ -677,7 +677,7 @@ ad_grad=IniVal #endif ad_rzeta2=IniVal -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D ad_rzetaSA=IniVal #endif ad_rzeta=IniVal @@ -853,7 +853,7 @@ zwrk(i,j)=cff1*zeta_new(i,j)+ & & cff2*zeta(i,j,kstp)+ & & cff3*zeta(i,j,kbak) -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j) rzeta2(i,j)=rzeta(i,j)*zwrk(i,j) rzetaSA(i,j)=zwrk(i,j)*(rhoS(i,j)-rhoA(i,j)) @@ -891,7 +891,7 @@ & cff1*zeta_new(i,j)+ & & cff2*zeta(i,j,kstp)+ & & cff3*zeta(i,j,kbak) -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j) rzeta2(i,j)=rzeta(i,j)*zwrk(i,j) rzetaSA(i,j)=zwrk(i,j)*(rhoS(i,j)-rhoA(i,j)) @@ -2078,7 +2078,7 @@ !^ & h(i,j ))* & !^ & (tl_rzeta(i,j-1)- & !^ & tl_rzeta(i,j ))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (tl_h(i,j-1)- & !^ & tl_h(i,j ))* & !^ & (rzetaSA(i,j-1)+ & @@ -2112,7 +2112,7 @@ ad_rzeta(i,j )=ad_rzeta(i,j )-adfac2 ad_rzeta2(i,j-1)=ad_rzeta2(i,j-1)+adfac ad_rzeta2(i,j )=ad_rzeta2(i,j )-adfac -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D adfac3=adfac*(rzetaSA(i,j-1)+ & & rzetaSA(i,j )+ & & cff2*(rhoA(i,j-1)- & @@ -2147,7 +2147,7 @@ !^ & h(i ,j))* & !^ & (tl_rzeta(i-1,j)- & !^ & tl_rzeta(i ,j))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (tl_h(i-1,j)- & !^ & tl_h(i ,j))* & !^ & (rzetaSA(i-1,j)+ & @@ -2181,7 +2181,7 @@ ad_rzeta(i ,j)=ad_rzeta(i ,j)-adfac2 ad_rzeta2(i-1,j)=ad_rzeta2(i-1,j)+adfac ad_rzeta2(i ,j)=ad_rzeta2(i ,j)-adfac -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D adfac3=adfac*(rzetaSA(i-1,j)+ & & rzetaSA(i ,j)+ & & cff2*(rhoA(i-1,j)- & @@ -2214,7 +2214,7 @@ DO j=JstrV-1,Jend DO i=IstrU-1,Iend -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ tl_rzetaSA(i,j)=tl_zwrk(i,j)* & !^ & (rhoS(i,j)-rhoA(i,j))+ & !^ & zwrk(i,j)* & @@ -3441,7 +3441,7 @@ !^ & h(i,j ))* & !^ & (tl_rzeta(i,j-1)- & !^ & tl_rzeta(i,j ))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (tl_h(i,j-1)- & !^ & tl_h(i,j ))* & !^ & (rzetaSA(i,j-1)+ & @@ -3475,7 +3475,7 @@ ad_rzeta(i,j )=ad_rzeta(i,j )-adfac2 ad_rzeta2(i,j-1)=ad_rzeta2(i,j-1)+adfac ad_rzeta2(i,j )=ad_rzeta2(i,j )-adfac -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D adfac3=adfac*(rzetaSA(i,j-1)+ & & rzetaSA(i,j )+ & & cff2*(rhoA(i,j-1)- & @@ -3543,7 +3543,7 @@ !^ & h(i ,j))* & !^ & (tl_rzeta(i-1,j)- & !^ & tl_rzeta(i ,j))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (tl_h(i-1,j)- & !^ & tl_h(i ,j))* & !^ & (rzetaSA(i-1,j)+ & @@ -3577,7 +3577,7 @@ ad_rzeta(i ,j)=ad_rzeta(i ,j)-adfac2 ad_rzeta2(i-1,j)=ad_rzeta2(i-1,j)+adfac ad_rzeta2(i ,j)=ad_rzeta2(i ,j)-adfac -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D adfac3=adfac*(rzetaSA(i-1,j)+ & & rzetaSA(i ,j)+ & & cff2*(rhoA(i-1,j)- & @@ -3715,7 +3715,7 @@ DO j=JstrV-1,Jend DO i=IstrU-1,Iend fac=cff*pm(i,j)*pn(i,j) -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ tl_rzetaSA(i,j)=tl_zwrk(i,j)*(rhoS(i,j)-rhoA(i,j))+ & !^ & zwrk(i,j)*(tl_rhoS(i,j)-tl_rhoA(i,j)) !^ @@ -3795,7 +3795,7 @@ DO j=JstrV-1,Jend DO i=IstrU-1,Iend fac=dtfast(ng)*pm(i,j)*pn(i,j) -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ tl_rzetaSA(i,j)=tl_zwrk(i,j)*(rhoS(i,j)-rhoA(i,j))+ & !^ & zwrk(i,j)*(tl_rhoS(i,j)-tl_rhoA(i,j)) !^ diff --git a/ROMS/Adjoint/ad_step3d_uv.F b/ROMS/Adjoint/ad_step3d_uv.F index 60e19689e..243d56969 100644 --- a/ROMS/Adjoint/ad_step3d_uv.F +++ b/ROMS/Adjoint/ad_step3d_uv.F @@ -126,8 +126,10 @@ SUBROUTINE ad_step3d_uv (ng, tile) # endif & OCEAN(ng) % ad_ubar, & & OCEAN(ng) % ad_vbar, & +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) & OCEAN(ng) % ad_ubar_sol, & & OCEAN(ng) % ad_vbar_sol, & +# endif # ifdef WEC_NOT_YET & OCEAN(ng) % ubar_stokes, & & OCEAN(ng) % tl_ubar_stokes, & @@ -182,7 +184,9 @@ SUBROUTINE ad_step3d_uv_tile (ng, tile, & & ad_u_sol, ad_v_sol, & # endif & ad_ubar, ad_vbar, & +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) & ad_ubar_sol, ad_vbar_sol, & +# endif # ifdef WEC_NOT_YET & ubar_stokes, ad_ubar_stokes, & & vbar_stokes, ad_vbar_stokes, & @@ -267,9 +271,10 @@ SUBROUTINE ad_step3d_uv_tile (ng, tile, & real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:) real(r8), intent(inout) :: ad_Huon(LBi:,LBj:,:) real(r8), intent(inout) :: ad_Hvom(LBi:,LBj:,:) - +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) real(r8), intent(out) :: ad_ubar_sol(LBi:,LBj:) real(r8), intent(out) :: ad_vbar_sol(LBi:,LBj:) +# endif # else @@ -330,18 +335,19 @@ SUBROUTINE ad_step3d_uv_tile (ng, tile, & real(r8), intent(inout) :: ad_v_sol(LBi:UBi,LBj:UBj,N(ng)) # endif # ifdef WEC_NOT_YET - real(r8), intent(in) :: ad_ubar_stokes(LBi:UBi,LBj:UBj) - real(r8), intent(in) :: ad_vbar_stokes(LBi:UBi,LBj:UBj) + real(r8), intent(inout) :: ad_ubar_stokes(LBi:UBi,LBj:UBj) + real(r8), intent(inout) :: ad_vbar_stokes(LBi:UBi,LBj:UBj) real(r8), intent(inout) :: ad_u_stokes(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(inout) :: ad_v_stokes(LBi:UBi,LBj:UBj,N(ng)) # endif - real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,3) - real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,3) + real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:) + real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:) real(r8), intent(inout) :: ad_Huon(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(inout) :: ad_Hvom(LBi:UBi,LBj:UBj,N(ng)) - +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) real(r8), intent(out) :: ad_ubar_sol(LBi:UBi,LBj:UBj) real(r8), intent(out) :: ad_vbar_sol(LBi:UBi,LBj:UBj) +# endif # endif ! ! Local variable declarations. @@ -432,6 +438,19 @@ SUBROUTINE ad_step3d_uv_tile (ng, tile, & !----------------------------------------------------------------------- ! # ifdef DISTRIBUTE +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +!^ CALL mp_exchange2d (ng, tile, iTLM, 2, & +!^ & LBi, UBi, LBj, UBj, & +!^ & NghostPoints, & +!^ & EWperiodic(ng), NSperiodic(ng), & +!^ & tl_ubar(:,:,knew), tl_vbar(:,:,knew)) +!^ + CALL ad_mp_exchange2d (ng, tile, iADM, 2, & + & LBi, UBi, LBj, UBj, & + & NghostPoints, & + & EWperiodic(ng), NSperiodic(ng), & + & ad_ubar(:,:,knew), ad_vbar(:,:,knew)) +# else !^ CALL mp_exchange2d (ng, tile, iTLM, 4, & !^ & LBi, UBi, LBj, UBj, & !^ & NghostPoints, & @@ -445,7 +464,7 @@ SUBROUTINE ad_step3d_uv_tile (ng, tile, & & EWperiodic(ng), NSperiodic(ng), & & ad_ubar(:,:,1), ad_vbar(:,:,1), & & ad_ubar(:,:,2), ad_vbar(:,:,2)) - +# endif !^ CALL mp_exchange3d (ng, tile, iTLM, 4, & !^ & LBi, UBi, LBj, UBj, 1, N(ng), & !^ & NghostPoints, & @@ -463,6 +482,22 @@ SUBROUTINE ad_step3d_uv_tile (ng, tile, & # endif IF (EWperiodic(ng).or.NSperiodic(ng)) THEN +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +!^ CALL exchange_v2d_tile (ng, tile, & +!^ & LBi, UBi, LBj, UBj, & +!^ & tl_vbar(:,:,knew)) +!^ + CALL ad_exchange_v2d_tile (ng, tile, & + & LBi, UBi, LBj, UBj, & + & ad_vbar(:,:,knew)) +!^ CALL exchange_u2d_tile (ng, tile, & +!^ & LBi, UBi, LBj, UBj, & +!^ & tl_ubar(:,:,knew)) +!^ + CALL ad_exchange_u2d_tile (ng, tile, & + & LBi, UBi, LBj, UBj, & + & ad_ubar(:,:,knew)) +# else DO k=1,2 !^ CALL exchange_v2d_tile (ng, tile, & !^ & LBi, UBi, LBj, UBj, & @@ -479,6 +514,7 @@ SUBROUTINE ad_step3d_uv_tile (ng, tile, & & LBi, UBi, LBj, UBj, & & ad_ubar(:,:,k)) END DO +# endif ! CALL exchange_v3d_tile (ng, tile, & & LBi, UBi, LBj, UBj, 1, N(ng), & @@ -846,13 +882,15 @@ SUBROUTINE ad_step3d_uv_tile (ng, tile, & !! END DO !! END DO # endif + +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) ! -! Save adjoint solution for time-step iic(ng)-1 as the sum of time -! records 1 and 2. +! Save adjoint solution for time-step iic(ng)-1 as for I/O purposes. ! DO i=IstrT,IendT ad_vbar_sol(i,j)=ad_vbar(i,j,1)+ad_vbar(i,j,2) END DO +# endif ! ! Compute adjoint thicknesses of V-boxes DC(i,1:N), total depth of the ! water column DC(i,0), and incorrect vertical mean CF(i,0). Notice @@ -867,16 +905,35 @@ SUBROUTINE ad_step3d_uv_tile (ng, tile, & !! DiaV2wrk(i,j,M2rate)=vbar(i,j,1)- & !! & DiaV2int(i,j,M2rate)*DC(i,0) # endif +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +# ifdef WET_DRY_NOT_YET +!^ vbar(i,j,knew)=vbar(i,j,knew)*vmask_wet(i,j) +!^ +!! tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask_wet(i,j) +# endif +!^ tl_vbar(i,j,knew)=tl_DC(i,0)*DV_avg1(i,j)+ & +!^ & DC(i,0)*tl_DV_avg1(i,j) +!^ + ad_DC(i,0)=ad_DC(i,0)+ad_vbar(i,j,knew)*DV_avg1(i,j) + ad_DV_avg1(i,j)=ad_DV_avg1(i,j)+ad_vbar(i,j,knew)*DC(i,0) + ad_vbar(i,j,knew)=0.0_r8 +# else !^ tl_vbar(i,j,2)=tl_vbar(i,j,1) !^ ad_vbar(i,j,1)=ad_vbar(i,j,1)+ad_vbar(i,j,2) ad_vbar(i,j,2)=0.0_r8 +# ifdef WET_DRY_NOT_YET +!^ vbar(i,j,1)=vbar(i,j,1)*vmask_wet(i,j) +!^ +!! tl_vbar(i,j,1)=tl_vbar(i,j,1)*vmask_wet(i,j) +# endif !^ tl_vbar(i,j,1)=tl_DC(i,0)*DV_avg1(i,j)+ & !^ & DC(i,0)*tl_DV_avg1(i,j) !^ ad_DC(i,0)=ad_DC(i,0)+ad_vbar(i,j,1)*DV_avg1(i,j) ad_DV_avg1(i,j)=ad_DV_avg1(i,j)+ad_vbar(i,j,1)*DC(i,0) ad_vbar(i,j,1)=0.0_r8 +# endif # ifdef WEC_NOT_YET !^ tl_CFs(i,0)=tl_DC(i,0)*(CFs1(i)-cff2)+ & !^ & DC(i,0)*(tl_CFs(i,0)-tl_cff2) @@ -1282,6 +1339,8 @@ SUBROUTINE ad_step3d_uv_tile (ng, tile, & !! END DO !! END DO # endif + +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) ! ! Save adjoint solution for time-step iic(ng)-1 as the sum of time ! records 1 and 2. @@ -1289,6 +1348,7 @@ SUBROUTINE ad_step3d_uv_tile (ng, tile, & DO i=IstrP,IendT ad_ubar_sol(i,j)=ad_ubar(i,j,1)+ad_ubar(i,j,2) END DO +# endif ! ! Compute thicknesses of U-boxes DC(i,1:N), total depth of the water ! column DC(i,0), and incorrect vertical mean CF(i,0). Notice that @@ -1300,16 +1360,35 @@ SUBROUTINE ad_step3d_uv_tile (ng, tile, & !! DiaU2int(i,j,M2rate)=ubar(i,j,1)*DC1(i,0) !! DiaU2wrk(i,j,M2rate)=ubar(i,j,1)-DiaU2int(i,j,M2rate)*DC(i,0) # endif +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +# ifdef WET_DRY_NOT_YET +!^ ubar(i,j,knew)=ubar(i,j,knew)*umask_wet(i,j) +!^ +!! tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask_wet(i,j) +# endif +!^ tl_ubar(i,j,knew)=tl_DC(i,0)*DU_avg1(i,j)+ & +!^ & DC(i,0)*tl_DU_avg1(i,j) +!^ + ad_DC(i,0)=ad_DC(i,0)+ad_ubar(i,j,knew)*DU_avg1(i,j) + ad_DU_avg1(i,j)=ad_DU_avg1(i,j)+ad_ubar(i,j,knew)*DC(i,0) + ad_ubar(i,j,knew)=0.0_r8 +# else !^ tl_ubar(i,j,2)=tl_ubar(i,j,1) !^ ad_ubar(i,j,1)=ad_ubar(i,j,1)+ad_ubar(i,j,2) ad_ubar(i,j,2)=0.0_r8 +# ifdef WET_DRY_NOT_YET +!^ ubar(i,j,1)=ubar(i,j,1)*umask_wet(i,j) +!^ +!! tl_ubar(i,j,1)=tl_ubar(i,j,1)*umask_wet(i,j) +# endif !^ tl_ubar(i,j,1)=tl_DC(i,0)*DU_avg1(i,j)+ & !^ & DC(i,0)*tl_DU_avg1(i,j) !^ ad_DC(i,0)=ad_DC(i,0)+ad_ubar(i,j,1)*DU_avg1(i,j) ad_DU_avg1(i,j)=ad_DU_avg1(i,j)+ad_ubar(i,j,1)*DC(i,0) ad_ubar(i,j,1)=0.0_r8 +# endif # ifdef WEC_NOT_YET !^ tl_CFs(i,0)=tl_DC(i,0)*(CFs1(i)-cff2)+ & !^ & DC(i,0)*(tl_CFs(i,0)-tl_cff2) diff --git a/ROMS/Adjoint/ad_zetabc.F b/ROMS/Adjoint/ad_zetabc.F index b1352abaa..5c4982e7a 100644 --- a/ROMS/Adjoint/ad_zetabc.F +++ b/ROMS/Adjoint/ad_zetabc.F @@ -15,21 +15,29 @@ MODULE ad_zetabc_mod ! BASIC STATE variables needed: zeta ! ! ! !======================================================================= +! + USE mod_param + USE mod_boundary + USE mod_grid + USE mod_ncparam + USE mod_ocean + USE mod_scalars + USE mod_stepping ! implicit none - +! PRIVATE - PUBLIC :: ad_zetabc, ad_zetabc_tile - + PUBLIC :: ad_zetabc +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + PUBLIC :: ad_zetabc_local +# endif + PUBLIC :: ad_zetabc_tile +! CONTAINS ! !*********************************************************************** SUBROUTINE ad_zetabc (ng, tile, kout) !*********************************************************************** -! - USE mod_param - USE mod_ocean - USE mod_stepping ! ! Imported variable declarations. ! @@ -45,6 +53,7 @@ SUBROUTINE ad_zetabc (ng, tile, kout) & krhs(ng), kstp(ng), kout, & & OCEAN(ng) % zeta, & & OCEAN(ng) % ad_zeta) +! RETURN END SUBROUTINE ad_zetabc ! @@ -55,12 +64,6 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & & krhs, kstp, kout, & & zeta, ad_zeta) !*********************************************************************** -! - USE mod_param - USE mod_boundary - USE mod_grid - USE mod_ncparam - USE mod_scalars ! ! Imported variable declarations. ! @@ -74,9 +77,9 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:) # else - real(r8), intent(in) :: zeta(LBi:UBi,LBj:UBj,3) + real(r8), intent(in) :: zeta(LBi:UBi,LBj:UBj,:) - real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,3) + real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:) # endif ! ! Local variable declarations. @@ -109,6 +112,10 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & ! Set time-indices !----------------------------------------------------------------------- ! +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + know=kstp + dt2d=dtfast(ng) +# else IF (FIRST_2D_STEP) THEN know=krhs dt2d=dtfast(ng) @@ -119,7 +126,7 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & know=kstp dt2d=dtfast(ng) END IF - +# endif # if defined WET_DRY ! !----------------------------------------------------------------------- @@ -127,7 +134,7 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & !----------------------------------------------------------------------- ! cff=Dcrit(ng)-eps - +! IF (.not.(EWperiodic(ng).or.NSperiodic(ng))) THEN IF (DOMAIN(ng)%NorthEast_Corner(tile)) THEN IF (LBC_apply(ng)%north(Iend+1).and. & @@ -182,7 +189,7 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & END IF END IF END IF - +! IF (.not.NSperiodic(ng)) THEN IF (DOMAIN(ng)%Northern_Edge(tile)) THEN DO i=Istr,Iend @@ -213,7 +220,7 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & END DO END IF END IF - +! IF (.not.EWperiodic(ng)) THEN IF (DOMAIN(ng)%Eastern_Edge(tile)) THEN DO j=Jstr,Jend @@ -320,11 +327,20 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & IF (DOMAIN(ng)%Northern_Edge(tile)) THEN ! ! Northern edge, implicit upstream radiation condition. +! (Not implemented since the ADM requires nonlinear celerity at every +! timestep. Using gradient instead). ! IF (ad_LBC(inorth,isFsur,ng)%radiation) THEN IF (iic(ng).ne.0) THEN DO i=Istr,Iend IF (LBC_apply(ng)%north(i)) THEN +# ifdef MASKING +!^ tl_zeta(i,Jend+1,kout)=tl_zeta(i,Jend+1,kout)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + ad_zeta(i,Jend+1,kout)=ad_zeta(i,Jend+1,kout)* & + & GRID(ng)%rmask(i,Jend+1) +# endif # if defined CELERITY_READ && defined FORWARD_READ IF (ad_LBC(inorth,isFsur,ng)%nudging) THEN IF (BOUNDARY(ng)%zeta_north_Ce(i).eq.0.0_r8) THEN @@ -341,14 +357,7 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & # endif Ce=BOUNDARY(ng)%zeta_north_Ce(i) cff=BOUNDARY(ng)%zeta_north_C2(i) -# endif -# ifdef MASKING -!^ tl_zeta(i,Jend+1,kout)=tl_zeta(i,Jend+1,kout)* & -!^ & GRID(ng)%rmask(i,Jend+1) -!^ - ad_zeta(i,Jend+1,kout)=ad_zeta(i,Jend+1,kout)* & - & GRID(ng)%rmask(i,Jend+1) -# endif +! IF (ad_LBC(inorth,isFsur,ng)%nudging) THEN !^ tl_zeta(i,Jend+1,kout)=tl_zeta(i,Jend+1,kout)- & !^ & tau*tl_zeta(i,Jend+1,know) @@ -372,6 +381,13 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & ad_zeta(i,Jend ,kout)=ad_zeta(i,Jend ,kout)+Ce *adfac ad_zeta(i,Jend+1,know)=ad_zeta(i,Jend+1,know)+cff*adfac ad_zeta(i,Jend+1,kout)=0.0_r8 +# else +!^ tl_zeta(i,Jend+1,kout)=tl_zeta(i,Jend,kout) +!^ gradient + ad_zeta(i,Jend ,kout)=ad_zeta(i,Jend ,kout)+ & + & ad_zeta(i,Jend+1,kout) + ad_zeta(i,Jend+1,kout)=0.0_r8 +# endif END IF END DO END IF @@ -549,11 +565,20 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & IF (DOMAIN(ng)%Southern_Edge(tile)) THEN ! ! Southern edge, implicit upstream radiation condition. +! (Not implemented since the ADM requires nonlinear celerity at every +! timestep. Using gradient instead). ! IF (ad_LBC(isouth,isFsur,ng)%radiation) THEN IF (iic(ng).ne.0) THEN DO i=Istr,Iend IF (LBC_apply(ng)%south(i)) THEN +# ifdef MASKING +!^ tl_zeta(i,Jstr-1,kout)=tl_zeta(i,Jstr-1,kout)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + ad_zeta(i,Jstr-1,kout)=ad_zeta(i,Jstr-1,kout)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif # if defined CELERITY_READ && defined FORWARD_READ IF (ad_LBC(isouth,isFsur,ng)%nudging) THEN IF (BOUNDARY(ng)%zeta_south_Ce(i).eq.0.0_r8) THEN @@ -570,14 +595,7 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & # endif Ce=BOUNDARY(ng)%zeta_south_Ce(i) cff=BOUNDARY(ng)%zeta_south_C2(i) -# endif -# ifdef MASKING -!^ tl_zeta(i,Jstr-1,kout)=tl_zeta(i,Jstr-1,kout)* & -!^ & GRID(ng)%rmask(i,Jstr-1) -!^ - ad_zeta(i,Jstr-1,kout)=ad_zeta(i,Jstr-1,kout)* & - & GRID(ng)%rmask(i,Jstr-1) -# endif +! IF (ad_LBC(isouth,isFsur,ng)%nudging) THEN !^ tl_zeta(i,Jstr-1,kout)=tl_zeta(i,Jstr-1,kout)- & !^ & tau*tl_zeta(i,Jstr-1,know) @@ -601,6 +619,13 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & ad_zeta(i,Jstr-1,know)=ad_zeta(i,Jstr-1,know)+cff*adfac ad_zeta(i,Jstr ,kout)=ad_zeta(i,Jstr ,kout)+Ce *adfac ad_zeta(i,Jstr-1,kout)=0.0_r8 +# else +!^ tl_zeta(i,Jstr-1,kout)=tl_zeta(i,Jstr,kout) +!^ gradient + ad_zeta(i,Jstr ,kout)=ad_zeta(i,Jstr ,kout)+ & + & ad_zeta(i,Jstr-1,kout) + ad_zeta(i,Jstr-1,kout)=0.0_r8 +# endif END IF END DO END IF @@ -778,11 +803,20 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & IF (DOMAIN(ng)%Eastern_Edge(tile)) THEN ! ! Eastern edge, implicit upstream radiation condition. +! (Not implemented since the ADM requires nonlinear celerity at every +! timestep. Using gradient instead). ! IF (ad_LBC(ieast,isFsur,ng)%radiation) THEN IF (iic(ng).ne.0) THEN DO j=Jstr,Jend IF (LBC_apply(ng)%east(j)) THEN +# ifdef MASKING +!^ tl_zeta(Iend+1,j,kout)=tl_zeta(Iend+1,j,kout)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + ad_zeta(Iend+1,j,kout)=ad_zeta(Iend+1,j,kout)* & + & GRID(ng)%rmask(Iend+1,j) +# endif # if defined CELERITY_READ && defined FORWARD_READ IF (ad_LBC(ieast,isFsur,ng)%nudging) THEN IF (BOUNDARY(ng)%zeta_east_Cx(j).eq.0.0_r8) THEN @@ -799,14 +833,7 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & Ce=0.0_r8 # endif cff=BOUNDARY(ng)%zeta_east_C2(j) -# endif -# ifdef MASKING -!^ tl_zeta(Iend+1,j,kout)=tl_zeta(Iend+1,j,kout)* & -!^ & GRID(ng)%rmask(Iend+1,j) -!^ - ad_zeta(Iend+1,j,kout)=ad_zeta(Iend+1,j,kout)* & - & GRID(ng)%rmask(Iend+1,j) -# endif +! IF (ad_LBC(ieast,isFsur,ng)%nudging) THEN !^ tl_zeta(Iend+1,j,kout)=tl_zeta(Iend+1,j,kout)- & !^ & tau*tl_zeta(Iend+1,j,know) @@ -830,6 +857,13 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & ad_zeta(Iend ,j,kout)=ad_zeta(Iend ,j,kout)+Cx *adfac ad_zeta(Iend+1,j,know)=ad_zeta(Iend+1,j,know)+cff*adfac ad_zeta(Iend+1,j,kout)=0.0_r8 +# else +!^ tl_zeta(Iend+1,j,kout)=tl_zeta(Iend,j,kout) +!^ gradient + ad_zeta(Iend ,j,kout)=ad_zeta(Iend ,j,kout)+ & + & ad_zeta(Iend+1,j,kout) + ad_zeta(Iend+1,j,kout)=0.0_r8 +# endif END IF END DO END IF @@ -1007,11 +1041,20 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & IF (DOMAIN(ng)%Western_Edge(tile)) THEN ! ! Western edge, implicit upstream radiation condition. +! (Not implemented since the ADM requires nonlinear celerity at every +! timestep. Using gradient instead). ! IF (ad_LBC(iwest,isFsur,ng)%radiation) THEN IF (iic(ng).ne.0) THEN DO j=Jstr,Jend IF (LBC_apply(ng)%west(j)) THEN +# ifdef MASKING +!^ tl_zeta(Istr-1,j,kout)=tl_zeta(Istr-1,j,kout)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + ad_zeta(Istr-1,j,kout)=ad_zeta(Istr-1,j,kout)* & + & GRID(ng)%rmask(Istr-1,j) +# endif # if defined CELERITY_READ && defined FORWARD_READ IF (ad_LBC(iwest,isFsur,ng)%nudging) THEN IF (BOUNDARY(ng)%zeta_west_Cx(j).eq.0.0_r8) THEN @@ -1028,14 +1071,7 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & Ce=0.0_r8 # endif cff=BOUNDARY(ng)%zeta_west_C2(j) -# endif -# ifdef MASKING -!^ tl_zeta(Istr-1,j,kout)=tl_zeta(Istr-1,j,kout)* & -!^ & GRID(ng)%rmask(Istr-1,j) -!^ - ad_zeta(Istr-1,j,kout)=ad_zeta(Istr-1,j,kout)* & - & GRID(ng)%rmask(Istr-1,j) -# endif +! IF (ad_LBC(iwest,isFsur,ng)%nudging) THEN !^ tl_zeta(Istr-1,j,kout)=tl_zeta(Istr-1,j,kout)- & !^ & tau*tl_zeta(Istr-1,j,know) @@ -1060,6 +1096,13 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & ad_zeta(Istr-1,j,know)=ad_zeta(Istr-1,j,know)+cff*adfac ad_zeta(Istr ,j,kout)=ad_zeta(Istr ,j,kout)+Cx *adfac ad_zeta(Istr-1,j,kout)=0.0_r8 +# else +!^ tl_zeta(Istr-1,j,kout)=tl_zeta(Istr,j,kout) +!^ gradient + ad_zeta(Istr ,j,kout)=ad_zeta(Istr ,j,kout)+ & + & ad_zeta(Istr-1,j,kout) + ad_zeta(Istr-1,j,kout)=0.0_r8 +# endif END IF END DO END IF @@ -1229,8 +1272,1223 @@ SUBROUTINE ad_zetabc_tile (ng, tile, & END DO END IF END IF - +! RETURN END SUBROUTINE ad_zetabc_tile + +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +! +!*********************************************************************** + SUBROUTINE ad_zetabc_local (ng, tile, & + & LBi, UBi, LBj, UBj, & + & IminS, ImaxS, JminS, JmaxS, & + & kstp, & + & zeta, ad_zeta, & + & zeta_new, ad_zeta_new) +!*********************************************************************** +! +! Imported variable declarations. +! + integer, intent(in) :: ng, tile + integer, intent(in) :: LBi, UBi, LBj, UBj + integer, intent(in) :: IminS, ImaxS, JminS, JmaxS + integer, intent(in) :: kstp +! +# ifdef ASSUMED_SHAPE + real(r8), intent(in) :: zeta(LBi:,LBj:,:) + real(r8), intent(in) :: zeta_new(IminS:,JminS:) + + real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:) + real(r8), intent(inout) :: ad_zeta_new(IminS:,JminS:) +# else + real(r8), intent(in) :: zeta(LBi:UBi,LBj:UBj,:) + real(r8), intent(in) :: zeta_new(IminS:ImaxS,JminS:JmaxS) + + real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:) + real(r8), intent(inout) :: ad_zeta_new(IminS:ImaxS,JminS:JmaxS) +# endif +! +! Local variable declarations. +! + integer :: i, j, know + + real(r8) :: Ce, Cx + real(r8) :: cff, cff1, cff2, dt2d, tau + + real(r8) :: ad_Ce, ad_Cx + real(r8) :: ad_cff1, ad_cff2 + real(r8) :: adfac + + real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_grad + +# include "set_bounds.h" +! +!----------------------------------------------------------------------- +! Set time-indices +!----------------------------------------------------------------------- +! + know=kstp + dt2d=dtfast(ng) +! +!----------------------------------------------------------------------- +! Initialize adjoint private variables. +!----------------------------------------------------------------------- +! + ad_Ce=0.0_r8 + ad_Cx=0.0_r8 + ad_cff1=0.0_r8 + ad_cff2=0.0_r8 + + ad_grad(LBi:UBi,LBj:UBj)=0.0_r8 + +# if defined WET_DRY +! +!----------------------------------------------------------------------- +! Ensure that water level on boundary cells is above bed elevation. +!----------------------------------------------------------------------- +! + cff=Dcrit(ng)-eps +! + IF (.not.(EWperiodic(ng).or.NSperiodic(ng))) THEN + IF (DOMAIN(ng)%NorthEast_Corner(tile)) THEN + IF (LBC_apply(ng)%north(Iend+1).and. & + & LBC_apply(ng)%east (Jend+1)) THEN + IF (zeta_new(Iend+1,Jend+1).le. & + & (Dcrit(ng)-GRID(ng)%h(Iend+1,Jend+1))) THEN +!^ tl_zeta_new(Iend+1,Jend+1)=-GRID(ng)%tl_h(Iend+1,Jend+1) +!^ + GRID(ng)%ad_h(Iend+1,Jend+1)=GRID(ng)%ad_h(Iend+1,Jend+1)-& + & ad_zeta_new(Iend+1,Jend+1) + ad_zeta_new(Iend+1,Jend+1)=0.0_r8 + END IF + END IF + END IF + IF (DOMAIN(ng)%NorthWest_Corner(tile)) THEN + IF (LBC_apply(ng)%north(Istr-1).and. & + & LBC_apply(ng)%west (Jend+1)) THEN + IF (zeta_new(Istr-1,Jend+1).le. & + & (Dcrit(ng)-GRID(ng)%h(Istr-1,Jend+1))) THEN +!^ tl_zeta_new(Istr-1,Jend+1)=-GRID(ng)%tl_h(Istr-1,Jend+1) +!^ + GRID(ng)%ad_h(Istr-1,Jend+1)=GRID(ng)%ad_h(Istr-1,Jend+1)-& + & ad_zeta_new(Istr-1,Jend+1) + ad_zeta_new(Istr-1,Jend+1)=0.0_r8 + END IF + END IF + END IF + IF (DOMAIN(ng)%SouthEast_Corner(tile)) THEN + IF (LBC_apply(ng)%south(Iend+1).and. & + & LBC_apply(ng)%east (Jstr-1)) THEN + IF (zeta_new(Iend+1,Jstr-1).le. & + & (Dcrit(ng)-GRID(ng)%h(Iend+1,Jstr-1))) THEN +!^ tl_zeta_new(Iend+1,Jstr-1)=-GRID(ng)%tl_h(Iend+1,Jstr-1) +!^ + GRID(ng)%ad_h(Iend+1,Jstr-1)=GRID(ng)%ad_h(Iend+1,Jstr-1)-& + & ad_zeta_new(Iend+1,Jstr-1) + ad_zeta_new(Iend+1,Jstr-1)=0.0_r8 + END IF + END IF + END IF + IF (DOMAIN(ng)%SouthWest_Corner(tile)) THEN + IF (LBC_apply(ng)%south(Istr-1).and. & + & LBC_apply(ng)%west (Jstr-1)) THEN + IF (zeta_new(Istr-1,Jstr-1).le. & + & (Dcrit(ng)-GRID(ng)%h(Istr-1,Jstr-1))) THEN +!^ tl_zeta_new(Istr-1,Jstr-1)=-GRID(ng)%tl_h(Istr-1,Jstr-1) +!^ + GRID(ng)%ad_h(Istr-1,Jstr-1)=GRID(ng)%ad_h(Istr-1,Jstr-1)-& + & ad_zeta_new(Istr-1,Jstr-1) + ad_zeta_new(Istr-1,Jstr-1)=0.0_r8 + END IF + END IF + END IF + END IF +! + IF (.not.NSperiodic(ng)) THEN + IF (DOMAIN(ng)%Northern_Edge(tile)) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN + IF (zeta_new(i,Jend+1).le. & + & (Dcrit(ng)-GRID(ng)%h(i,Jend+1))) THEN +!^ tl_zeta_new(i,Jend+1)=-GRID(ng)%tl_h(i,Jend+1) +!^ + GRID(ng)%ad_h(i,Jend+1)=GRID(ng)%ad_h(i,Jend+1)- & + & ad_zeta_new(i,Jend+1) + ad_zeta_new(i,Jend+1)=0.0_r8 + END IF + END IF + END DO + END IF + IF (DOMAIN(ng)%Southern_Edge(tile)) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN + IF (zeta_new(i,Jstr-1).le. & + & (Dcrit(ng)-GRID(ng)%h(i,Jstr-1))) THEN +!^ tl_zeta_new(i,Jstr-1)=-GRID(ng)%tl_h(i,Jstr-1) +!^ + GRID(ng)%ad_h(i,Jstr-1)=GRID(ng)%ad_h(i,Jstr-1)- & + & ad_zeta_new(i,Jstr-1) + ad_zeta_new(i,Jstr-1)=0.0_r8 + END IF + END IF + END DO + END IF + END IF +! + IF (.not.EWperiodic(ng)) THEN + IF (DOMAIN(ng)%Eastern_Edge(tile)) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN + IF (zeta_new(Iend+1,j).le. & + & (Dcrit(ng)-GRID(ng)%h(Iend+1,j))) THEN +!^ tl_zeta_new(Iend+1,j)=-GRID(ng)%tl_h(Iend+1,j) +!^ + GRID(ng)%ad_h(Iend+1,j)=GRID(ng)%ad_h(Iend+1,j)- & + & ad_zeta_new(Iend+1,j) + ad_zeta_new(Iend+1,j)=0.0_r8 + END IF + END IF + END DO + END IF + IF (DOMAIN(ng)%Western_Edge(tile)) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN + IF (zeta_new(Istr-1,j).le. & + & (Dcrit(ng)-GRID(ng)%h(Istr-1,j))) THEN +!^ tl_zeta_new(Istr-1,j)=-GRID(ng)%tl_h(Istr-1,j) +!^ + GRID(ng)%ad_h(Istr-1,j)=GRID(ng)%ad_h(Istr-1,j)- & + & ad_zeta_new(Istr-1,j) + ad_zeta_new(Istr-1,j)=0.0_r8 + END IF + END IF + END DO + END IF + END IF +# endif +! +!----------------------------------------------------------------------- +! Boundary corners. +!----------------------------------------------------------------------- +! + IF (.not.(EWperiodic(ng).or.NSperiodic(ng))) THEN + IF (DOMAIN(ng)%NorthEast_Corner(tile)) THEN + IF (LBC_apply(ng)%north(Iend+1).and. & + & LBC_apply(ng)%east (Jend+1)) THEN +!^ tl_zeta_new(Iend+1,Jend+1)=0.5_r8* & +!^ & (tl_zeta_new(Iend+1,Jend )+ & +!^ & tl_zeta_new(Iend ,Jend+1)) +!^ + adfac=0.5_r8*ad_zeta_new(Iend+1,Jend+1) + ad_zeta_new(Iend ,Jend+1)=ad_zeta_new(Iend ,Jend+1)+ & + & adfac + ad_zeta_new(Iend+1,Jend )=ad_zeta_new(Iend+1,Jend )+ & + & adfac + ad_zeta_new(Iend+1,Jend+1)=0.0_r8 + END IF + END IF + IF (DOMAIN(ng)%NorthWest_Corner(tile)) THEN + IF (LBC_apply(ng)%north(Istr-1).and. & + & LBC_apply(ng)%west (Jend+1)) THEN +!^ tl_zeta_new(Istr-1,Jend+1)=0.5_r8* & +!^ & (tl_zeta_new(Istr-1,Jend )+ & +!^ & tl_zeta_new(Istr ,Jend+1)) +!^ + adfac=0.5_r8*ad_zeta_new(Istr-1,Jend+1) + ad_zeta_new(Istr-1,Jend )=ad_zeta_new(Istr-1,Jend )+ & + & adfac + ad_zeta_new(Istr ,Jend+1)=ad_zeta_new(Istr ,Jend+1)+ & + & adfac + ad_zeta_new(Istr-1,Jend+1)=0.0_r8 + END IF + END IF + IF (DOMAIN(ng)%SouthEast_Corner(tile)) THEN + IF (LBC_apply(ng)%south(Iend+1).and. & + & LBC_apply(ng)%east (Jstr-1)) THEN +!^ tl_zeta_new(Iend+1,Jstr-1)=0.5_r8* & +!^ & (tl_zeta_new(Iend ,Jstr-1)+ & +!^ & tl_zeta_new(Iend+1,Jstr )) +!^ + adfac=0.5_r8*ad_zeta_new(Iend+1,Jstr-1) + ad_zeta_new(Iend ,Jstr-1)=ad_zeta_new(Iend ,Jstr-1)+ & + & adfac + ad_zeta_new(Iend+1,Jstr )=ad_zeta_new(Iend+1,Jstr )+ & + & adfac + ad_zeta_new(Iend+1,Jstr-1)=0.0_r8 + END IF + END IF + IF (DOMAIN(ng)%SouthWest_Corner(tile)) THEN + IF (LBC_apply(ng)%south(Istr-1).and. & + & LBC_apply(ng)%west (Jstr-1)) THEN +!^ tl_zeta_new(Istr-1,Jstr-1)=0.5_r8* & +!^ & (tl_zeta_new(Istr ,Jstr-1)+ & +!^ & tl_zeta_new(Istr-1,Jstr )) +!^ + adfac=0.5_r8*ad_zeta_new(Istr-1,Jstr-1) + ad_zeta_new(Istr ,Jstr-1)=ad_zeta_new(Istr ,Jstr-1)+ & + & adfac + ad_zeta_new(Istr-1,Jstr )=ad_zeta_new(Istr-1,Jstr )+ & + & adfac + ad_zeta_new(Istr-1,Jstr-1)=0.0_r8 + END IF + END IF + END IF +! +!----------------------------------------------------------------------- +! Lateral boundary conditions at the northern edge. +!----------------------------------------------------------------------- +! + IF (DOMAIN(ng)%Northern_Edge(tile)) THEN +! +! Northern edge, implicit upstream radiation condition. +! (Not implemented since the ADM requires nonlinear celerity at every +! timestep. Using gradient instead). +! + IF (ad_LBC(inorth,isFsur,ng)%radiation) THEN + IF (iic(ng).ne.0) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN +# ifdef MASKING +!^ tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + ad_zeta_new(i,Jend+1)=ad_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif +# if defined CELERITY_READ && defined FORWARD_READ + IF (ad_LBC(inorth,isFsur,ng)%nudging) THEN + IF (BOUNDARY(ng)%zeta_north_Ce(i).eq.0.0_r8) THEN + tau=FSobc_in(ng,inorth) + ELSE + tau=FSobc_out(ng,inorth) + END IF + tau=tau*dt2d + END IF +# ifdef RADIATION_2D + Cx=BOUNDARY(ng)%zeta_north_Cx(i) +# else + Cx=0.0_r8 +# endif + Ce=BOUNDARY(ng)%zeta_north_Ce(i) + cff=BOUNDARY(ng)%zeta_north_C2(i) +! + IF (ad_LBC(inorth,isFsur,ng)%nudging) THEN +!^ tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)- & +!^ & tau*tl_zeta(i,Jend+1,know) +!^ + ad_zeta(i,Jend+1,know)=ad_zeta(i,Jend+1,know)- & + & tau*ad_zeta_new(i,Jend+1) + END IF +!^ tl_zeta_new(i,Jend+1)=(cff*tl_zeta(i,Jend+1,know)+ & +!^ & Ce *tl_zeta_new(i,Jend)- & +!^ & MAX(Cx,0.0_r8)* & +!^ & tl_grad(i ,Jend+1)- & +!^ & MIN(Cx,0.0_r8)* & +!^ & tl_grad(i+1,Jend+1))/ & +!^ & (cff+Ce) +!^ + adfac=ad_zeta_new(i,Jend+1)/(cff+Ce) + ad_grad(i ,Jend+1)=ad_grad(i ,Jend+1)- & + & MAX(Cx,0.0_r8)*adfac + ad_grad(i+1,Jend+1)=ad_grad(i+1,Jend+1)- & + & MIN(Cx,0.0_r8)*adfac + ad_zeta_new(i,Jend)=ad_zeta_new(i,Jend)+Ce*adfac + ad_zeta(i,Jend+1,know)=ad_zeta(i,Jend+1,know)+cff*adfac + ad_zeta_new(i,Jend+1)=0.0_r8 +# else +!^ tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend) +!^ gradient + ad_zeta_new(i,Jend )=ad_zeta_new(i,Jend )+ & + & ad_zeta_new(i,Jend+1) + ad_zeta_new(i,Jend+1)=0.0_r8 +# endif + END IF + END DO + END IF +! +! Northern edge, explicit Chapman boundary condition. +! + ELSE IF (ad_LBC(inorth,isFsur,ng)%Chapman_explicit) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN + cff=dt2d*GRID(ng)%pn(i,Jend) + cff1=SQRT(g*(GRID(ng)%h(i,Jend)+ & + & zeta(i,Jend,know))) + Ce=cff*cff1 +# ifdef MASKING +!^ tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + ad_zeta_new(i,Jend+1)=ad_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif +!^ tl_zeta_new(i,Jend+1)=(1.0_r8-Ce)*tl_zeta(i,Jend+1,know)+ & +!^ & tl_Ce*(zeta(i,Jend+1,know)+ & +!^ & zeta(i,Jend ,know))+ & +!^ & Ce*tl_zeta(i,Jend,know) +!^ + ad_zeta(i,Jend+1,know)=ad_zeta(i,Jend+1,know)+ & + & (1.0_r8-Ce)*ad_zeta_new(i,Jend+1) + ad_Ce=ad_Ce+(zeta(i,Jend+1,know)+ & + & zeta(i,Jend ,know))*ad_zeta_new(i,Jend+1) + ad_zeta(i,Jend,know)=ad_zeta(i,Jend,know)+ & + & Ce*ad_zeta_new(i,Jend+1) + ad_zeta_new(i,Jend+1)=0.0_r8 +!^ tl_Ce=cff*tl_cff1 +!^ + ad_cff1=ad_cff1+cff*ad_Ce + ad_Ce=0.0_r8 +!^ tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(i,Jend)+ & +!^ & tl_zeta(i,Jend,know))/cff1 +!^ + adfac=0.5_r8*g*ad_cff1/cff1 + GRID(ng)%ad_h(i,Jend)=GRID(ng)%ad_h(i,Jend)+adfac + ad_zeta(i,Jend,know)=ad_zeta(i,Jend,know)+adfac + ad_cff1=0.0_r8 + END IF + END DO +! +! Northern edge, implicit Chapman boundary condition. +! + ELSE IF (ad_LBC(inorth,isFsur,ng)%Chapman_implicit) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN + cff=dt2d*GRID(ng)%pn(i,Jend) + cff1=SQRT(g*(GRID(ng)%h(i,Jend)+ & + & zeta(i,Jend,know))) + Ce=cff*cff1 + cff2=1.0_r8/(1.0_r8+Ce) +# ifdef MASKING +!^ tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + ad_zeta_new(i,Jend+1)=ad_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif +!^ tl_zeta_new(i,Jend+1)=tl_cff2*(zeta(i,Jend+1,know)+ & +!^ & Ce*zeta_new(i,Jend))+ & +!^ & cff2*(tl_zeta(i,Jend+1,know)+ & +!^ & tl_Ce*zeta_new(i,Jend)+ & +!^ & Ce*tl_zeta_new(i,Jend)) +!^ + adfac=cff2*ad_zeta_new(i,Jend+1) + ad_zeta_new(i,Jend)=ad_zeta_new(i,Jend)+Ce*adfac + ad_zeta(i,Jend+1,know)=ad_zeta(i,Jend+1,know)+adfac + ad_Ce=ad_Ce+zeta_new(i,Jend)*adfac + ad_cff2=ad_cff2+ & + & (zeta(i,Jend+1,know)+ & + & Ce*zeta_new(i,Jend))*ad_zeta_new(i,Jend+1) + ad_zeta_new(i,Jend+1)=0.0_r8 +!^ tl_cff2=-cff2*cff2*tl_Ce +!^ + ad_Ce=ad_Ce-cff2*cff2*ad_cff2 + ad_cff2=0.0_r8 +!^ tl_Ce=cff*tl_cff1 +!^ + ad_cff1=ad_cff1+cff*ad_Ce + ad_Ce=0.0_r8 +!^ tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(i,Jend)+ & +!^ & tl_zeta(i,Jend,know))/cff1 +!^ + adfac=0.5_r8*g*ad_cff1/cff1 + GRID(ng)%ad_h(i,Jend)=GRID(ng)%ad_h(i,Jend)+adfac + ad_zeta(i,Jend,know)=ad_zeta(i,Jend,know)+adfac + ad_cff1=0.0_r8 + END IF + END DO +! +! Northern edge, clamped boundary condition. +! + ELSE IF (ad_LBC(inorth,isFsur,ng)%clamped) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN +# ifdef MASKING +!^ tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + ad_zeta_new(i,Jend+1)=ad_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif +# ifdef ADJUST_BOUNDARY + IF (Lobc(inorth,isFsur,ng)) THEN +!^ tl_zeta_new(i,Jend+1)=BOUNDARY(ng)%tl_zeta_north(i) +!^ + BOUNDARY(ng)%ad_zeta_north(i)=BOUNDARY(ng)% & + & ad_zeta_north(i)+ & + & ad_zeta_new(i,Jend+1) + ad_zeta_new(i,Jend+1)=0.0_r8 + ELSE +!^ tl_zeta_new(i,Jend+1)=0.0_r8 +!^ + ad_zeta_new(i,Jend+1)=0.0_r8 + END IF +# else +!^ tl_zeta_new(i,Jend+1)=0.0_r8 +!^ + ad_zeta_new(i,Jend+1)=0.0_r8 +# endif + END IF + END DO +! +! Northern edge, gradient boundary condition. +! + ELSE IF (ad_LBC(inorth,isFsur,ng)%gradient) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN +# ifdef MASKING +!^ tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + ad_zeta_new(i,Jend+1)=ad_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif +!^ tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend) +!^ + ad_zeta_new(i,Jend )=ad_zeta_new(i,Jend )+ & + & ad_zeta_new(i,Jend+1) + ad_zeta_new(i,Jend+1)=0.0_r8 + END IF + END DO +! +! Northern edge, closed boundary condition. +! + ELSE IF (ad_LBC(inorth,isFsur,ng)%closed) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN +# ifdef MASKING +!^ tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + ad_zeta_new(i,Jend+1)=ad_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif +!^ tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend) +!^ + ad_zeta_new(i,Jend )=ad_zeta_new(i,Jend )+ & + & ad_zeta_new(i,Jend+1) + ad_zeta_new(i,Jend+1)=0.0_r8 + END IF + END DO + END IF + END IF +! +!----------------------------------------------------------------------- +! Lateral boundary conditions at the southern edge. +!----------------------------------------------------------------------- +! + IF (DOMAIN(ng)%Southern_Edge(tile)) THEN +! +! Southern edge, implicit upstream radiation condition. +! (Not implemented since the ADM requires nonlinear celerity at every +! timestep. Using gradient instead). +! + IF (ad_LBC(isouth,isFsur,ng)%radiation) THEN + IF (iic(ng).ne.0) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN +# ifdef MASKING +!^ tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + ad_zeta_new(i,Jstr-1)=ad_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif +# if defined CELERITY_READ && defined FORWARD_READ + IF (ad_LBC(isouth,isFsur,ng)%nudging) THEN + IF (BOUNDARY(ng)%zeta_south_Ce(i).eq.0.0_r8) THEN + tau=FSobc_in(ng,isouth) + ELSE + tau=FSobc_out(ng,isouth) + END IF + tau=tau*dt2d + END IF +# ifdef RADIATION_2D + Cx=BOUNDARY(ng)%zeta_south_Cx(i) +# else + Cx=0.0_r8 +# endif + Ce=BOUNDARY(ng)%zeta_south_Ce(i) + cff=BOUNDARY(ng)%zeta_south_C2(i) +! + IF (ad_LBC(isouth,isFsur,ng)%nudging) THEN +!^ tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)- & +!^ & tau*tl_zeta(i,Jstr-1,know) +!^ + ad_zeta(i,Jstr-1,know)=ad_zeta(i,Jstr-1,know)- & + & tau*ad_zeta_new(i,Jstr-1) + END IF +!^ tl_zeta_new(i,Jstr-1)=(cff*tl_zeta(i,Jstr-1,know)+ & +!^ & Ce *tl_zeta_new(i,Jstr)- & +!^ & MAX(Cx,0.0_r8)* & +!^ & tl_grad(i ,Jstr-1)- & +!^ & MIN(Cx,0.0_r8)* & +!^ & tl_grad(i+1,Jstr-1))/ & +!^ & (cff+Ce) +!^ + adfac=ad_zeta_new(i,Jstr-1)/(cff+Ce) + ad_grad(i ,Jstr-1)=ad_grad(i ,Jstr-1)- & + & MAX(Cx,0.0_r8)*adfac + ad_grad(i+1,Jstr-1)=ad_grad(i+1,Jstr-1)- & + & MIN(Cx,0.0_r8)*adfac + ad_zeta(i,Jstr-1,know)=ad_zeta(i,Jstr-1,know)+cff*adfac + ad_zeta_new(i,Jstr )=ad_zeta_new(i,Jstr )+Ce*adfac + ad_zeta_new(i,Jstr-1)=0.0_r8 +# else +!^ tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr) +!^ gradient + ad_zeta_new(i,Jstr )=ad_zeta_new(i,Jstr )+ & + & ad_zeta_new(i,Jstr-1) + ad_zeta_new(i,Jstr-1)=0.0_r8 +# endif + END IF + END DO + END IF +! +! Southern edge, explicit Chapman boundary condition. +! + ELSE IF (ad_LBC(isouth,isFsur,ng)%Chapman_explicit) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN + cff=dt2d*GRID(ng)%pn(i,Jstr) + cff1=SQRT(g*(GRID(ng)%h(i,Jstr)+ & + & zeta(i,Jstr,know))) + Ce=cff*cff1 +# ifdef MASKING +!^ tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + ad_zeta_new(i,Jstr-1)=ad_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif +!^ tl_zeta_new(i,Jstr-1)=(1.0_r8-Ce)*tl_zeta(i,Jstr-1,know)+ & +!^ & tl_Ce*(zeta(i,Jstr-1,know)+ & +!^ & zeta(i,Jstr ,know))+ & +!^ & Ce*tl_zeta(i,Jstr,know) +!^ + ad_zeta(i,Jstr-1,know)=ad_zeta(i,Jstr-1,know)+ & + & (1.0_r8-Ce)*ad_zeta_new(i,Jstr-1) + ad_Ce=ad_Ce+(zeta(i,Jstr-1,know)+ & + & zeta(i,Jstr ,know))*ad_zeta_new(i,Jstr-1) + ad_zeta(i,Jstr,know)=ad_zeta(i,Jstr,know)+ & + & Ce*ad_zeta_new(i,Jstr-1) + ad_zeta_new(i,Jstr-1)=0.0_r8 +!^ tl_Ce=cff*tl_cff1 +!^ + ad_cff1=ad_cff1+cff*ad_Ce + ad_Ce=0.0_r8 +!^ tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(i,Jstr)+ & +!^ & tl_zeta(i,Jstr,know))/cff1 +!^ + adfac=0.5_r8*g*ad_cff1/cff1 + GRID(ng)%ad_h(i,Jstr)=GRID(ng)%ad_h(i,Jstr)+adfac + ad_zeta(i,Jstr,know)=ad_zeta(i,Jstr,know)+adfac + ad_cff1=0.0_r8 + END IF + END DO +! +! Southern edge, implicit Chapman boundary condition. +! + ELSE IF (ad_LBC(isouth,isFsur,ng)%Chapman_implicit) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN + cff=dt2d*GRID(ng)%pn(i,Jstr) + cff1=SQRT(g*(GRID(ng)%h(i,Jstr)+ & + & zeta(i,Jstr,know))) + Ce=cff*cff1 + cff2=1.0_r8/(1.0_r8+Ce) +# ifdef MASKING +!^ tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + ad_zeta_new(i,Jstr-1)=ad_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif +!^ tl_zeta_new(i,Jstr-1)=tl_cff2*(zeta(i,Jstr-1,know)+ & +!^ & Ce*zeta_new(i,Jstr))+ & +!^ & cff2*(tl_zeta(i,Jstr-1,know)+ & +!^ & tl_Ce*zeta_new(i,Jstr)+ & +!^ & Ce*tl_zeta_new(i,Jstr)) +!^ + adfac=cff2*ad_zeta_new(i,Jstr-1) + ad_zeta(i,Jstr-1,know)=ad_zeta(i,Jstr-1,know)+adfac + ad_zeta_new(i,Jstr)=ad_zeta_new(i,Jstr)+Ce*adfac + ad_Ce=ad_Ce+zeta_new(i,Jstr)*adfac + ad_cff2=ad_cff2+ & + & (zeta(i,Jstr-1,know)+ & + & Ce*zeta_new(i,Jstr))*ad_zeta_new(i,Jstr-1) + ad_zeta_new(i,Jstr-1)=0.0_r8 +!^ tl_cff2=-cff2*cff2*tl_Ce +!^ + ad_Ce=ad_Ce-cff2*cff2*ad_cff2 + ad_cff2=0.0_r8 +!^ tl_Ce=cff*tl_cff1 +!^ + ad_cff1=ad_cff1+cff*ad_Ce + ad_Ce=0.0_r8 +!^ tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(i,Jstr)+ & +!^ & tl_zeta(i,Jstr,know))/cff1 +!^ + adfac=0.5_r8*g*ad_cff1/cff1 + GRID(ng)%ad_h(i,Jstr)=GRID(ng)%ad_h(i,Jstr)+adfac + ad_zeta(i,Jstr,know)=ad_zeta(i,Jstr,know)+adfac + ad_cff1=0.0_r8 + END IF + END DO +! +! Southern edge, clamped boundary condition. +! + ELSE IF (ad_LBC(isouth,isFsur,ng)%clamped) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN +# ifdef MASKING +!^ tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + ad_zeta_new(i,Jstr-1)=ad_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif +# ifdef ADJUST_BOUNDARY + IF (Lobc(isouth,isFsur,ng)) THEN +!^ tl_zeta_new(i,Jstr-1)=BOUNDARY(ng)%tl_zeta_south(i) +!^ + BOUNDARY(ng)%ad_zeta_south(i)=BOUNDARY(ng)% & + & ad_zeta_south(i)+ & + & ad_zeta_new(i,Jstr-1) + ad_zeta_new(i,Jstr-1)=0.0_r8 + ELSE +!^ tl_zeta_new(i,Jstr-1)=0.0_r8 +!^ + ad_zeta_new(i,Jstr-1)=0.0_r8 + END IF +# else +!^ tl_zeta_new(i,Jstr-1)=0.0_r8 +!^ + ad_zeta_new(i,Jstr-1)=0.0_r8 +# endif + END IF + END DO +! +! Southern edge, gradient boundary condition. +! + ELSE IF (ad_LBC(isouth,isFsur,ng)%gradient) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN +# ifdef MASKING +!^ tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + ad_zeta_new(i,Jstr-1)=ad_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif +!^ tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr) +!^ + ad_zeta_new(i,Jstr )=ad_zeta_new(i,Jstr )+ & + & ad_zeta_new(i,Jstr-1) + ad_zeta_new(i,Jstr-1)=0.0_r8 + END IF + END DO +! +! Southern edge, closed boundary condition. +! + ELSE IF (ad_LBC(isouth,isFsur,ng)%closed) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN +# ifdef MASKING +!^ tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + ad_zeta_new(i,Jstr-1)=ad_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif +!^ tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr) +!^ + ad_zeta_new(i,Jstr )=ad_zeta_new(i,Jstr )+ & + & ad_zeta_new(i,Jstr-1) + ad_zeta_new(i,Jstr-1)=0.0_r8 + END IF + END DO + END IF + END IF +! +!----------------------------------------------------------------------- +! Lateral boundary conditions at the eastern edge. +!----------------------------------------------------------------------- +! + IF (DOMAIN(ng)%Eastern_Edge(tile)) THEN +! +! Eastern edge, implicit upstream radiation condition. +! (Not implemented since the ADM requires nonlinear celerity at every +! timestep. Using gradient instead). +! + IF (ad_LBC(ieast,isFsur,ng)%radiation) THEN + IF (iic(ng).ne.0) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN +# ifdef MASKING +!^ tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + ad_zeta_new(Iend+1,j)=ad_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif +# if defined CELERITY_READ && defined FORWARD_READ + IF (ad_LBC(ieast,isFsur,ng)%nudging) THEN + IF (BOUNDARY(ng)%zeta_east_Cx(j).eq.0.0_r8) THEN + tau=FSobc_in(ieast) + ELSE + tau=FSobc_out(ieast) + END IF + tau=tau*dt2d + END IF + Cx=BOUNDARY(ng)%zeta_east_Cx(j) +# ifdef RADIATION_2D + Ce=BOUNDARY(ng)%zeta_east_Ce(j) +# else + Ce=0.0_r8 +# endif + cff=BOUNDARY(ng)%zeta_east_C2(j) +! + IF (ad_LBC(ieast,isFsur,ng)%nudging) THEN +!^ tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)- & +!^ & tau*tl_zeta(Iend+1,j,know) +!^ + ad_zeta(Iend+1,j,know)=ad_zeta(Iend+1,j,know)- & + & tau*ad_zeta_new(Iend+1,j) + END IF +!^ tl_zeta_new(Iend+1,j)=(cff*tl_zeta(Iend+1,j,know)+ & +!^ & Cx *tl_zeta_new(Iend,j)- & +!^ & MAX(Ce,0.0_r8)* & +!^ & tl_grad(Iend+1,j )- & +!^ & MIN(Ce,0.0_r8)* & +!^ & tl_grad(Iend+1,j+1))/ & +!^ & (cff+Cx) +!^ + adfac=ad_zeta_new(Iend+1,j)/(cff+Cx) + ad_grad(Iend+1,j )=ad_grad(Iend+1,j )- & + & MAX(Ce,0.0_r8)*adfac + ad_grad(Iend+1,j+1)=ad_grad(Iend+1,j+1)- & + & MIN(Ce,0.0_r8)*adfac + ad_zeta_new(Iend,j)=ad_zeta_new(Iend,j)+Cx *adfac + ad_zeta(Iend+1,j,know)=ad_zeta(Iend+1,j,know)+cff*adfac + ad_zeta_new(Iend+1,j)=0.0_r8 +# else +!^ tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend,j) +!^ gradient + ad_zeta_new(Iend ,j)=ad_zeta_new(Iend ,j)+ & + & ad_zeta_new(Iend+1,j) + ad_zeta_new(Iend+1,j)=0.0_r8 +# endif + END IF + END DO + END IF +! +! Eastern edge, explicit Chapman boundary condition. +! + ELSE IF (ad_LBC(ieast,isFsur,ng)%Chapman_explicit) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN + cff=dt2d*GRID(ng)%pm(Iend,j) + cff1=SQRT(g*(GRID(ng)%h(Iend,j)+ & + & zeta(Iend,j,know))) + Cx=cff*cff1 +# ifdef MASKING +!^ tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + ad_zeta_new(Iend+1,j)=ad_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif +!^ tl_zeta_new(Iend+1,j)=(1.0_r8-Cx)*tl_zeta(Iend+1,j,know)+ & +!^ & tl_Cx*(zeta(Iend+1,j,know)+ & +!^ & zeta(Iend ,j,know))+ & +!^ & Cx*tl_zeta(Iend,j,know) +!^ + ad_zeta(Iend+1,j,know)=ad_zeta(Iend+1,j,know)+ & + & (1.0_r8-Cx)*ad_zeta_new(Iend+1,j) + ad_Cx=ad_Cx+(zeta(Iend+1,j,know)+ & + & zeta(Iend ,j,know))*ad_zeta_new(Iend+1,j) + ad_zeta(Iend,j,know)=ad_zeta(Iend,j,know)+ & + & Cx*ad_zeta_new(Iend+1,j) + ad_zeta_new(Iend+1,j)=0.0_r8 +!^ tl_Cx=cff*tl_cff1 +!^ + ad_cff1=ad_cff1+cff*ad_Cx + ad_Cx=0.0_r8 +!^ tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(Iend,j)+ & +!^ & tl_zeta(Iend,j,know))/cff1 +!^ + adfac=0.5_r8*g*ad_cff1/cff1 + GRID(ng)%ad_h(Iend,j)=GRID(ng)%ad_h(Iend,j)+adfac + ad_zeta(Iend,j,know)=ad_zeta(Iend,j,know)+adfac + ad_cff1=0.0_r8 + END IF + END DO +! +! Eastern edge, implicit Chapman boundary condition. +! + ELSE IF (ad_LBC(ieast,isFsur,ng)%Chapman_implicit) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN + cff=dt2d*GRID(ng)%pm(Iend,j) + cff1=SQRT(g*(GRID(ng)%h(Iend,j)+ & + & zeta(Iend,j,know))) + Cx=cff*cff1 + cff2=1.0_r8/(1.0_r8+Cx) +# ifdef MASKING +!^ tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + ad_zeta_new(Iend+1,j)=ad_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif +!^ tl_zeta_new(Iend+1,j)=tl_cff2*(zeta(Iend+1,j,know)+ & +!^ & Cx*zeta_new(Iend,j))+ & +!^ & cff2*(tl_zeta(Iend+1,j,know)+ & +!^ & tl_Cx*zeta_new(Iend,j)+ & +!^ & Cx*tl_zeta_new(Iend,j)) +!^ + adfac=cff2*ad_zeta_new(Iend+1,j) + ad_zeta_new(Iend,j)=ad_zeta_new(Iend,j)+Cx*adfac + ad_zeta(Iend+1,j,know)=ad_zeta(Iend+1,j,know)+adfac + ad_Cx=ad_Cx+zeta_new(Iend,j)*adfac + ad_cff2=ad_cff2+ & + & (zeta(Iend+1,j,know)+ & + & Cx*zeta_new(Iend,j))*ad_zeta_new(Iend+1,j) + ad_zeta_new(Iend+1,j)=0.0_r8 +!^ tl_cff2=-cff2*cff2*tl_Cx +!^ + ad_Cx=ad_Cx-cff2*cff2*ad_cff2 + ad_cff2=0.0_r8 +!^ tl_Cx=cff*tl_cff1 +!^ + ad_cff1=ad_cff1+cff*ad_Cx + ad_Cx=0.0_r8 +!^ tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(Iend,j)+ & +!^ & tl_zeta(Iend,j,know))/cff1 +!^ + adfac=0.5_r8*g*ad_cff1/cff1 + GRID(ng)%ad_h(Iend,j)=GRID(ng)%ad_h(Iend,j)+adfac + ad_zeta(Iend,j,know)=ad_zeta(Iend,j,know)+adfac + ad_cff1=0.0_r8 + END IF + END DO +! +! Eastern edge, clamped boundary condition. +! + ELSE IF (ad_LBC(ieast,isFsur,ng)%clamped) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN +# ifdef MASKING +!^ tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + ad_zeta_new(Iend+1,j)=ad_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif +# ifdef ADJUST_BOUNDARY + IF (Lobc(ieast,isFsur,ng)) THEN +!^ tl_zeta_new(Iend+1,j)=BOUNDARY(ng)%tl_zeta_east(j) +!^ + BOUNDARY(ng)%ad_zeta_east(j)=BOUNDARY(ng)% & + & ad_zeta_east(j)+ & + & ad_zeta_new(Iend+1,j) + ad_zeta_new(Iend+1,j)=0.0_r8 + ELSE +!^ tl_zeta_new(Iend+1,j)=0.0_r8 +!^ + ad_zeta_new(Iend+1,j)=0.0_r8 + END IF +# else +!^ tl_zeta_new(Iend+1,j)=0.0_r8 +!^ + ad_zeta_new(Iend+1,j)=0.0_r8 +# endif + END IF + END DO +! +! Eastern edge, gradient boundary condition. +! + ELSE IF (ad_LBC(ieast,isFsur,ng)%gradient) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN +# ifdef MASKING +!^ tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + ad_zeta_new(Iend+1,j)=ad_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif +!^ tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend,j) +!^ + ad_zeta_new(Iend ,j)=ad_zeta_new(Iend ,j)+ & + & ad_zeta_new(Iend+1,j) + ad_zeta_new(Iend+1,j)=0.0_r8 + END IF + END DO +! +! Eastern edge, closed boundary condition. +! + ELSE IF (ad_LBC(ieast,isFsur,ng)%closed) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN +# ifdef MASKING +!^ tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + ad_zeta_new(Iend+1,j)=ad_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif +!^ tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend,j) +!^ + ad_zeta_new(Iend ,j)=ad_zeta_new(Iend ,j)+ & + & ad_zeta_new(Iend+1,j) + ad_zeta_new(Iend+1,j)=0.0_r8 + END IF + END DO + END IF + END IF +! +!----------------------------------------------------------------------- +! Lateral boundary conditions at the western edge. +!----------------------------------------------------------------------- +! + IF (DOMAIN(ng)%Western_Edge(tile)) THEN +! +! Western edge, implicit upstream radiation condition. +! (Not implemented since the ADM requires nonlinear celerity at every +! timestep. Using gradient instead). +! + IF (ad_LBC(iwest,isFsur,ng)%radiation) THEN + IF (iic(ng).ne.0) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN +# ifdef MASKING +!^ tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + ad_zeta_new(Istr-1,j)=ad_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif +# if defined CELERITY_READ && defined FORWARD_READ + IF (ad_LBC(iwest,isFsur,ng)%nudging) THEN + IF (BOUNDARY(ng)%zeta_west_Cx(j).eq.0.0_r8) THEN + tau=FSobc_in(ng,iwest) + ELSE + tau=FSobc_out(ng,iwest) + END IF + tau=tau*dt2d + END IF + Cx=BOUNDARY(ng)%zeta_west_Cx(j) +# ifdef RADIATION_2D + Ce=BOUNDARY(ng)%zeta_west_Ce(j) +# else + Ce=0.0_r8 +# endif + cff=BOUNDARY(ng)%zeta_west_C2(j) +! + IF (ad_LBC(iwest,isFsur,ng)%nudging) THEN +!^ tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)- & +!^ & tau*tl_zeta(Istr-1,j,know) +!^ + ad_zeta(Istr-1,j,know)=ad_zeta(Istr-1,j,know)- & + & tau*ad_zeta_new(Istr-1,j) + + END IF +!^ tl_zeta_new(Istr-1,j)=(cff*tl_zeta(Istr-1,j,know)+ & +!^ & Cx *tl_zeta_new(Istr,j)- & +!^ & MAX(Ce,0.0_r8)* & +!^ & tl_grad(Istr-1,j )- & +!^ & MIN(Ce,0.0_r8)* & +!^ & tl_grad(Istr-1,j+1))/ & +!^ & (cff+Cx) +!^ + adfac=ad_zeta_new(Istr-1,j)/(cff+Cx) + ad_grad(Istr-1,j )=ad_grad(Istr-1,j )- & + & MAX(Ce,0.0_r8)*adfac + ad_grad(Istr-1,j+1)=ad_grad(Istr-1,j+1)- & + & MIN(Ce,0.0_r8)*adfac + ad_zeta(Istr-1,j,know)=ad_zeta(Istr-1,j,know)+cff*adfac + ad_zeta_new(Istr ,j)=ad_zeta_new(Istr ,j)+Cx *adfac + ad_zeta_new(Istr-1,j)=0.0_r8 +# else +!^ tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr,j) +!^ gradient + ad_zeta_new(Istr ,j)=ad_zeta_new(Istr ,j)+ & + & ad_zeta_new(Istr-1,j) + ad_zeta_new(Istr-1,j)=0.0_r8 +# endif + END IF + END DO + END IF +! +! Western edge, explicit Chapman boundary condition. +! + ELSE IF (ad_LBC(iwest,isFsur,ng)%Chapman_explicit) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN + cff=dt2d*GRID(ng)%pm(Istr,j) + cff1=SQRT(g*(GRID(ng)%h(Istr,j)+ & + & zeta(Istr,j,know))) + Cx=cff*cff1 +# ifdef MASKING +!^ tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + ad_zeta_new(Istr-1,j)=ad_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif +!^ tl_zeta_new(Istr-1,j)=(1.0_r8-Cx)*tl_zeta(Istr-1,j,know)+ & +!^ & tl_Cx*(zeta(Istr-1,j,know)+ & +!^ & zeta(Istr ,j,know))+ & +!^ & Cx*tl_zeta(Istr,j,know) +!^ + ad_zeta(Istr-1,j,know)=ad_zeta(Istr-1,j,know)+ & + & (1.0_r8-Cx)*ad_zeta_new(Istr-1,j) + ad_Cx=ad_Cx+(zeta(Istr-1,j,know)+ & + & zeta(Istr ,j,know))*ad_zeta_new(Istr-1,j) + ad_zeta(Istr,j,know)=ad_zeta(Istr,j,know)+ & + & Cx*ad_zeta_new(Istr-1,j) + ad_zeta_new(Istr-1,j)=0.0_r8 +!^ tl_Cx=cff*tl_cff1 +!^ + ad_cff1=ad_cff1+cff*ad_Cx + ad_Cx=0.0_r8 +!^ tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(Istr,j)+ & +!^ & tl_zeta(Istr,j,know))/cff1 +!^ + adfac=0.5_r8*g*ad_cff1/cff1 + GRID(ng)%ad_h(Istr,j)=GRID(ng)%ad_h(Istr,j)+adfac + ad_zeta(Istr,j,know)=ad_zeta(Istr,j,know)+adfac + ad_cff1=0.0_r8 + END IF + END DO +! +! Western edge, implicit Chapman boundary condition. +! + ELSE IF (ad_LBC(iwest,isFsur,ng)%Chapman_implicit) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN + cff=dt2d*GRID(ng)%pm(Istr,j) + cff1=SQRT(g*(GRID(ng)%h(Istr,j)+ & + & zeta(Istr,j,know))) + Cx=cff*cff1 + cff2=1.0_r8/(1.0_r8+Cx) +# ifdef MASKING +!^ tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + ad_zeta_new(Istr-1,j)=ad_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif +!^ tl_zeta_new(Istr-1,j)=tl_cff2*(zeta(Istr-1,j,know)+ & +!^ & Cx*zeta_new(Istr,j))+ & +!^ & cff2*(tl_zeta(Istr-1,j,know)+ & +!^ & tl_Cx*zeta_new(Istr,j)+ & +!^ & Cx*tl_zeta_new(Istr,j)) +!^ + adfac=cff2*ad_zeta_new(Istr-1,j) + ad_zeta(Istr-1,j,know)=ad_zeta(Istr-1,j,know)+adfac + ad_zeta_new(Istr,j)=ad_zeta_new(Istr,j)+Cx*adfac + ad_Cx=ad_Cx+zeta_new(Istr,j)*adfac + ad_cff2=ad_cff2+ & + & (zeta(Istr-1,j,know)+ & + & Cx*zeta_new(Istr,j))*ad_zeta_new(Istr-1,j) + ad_zeta_new(Istr-1,j)=0.0_r8 +!^ tl_cff2=-cff2*cff2*tl_Cx +!^ + ad_Cx=ad_Cx-cff2*cff2*ad_cff2 + ad_cff2=0.0_r8 +!^ tl_Cx=cff*tl_cff1 +!^ + ad_cff1=ad_cff1+cff*ad_Cx + ad_Cx=0.0_r8 +!^ tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(Istr,j)+ & +!^ & tl_zeta(Istr,j,know))/cff1 +!^ + adfac=0.5_r8*g*ad_cff1/cff1 + GRID(ng)%ad_h(Istr,j)=GRID(ng)%ad_h(Istr,j)+adfac + ad_zeta(Istr,j,know)=ad_zeta(Istr,j,know)+adfac + ad_cff1=0.0_r8 + END IF + END DO +! +! Western edge, clamped boundary condition. +! + ELSE IF (ad_LBC(iwest,isFsur,ng)%gradient) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN +# ifdef MASKING +!^ tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + ad_zeta_new(Istr-1,j)=ad_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif +# ifdef ADJUST_BOUNDARY + IF (Lobc(iwest,isFsur,ng)) THEN +!^ tl_zeta_new(Istr-1,j)=BOUNDARY(ng)%tl_zeta_west(j) +!^ + BOUNDARY(ng)%ad_zeta_west(j)=BOUNDARY(ng)% & + & ad_zeta_west(j)+ & + & ad_zeta_new(Istr-1,j) + ad_zeta_new(Istr-1,j)=0.0_r8 + ELSE +!^ tl_zeta_new(Istr-1,j)=0.0_r8 +!^ + ad_zeta_new(Istr-1,j)=0.0_r8 + END IF +# else +!^ tl_zeta_new(Istr-1,j)=0.0_r8 +!^ + ad_zeta_new(Istr-1,j)=0.0_r8 +# endif + END IF + END DO +! +! Western edge, gradient boundary condition. +! + ELSE IF (ad_LBC(iwest,isFsur,ng)%gradient) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN +# ifdef MASKING +!^ tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + ad_zeta_new(Istr-1,j)=ad_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif +!^ tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr,j) +!^ + ad_zeta_new(Istr ,j)=ad_zeta_new(Istr ,j)+ & + & ad_zeta_new(Istr-1,j) + ad_zeta_new(Istr-1,j)=0.0_r8 + END IF + END DO +! +! Western edge, closed boundary condition. +! + ELSE IF (ad_LBC(iwest,isFsur,ng)%closed) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN +# ifdef MASKING +!^ tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + ad_zeta_new(Istr-1,j)=ad_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif +!^ tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr,j) +!^ + ad_zeta_new(Istr ,j)=ad_zeta_new(Istr ,j)+ & + & ad_zeta_new(Istr-1,j) + ad_zeta_new(Istr-1,j)=0.0_r8 + END IF + END DO + END IF + END IF +! + RETURN + END SUBROUTINE ad_zetabc_local +# endif #endif END MODULE ad_zetabc_mod diff --git a/ROMS/Modules/mod_coupling.F b/ROMS/Modules/mod_coupling.F index c9bee4431..193846a8f 100644 --- a/ROMS/Modules/mod_coupling.F +++ b/ROMS/Modules/mod_coupling.F @@ -16,8 +16,14 @@ MODULE mod_coupling ! Zt_avg1 Free-surface averaged over all short time-steps (m). ! ! rhoA Normalized vertical averaged density. ! ! rhoS Normalized vertical averaged density perturbation. ! -! rufrc Right-hand-side forcing term for 2D U-momentum (m4/s2) ! -! rvfrc Right-hand-side forcing term for 2D V-momentum (m4/s2) ! +! rufrc Right-hand-side forcing term for 2D U-momentum (m4/s2). ! +! rvfrc Right-hand-side forcing term for 2D V-momentum (m4/s2). ! +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +! rufrc_bak Right-hand-side forcing term for 2D U-momentum (m4/s2) ! +! in the Forward-Backward AB3-AM4 time stepping scheme. ! +! rvfrc_bak Right-hand-side forcing term for 2D V-momentum (m4/s2) ! +! in the Forward-Backward AB3-AM4 time stepping scheme. ! +# endif ! ! !======================================================================= ! @@ -44,6 +50,10 @@ MODULE mod_coupling real(r8), pointer :: Zt_avg1(:,:) real(r8), pointer :: rufrc(:,:) real(r8), pointer :: rvfrc(:,:) +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + real(r8), pointer :: rufrc_bak(:,:,:) + real(r8), pointer :: rvfrc_bak(:,:,:) +# endif # ifdef VAR_RHO_2D real(r8), pointer :: rhoA(:,:) real(r8), pointer :: rhoS(:,:) @@ -60,6 +70,10 @@ MODULE mod_coupling real(r8), pointer :: tl_Zt_avg1(:,:) real(r8), pointer :: tl_rufrc(:,:) real(r8), pointer :: tl_rvfrc(:,:) +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + real(r8), pointer :: tl_rufrc_bak(:,:,:) + real(r8), pointer :: tl_rvfrc_bak(:,:,:) +# endif # ifdef VAR_RHO_2D_NOT_YET real(r8), pointer :: tl_rhoA(:,:) real(r8), pointer :: tl_rhoS(:,:) @@ -77,6 +91,10 @@ MODULE mod_coupling real(r8), pointer :: ad_Zt_avg1(:,:) real(r8), pointer :: ad_rufrc(:,:) real(r8), pointer :: ad_rvfrc(:,:) +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + real(r8), pointer :: ad_rufrc_bak(:,:,:) + real(r8), pointer :: ad_rvfrc_bak(:,:,:) +# endif # ifdef VAR_RHO_2D_NOT_YET real(r8), pointer :: ad_rhoA(:,:) real(r8), pointer :: ad_rhoS(:,:) @@ -155,6 +173,14 @@ SUBROUTINE allocate_coupling (ng, LBi, UBi, LBj, UBj) allocate ( COUPLING(ng) % rvfrc(LBi:UBi,LBj:UBj) ) Dmem(ng)=Dmem(ng)+size2d +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + allocate ( COUPLING(ng) % rufrc_bak(LBi:UBi,LBj:UBj,2) ) + Dmem(ng)=Dmem(ng)+2.0_r8*size2d + + allocate ( COUPLING(ng) % rvfrc_bak(LBi:UBi,LBj:UBj,2) ) + Dmem(ng)=Dmem(ng)+2.0_r8*size2d +# endif + # ifdef VAR_RHO_2D allocate ( COUPLING(ng) % rhoA(LBi:UBi,LBj:UBj) ) Dmem(ng)=Dmem(ng)+size2d @@ -188,6 +214,14 @@ SUBROUTINE allocate_coupling (ng, LBi, UBi, LBj, UBj) allocate ( COUPLING(ng) % tl_rvfrc(LBi:UBi,LBj:UBj) ) Dmem(ng)=Dmem(ng)+size2d +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + allocate ( COUPLING(ng) % tl_rufrc_bak(LBi:UBi,LBj:UBj,2) ) + Dmem(ng)=Dmem(ng)+2.0_r8*size2d + + allocate ( COUPLING(ng) % tl_rvfrc_bak(LBi:UBi,LBj:UBj,2) ) + Dmem(ng)=Dmem(ng)+2.0_r8*size2d +# endif + # ifdef VAR_RHO_2D_NOT_YET allocate ( COUPLING(ng) % tl_rhoA(LBi:UBi,LBj:UBj) ) Dmem(ng)=Dmem(ng)+size2d @@ -222,6 +256,14 @@ SUBROUTINE allocate_coupling (ng, LBi, UBi, LBj, UBj) allocate ( COUPLING(ng) % ad_rvfrc(LBi:UBi,LBj:UBj) ) Dmem(ng)=Dmem(ng)+size2d +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + allocate ( COUPLING(ng) % ad_rufrc_bak(LBi:UBi,LBj:UBj,2) ) + Dmem(ng)=Dmem(ng)+2.0_r8*size2d + + allocate ( COUPLING(ng) % ad_rvfrc_bak(LBi:UBi,LBj:UBj,2) ) + Dmem(ng)=Dmem(ng)+2.0_r8*size2d +# endif + # ifdef VAR_RHO_2D_NOT_YET allocate ( COUPLING(ng) % ad_rhoA(LBi:UBi,LBj:UBj) ) Dmem(ng)=Dmem(ng)+size2d @@ -311,6 +353,14 @@ SUBROUTINE deallocate_coupling (ng) IF (.not.destroy(ng, COUPLING(ng)%rvfrc, MyFile, & & __LINE__, 'COUPLING(ng)%rvfrc')) RETURN +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + IF (.not.destroy(ng, COUPLING(ng)%rufrc_bak, MyFile, & + & __LINE__, 'COUPLING(ng)%rufrc_bak')) RETURN + + IF (.not.destroy(ng, COUPLING(ng)%rvfrc_bak, MyFile, & + & __LINE__, 'COUPLING(ng)%rvfrc_bak')) RETURN +# endif + # ifdef VAR_RHO_2D IF (.not.destroy(ng, COUPLING(ng)%rhoA, MyFile, & & __LINE__, 'COUPLING(ng)%rhoA')) RETURN @@ -344,6 +394,14 @@ SUBROUTINE deallocate_coupling (ng) IF (.not.destroy(ng, COUPLING(ng)%tl_rvfrc, MyFile, & & __LINE__, 'COUPLING(ng)%tl_rvfrc')) RETURN +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + IF (.not.destroy(ng, COUPLING(ng)%tl_rufrc_bak, MyFile, & + & __LINE__, 'COUPLING(ng)%tl_rufrc_bak')) RETURN + + IF (.not.destroy(ng, COUPLING(ng)%tl_rvfrc_bak, MyFile, & + & __LINE__, 'COUPLING(ng)%tl_rvfrc_bak')) RETURN +# endif + # ifdef VAR_RHO_2D_NOT_YET IF (.not.destroy(ng, COUPLING(ng)%tl_rhoA, MyFile, & & __LINE__, 'COUPLING(ng)%tl_rhoA')) RETURN @@ -378,6 +436,14 @@ SUBROUTINE deallocate_coupling (ng) IF (.not.destroy(ng, COUPLING(ng)%ad_rvfrc, MyFile, & & __LINE__, 'COUPLING(ng)%ad_rvfrc')) RETURN +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + IF (.not.destroy(ng, COUPLING(ng)%ad_rufrc_bak, MyFile, & + & __LINE__, 'COUPLING(ng)%ad_rufrc_bak')) RETURN + + IF (.not.destroy(ng, COUPLING(ng)%ad_rvfrc_bak, MyFile, & + & __LINE__, 'COUPLING(ng)%ad_rvfrc_bak')) RETURN +# endif + # ifdef VAR_RHO_2D_NOT_YET IF (.not.destroy(ng, COUPLING(ng)%ad_rhoA, MyFile, & & __LINE__, 'COUPLING(ng)%ad_rhoA')) RETURN @@ -501,6 +567,13 @@ SUBROUTINE initialize_coupling (ng, tile, model) COUPLING(ng) % rufrc(i,j) = IniVal COUPLING(ng) % rvfrc(i,j) = IniVal +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + COUPLING(ng) % rufrc_bak(i,j,1) = IniVal + COUPLING(ng) % rufrc_bak(i,j,2) = IniVal + COUPLING(ng) % rvfrc_bak(i,j,1) = IniVal + COUPLING(ng) % rvfrc_bak(i,j,2) = IniVal +# endif + # ifdef VAR_RHO_2D COUPLING(ng) % rhoA(i,j) = IniVal COUPLING(ng) % rhoS(i,j) = IniVal @@ -527,6 +600,13 @@ SUBROUTINE initialize_coupling (ng, tile, model) COUPLING(ng) % tl_rufrc(i,j) = IniVal COUPLING(ng) % tl_rvfrc(i,j) = IniVal +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + COUPLING(ng) % tl_rufrc_bak(i,j,1) = IniVal + COUPLING(ng) % tl_rufrc_bak(i,j,2) = IniVal + COUPLING(ng) % tl_rvfrc_bak(i,j,1) = IniVal + COUPLING(ng) % tl_rvfrc_bak(i,j,2) = IniVal +# endif + # ifdef VAR_RHO_2D_NOT_YET COUPLING(ng) % tl_rhoA(i,j) = IniVal COUPLING(ng) % tl_rhoS(i,j) = IniVal @@ -554,6 +634,13 @@ SUBROUTINE initialize_coupling (ng, tile, model) COUPLING(ng) % ad_rufrc(i,j) = IniVal COUPLING(ng) % ad_rvfrc(i,j) = IniVal +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + COUPLING(ng) % ad_rufrc_bak(i,j,1) = IniVal + COUPLING(ng) % ad_rufrc_bak(i,j,2) = IniVal + COUPLING(ng) % ad_rvfrc_bak(i,j,1) = IniVal + COUPLING(ng) % ad_rvfrc_bak(i,j,2) = IniVal +# endif + # ifdef VAR_RHO_2D_NOT_YET COUPLING(ng) % ad_rhoA(i,j) = IniVal COUPLING(ng) % ad_rhoS(i,j) = IniVal diff --git a/ROMS/Modules/mod_ocean.F b/ROMS/Modules/mod_ocean.F index 79b254ed4..3c60b104b 100644 --- a/ROMS/Modules/mod_ocean.F +++ b/ROMS/Modules/mod_ocean.F @@ -10,9 +10,11 @@ MODULE mod_ocean ! ! ! 2D Primitive Variables. ! ! ! +#if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) ! rubar Right-hand-side of 2D U-momentum equation (m4/s2). ! ! rvbar Right-hand-side of 2D V-momentum equation (m4/s2). ! ! rzeta Right-hand-side of free surface equation (m3/s). ! +#endif ! ubar Vertically integrated U-momentum component (m/s). ! ! vbar Vertically integrated V-momentum component (m/s). ! ! zeta Free surface (m). ! @@ -32,6 +34,10 @@ MODULE mod_ocean ! v 3D V-momentum component (m/s). ! ! va 3D U-momentun component (m/s) at RHO-points, A-grid. ! ! W S-coordinate (omega*Hz/mn) vertical velocity (m3/s). ! +# if defined OMEGA_IMPLICIT +! Wi Implicit, S-coordinate vertical velocity (m3/s). ! +# endif +! wvel Z-coordinate vertical velocity (m/s). ! #ifdef BIOLOGY ! ! ! Biology Variables. ! @@ -85,9 +91,11 @@ MODULE mod_ocean ! ! Nonlinear model state. ! +#if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) real(r8), pointer :: rubar(:,:,:) real(r8), pointer :: rvbar(:,:,:) real(r8), pointer :: rzeta(:,:,:) +#endif real(r8), pointer :: ubar(:,:,:) real(r8), pointer :: vbar(:,:,:) real(r8), pointer :: zeta(:,:,:) @@ -149,9 +157,11 @@ MODULE mod_ocean ! ! Tangent linear model state. ! +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) real(r8), pointer :: tl_rubar(:,:,:) real(r8), pointer :: tl_rvbar(:,:,:) real(r8), pointer :: tl_rzeta(:,:,:) +# endif real(r8), pointer :: tl_ubar(:,:,:) real(r8), pointer :: tl_vbar(:,:,:) real(r8), pointer :: tl_zeta(:,:,:) @@ -197,9 +207,11 @@ MODULE mod_ocean ! ! Adjoint model state. ! +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) real(r8), pointer :: ad_rubar(:,:,:) real(r8), pointer :: ad_rvbar(:,:,:) real(r8), pointer :: ad_rzeta(:,:,:) +# endif real(r8), pointer :: ad_ubar(:,:,:) real(r8), pointer :: ad_vbar(:,:,:) real(r8), pointer :: ad_zeta(:,:,:) @@ -230,6 +242,9 @@ MODULE mod_ocean real(r8), pointer :: ad_v(:,:,:,:) real(r8), pointer :: ad_va(:,:,:) real(r8), pointer :: ad_W(:,:,:) +# ifdef OMEGA_IMPLICIT + real(r8), pointer :: ad_Wi(:,:,:) +# endif real(r8), pointer :: ad_wvel(:,:,:) real(r8), pointer :: ad_t_sol(:,:,:,:) @@ -339,7 +354,8 @@ MODULE mod_ocean ! Latest two records of the nonlinear trajectory used to interpolate ! the background state in the tangent linear and adjoint models. ! -# ifdef FORWARD_RHS +# if defined FORWARD_RHS && \ + !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) real(r8), pointer :: rubarG(:,:,:) real(r8), pointer :: rvbarG(:,:,:) real(r8), pointer :: rzetaG(:,:,:) @@ -395,6 +411,7 @@ SUBROUTINE allocate_ocean (ng, LBi, UBi, LBj, UBj) ! ! Nonlinear model state. ! +#if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) allocate ( OCEAN(ng) % rubar(LBi:UBi,LBj:UBj,2) ) Dmem(ng)=Dmem(ng)+2.0_r8*size2d ! @@ -403,6 +420,19 @@ SUBROUTINE allocate_ocean (ng, LBi, UBi, LBj, UBj) ! allocate ( OCEAN(ng) % rzeta(LBi:UBi,LBj:UBj,2) ) Dmem(ng)=Dmem(ng)+2.0_r8*size2d +#endif + +#ifdef STEP2D_FB_AB3_AM4 +! + allocate ( OCEAN(ng) % ubar(LBi:UBi,LBj:UBj,4) ) + Dmem(ng)=Dmem(ng)+4.0_r8*size2d +! + allocate ( OCEAN(ng) % vbar(LBi:UBi,LBj:UBj,4) ) + Dmem(ng)=Dmem(ng)+4.0_r8*size2d +! + allocate ( OCEAN(ng) % zeta(LBi:UBi,LBj:UBj,4) ) + Dmem(ng)=Dmem(ng)+4.0_r8*size2d +#else ! allocate ( OCEAN(ng) % ubar(LBi:UBi,LBj:UBj,3) ) Dmem(ng)=Dmem(ng)+3.0_r8*size2d @@ -412,6 +442,7 @@ SUBROUTINE allocate_ocean (ng, LBi, UBi, LBj, UBj) ! allocate ( OCEAN(ng) % zeta(LBi:UBi,LBj:UBj,3) ) Dmem(ng)=Dmem(ng)+3.0_r8*size2d +#endif #if defined TIDE_GENERATING_FORCES ! @@ -537,10 +568,11 @@ SUBROUTINE allocate_ocean (ng, LBi, UBi, LBj, UBj) # endif #endif -#if (defined TANGENT || defined TL_IOMS) +#if defined TANGENT || defined TL_IOMS ! ! Tangent linear model state. ! +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) allocate ( OCEAN(ng) % tl_rubar(LBi:UBi,LBj:UBj,2) ) Dmem(ng)=Dmem(ng)+2.0_r8*size2d ! @@ -549,6 +581,19 @@ SUBROUTINE allocate_ocean (ng, LBi, UBi, LBj, UBj) ! allocate ( OCEAN(ng) % tl_rzeta(LBi:UBi,LBj:UBj,2) ) Dmem(ng)=Dmem(ng)+2.0_r8*size2d +# endif + +# ifdef STEP2D_FB_AB3_AM4 +! + allocate ( OCEAN(ng) % tl_ubar(LBi:UBi,LBj:UBj,4) ) + Dmem(ng)=Dmem(ng)+4.0_r8*size2d +! + allocate ( OCEAN(ng) % tl_vbar(LBi:UBi,LBj:UBj,4) ) + Dmem(ng)=Dmem(ng)+4.0_r8*size2d +! + allocate ( OCEAN(ng) % tl_zeta(LBi:UBi,LBj:UBj,4) ) + Dmem(ng)=Dmem(ng)+4.0_r8*size2d +# else ! allocate ( OCEAN(ng) % tl_ubar(LBi:UBi,LBj:UBj,3) ) Dmem(ng)=Dmem(ng)+3.0_r8*size2d @@ -558,6 +603,7 @@ SUBROUTINE allocate_ocean (ng, LBi, UBi, LBj, UBj) ! allocate ( OCEAN(ng) % tl_zeta(LBi:UBi,LBj:UBj,3) ) Dmem(ng)=Dmem(ng)+3.0_r8*size2d +# endif # if defined TIDE_GENERATING_FORCES ! @@ -651,6 +697,7 @@ SUBROUTINE allocate_ocean (ng, LBi, UBi, LBj, UBj) ! ! Adjoint model state. ! +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) allocate ( OCEAN(ng) % ad_rubar(LBi:UBi,LBj:UBj,2) ) Dmem(ng)=Dmem(ng)+2.0_r8*size2d ! @@ -659,6 +706,19 @@ SUBROUTINE allocate_ocean (ng, LBi, UBi, LBj, UBj) ! allocate ( OCEAN(ng) % ad_rzeta(LBi:UBi,LBj:UBj,2) ) Dmem(ng)=Dmem(ng)+2.0_r8*size2d +# endif + +# ifdef STEP2D_FB_AB3_AM4 +! + allocate ( OCEAN(ng) % ad_ubar(LBi:UBi,LBj:UBj,4) ) + Dmem(ng)=Dmem(ng)+4.0_r8*size2d +! + allocate ( OCEAN(ng) % ad_vbar(LBi:UBi,LBj:UBj,4) ) + Dmem(ng)=Dmem(ng)+4.0_r8*size2d +! + allocate ( OCEAN(ng) % ad_zeta(LBi:UBi,LBj:UBj,4) ) + Dmem(ng)=Dmem(ng)+4.0_r8*size2d +# else ! allocate ( OCEAN(ng) % ad_ubar(LBi:UBi,LBj:UBj,3) ) Dmem(ng)=Dmem(ng)+3.0_r8*size2d @@ -668,6 +728,7 @@ SUBROUTINE allocate_ocean (ng, LBi, UBi, LBj, UBj) ! allocate ( OCEAN(ng) % ad_zeta(LBi:UBi,LBj:UBj,3) ) Dmem(ng)=Dmem(ng)+3.0_r8*size2d +# endif ! allocate ( OCEAN(ng) % ad_ubar_sol(LBi:UBi,LBj:UBj) ) Dmem(ng)=Dmem(ng)+size2d @@ -937,7 +998,8 @@ SUBROUTINE allocate_ocean (ng, LBi, UBi, LBj, UBj) ! Latest two records of the nonlinear trajectory used to interpolate ! the background state in the tangent linear and adjoint models. ! -# ifdef FORWARD_RHS +# if defined FORWARD_RHS && \ + !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) allocate ( OCEAN(ng) % rubarG(LBi:UBi,LBj:UBj,2) ) Dmem(ng)=Dmem(ng)+2.0_r8*size2d ! @@ -948,6 +1010,7 @@ SUBROUTINE allocate_ocean (ng, LBi, UBi, LBj, UBj) Dmem(ng)=Dmem(ng)+2.0_r8*size2d ! # endif + allocate ( OCEAN(ng) % ubarG(LBi:UBi,LBj:UBj,2) ) Dmem(ng)=Dmem(ng)+2.0_r8*size2d ! @@ -1013,6 +1076,7 @@ SUBROUTINE deallocate_ocean (ng) ! ! Nonlinear model state. ! +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) IF (.not.destroy(ng, OCEAN(ng)%rubar, MyFile, & & __LINE__, 'OCEAN(ng)%rubar')) RETURN @@ -1021,6 +1085,7 @@ SUBROUTINE deallocate_ocean (ng) IF (.not.destroy(ng, OCEAN(ng)%rzeta, MyFile, & & __LINE__, 'OCEAN(ng)%rzeta')) RETURN +# endif IF (.not.destroy(ng, OCEAN(ng)%ubar, MyFile, & & __LINE__, 'OCEAN(ng)%ubar')) RETURN @@ -1136,10 +1201,11 @@ SUBROUTINE deallocate_ocean (ng) # endif # endif -# if (defined TANGENT || defined TL_IOMS) +# if defined TANGENT || defined TL_IOMS ! ! Tangent linear model state. ! +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) IF (.not.destroy(ng, OCEAN(ng)%tl_rubar, MyFile, & & __LINE__, 'OCEAN(ng)%tl_rubar')) RETURN @@ -1148,6 +1214,7 @@ SUBROUTINE deallocate_ocean (ng) IF (.not.destroy(ng, OCEAN(ng)%tl_rzeta, MyFile, & & __LINE__, 'OCEAN(ng)%tl_rzeta')) RETURN +# endif IF (.not.destroy(ng, OCEAN(ng)%tl_ubar, MyFile, & & __LINE__, 'OCEAN(ng)%tl_ubar')) RETURN @@ -1238,6 +1305,7 @@ SUBROUTINE deallocate_ocean (ng) ! ! Adjoint model state. ! +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) IF (.not.destroy(ng, OCEAN(ng)%ad_rubar, MyFile, & & __LINE__, 'OCEAN(ng)%ad_rubar')) RETURN @@ -1246,6 +1314,7 @@ SUBROUTINE deallocate_ocean (ng) IF (.not.destroy(ng, OCEAN(ng)%ad_rzeta, MyFile, & & __LINE__, 'OCEAN(ng)%ad_rzeta')) RETURN +# endif IF (.not.destroy(ng, OCEAN(ng)%ad_ubar, MyFile, & & __LINE__, 'OCEAN(ng)%ad_ubar')) RETURN @@ -1507,7 +1576,8 @@ SUBROUTINE deallocate_ocean (ng) ! Latest two records of the nonlinear trajectory used to interpolate ! the background state in the tangent linear and adjoint models. ! -# ifdef FORWARD_RHS +# if defined FORWARD_RHS && \ + !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) IF (.not.destroy(ng, OCEAN(ng)%rubarG, MyFile, & & __LINE__, 'OCEAN(ng)%rubarG')) RETURN @@ -1628,22 +1698,32 @@ SUBROUTINE initialize_ocean (ng, tile, model) IF ((model.eq.0).or.(model.eq.iNLM)) THEN DO j=Jmin,Jmax DO i=Imin,Imax +#if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) OCEAN(ng) % rubar(i,j,1) = IniVal OCEAN(ng) % rubar(i,j,2) = IniVal OCEAN(ng) % rvbar(i,j,1) = IniVal OCEAN(ng) % rvbar(i,j,2) = IniVal OCEAN(ng) % rzeta(i,j,1) = IniVal OCEAN(ng) % rzeta(i,j,2) = IniVal - +#endif OCEAN(ng) % ubar(i,j,1) = IniVal OCEAN(ng) % ubar(i,j,2) = IniVal OCEAN(ng) % ubar(i,j,3) = IniVal +#ifdef STEP2D_FB_AB3_AM4 + OCEAN(ng) % ubar(i,j,4) = IniVal +#endif OCEAN(ng) % vbar(i,j,1) = IniVal OCEAN(ng) % vbar(i,j,2) = IniVal OCEAN(ng) % vbar(i,j,3) = IniVal +#ifdef STEP2D_FB_AB3_AM4 + OCEAN(ng) % vbar(i,j,4) = IniVal +#endif OCEAN(ng) % zeta(i,j,1) = IniVal OCEAN(ng) % zeta(i,j,2) = IniVal OCEAN(ng) % zeta(i,j,3) = IniVal +#ifdef STEP2D_FB_AB3_AM4 + OCEAN(ng) % zeta(i,j,4) = IniVal +#endif #if defined TIDE_GENERATING_FORCES OCEAN(ng) % eq_tide(i,j) = IniVal #endif @@ -1730,29 +1810,39 @@ SUBROUTINE initialize_ocean (ng, tile, model) END DO END IF -#if (defined TANGENT || defined TL_IOMS) +#if defined TANGENT || defined TL_IOMS ! ! Tangent linear model state. ! IF ((model.eq.0).or.(model.eq.iTLM).or.(model.eq.iRPM)) THEN DO j=Jmin,Jmax DO i=Imin,Imax +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) OCEAN(ng) % tl_rubar(i,j,1) = IniVal OCEAN(ng) % tl_rubar(i,j,2) = IniVal OCEAN(ng) % tl_rvbar(i,j,1) = IniVal OCEAN(ng) % tl_rvbar(i,j,2) = IniVal OCEAN(ng) % tl_rzeta(i,j,1) = IniVal OCEAN(ng) % tl_rzeta(i,j,2) = IniVal - +# endif OCEAN(ng) % tl_ubar(i,j,1) = IniVal OCEAN(ng) % tl_ubar(i,j,2) = IniVal OCEAN(ng) % tl_ubar(i,j,3) = IniVal +# ifdef STEP2D_FB_AB3_AM4 + OCEAN(ng) % tl_ubar(i,j,4) = IniVal +# endif OCEAN(ng) % tl_vbar(i,j,1) = IniVal OCEAN(ng) % tl_vbar(i,j,2) = IniVal OCEAN(ng) % tl_vbar(i,j,3) = IniVal +# ifdef STEP2D_FB_AB3_AM4 + OCEAN(ng) % tl_vbar(i,j,4) = IniVal +# endif OCEAN(ng) % tl_zeta(i,j,1) = IniVal OCEAN(ng) % tl_zeta(i,j,2) = IniVal OCEAN(ng) % tl_zeta(i,j,3) = IniVal +# ifdef STEP2D_FB_AB3_AM4 + OCEAN(ng) % tl_zeta(i,j,4) = IniVal +# endif # if defined TIDE_GENERATING_FORCES OCEAN(ng) % tl_eq_tide(i,j) = IniVal @@ -1828,22 +1918,32 @@ SUBROUTINE initialize_ocean (ng, tile, model) IF ((model.eq.0).or.(model.eq.iADM)) THEN DO j=Jmin,Jmax DO i=Imin,Imax +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) OCEAN(ng) % ad_rubar(i,j,1) = IniVal OCEAN(ng) % ad_rubar(i,j,2) = IniVal OCEAN(ng) % ad_rvbar(i,j,1) = IniVal OCEAN(ng) % ad_rvbar(i,j,2) = IniVal OCEAN(ng) % ad_rzeta(i,j,1) = IniVal OCEAN(ng) % ad_rzeta(i,j,2) = IniVal - +# endif OCEAN(ng) % ad_ubar(i,j,1) = IniVal OCEAN(ng) % ad_ubar(i,j,2) = IniVal OCEAN(ng) % ad_ubar(i,j,3) = IniVal +# ifdef STEP2D_FB_AB3_AM4 + OCEAN(ng) % ad_ubar(i,j,4) = IniVal +# endif OCEAN(ng) % ad_vbar(i,j,1) = IniVal OCEAN(ng) % ad_vbar(i,j,2) = IniVal OCEAN(ng) % ad_vbar(i,j,3) = IniVal +# ifdef STEP2D_FB_AB3_AM4 + OCEAN(ng) % ad_vbar(i,j,4) = IniVal +# endif OCEAN(ng) % ad_zeta(i,j,1) = IniVal OCEAN(ng) % ad_zeta(i,j,2) = IniVal OCEAN(ng) % ad_zeta(i,j,3) = IniVal +# ifdef STEP2D_FB_AB3_AM4 + OCEAN(ng) % ad_zeta(i,j,4) = IniVal +# endif # if defined TIDE_GENERATING_FORCES OCEAN(ng) % ad_eq_tide(i,j) = IniVal @@ -2119,7 +2219,8 @@ SUBROUTINE initialize_ocean (ng, tile, model) IF (model.eq.0) THEN DO j=Jmin,Jmax DO i=Imin,Imax -# ifdef FORWARD_RHS +# if defined FORWARD_RHS && \ + !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) OCEAN(ng) % rubarG(i,j,1) = IniVal OCEAN(ng) % rubarG(i,j,2) = IniVal OCEAN(ng) % rvbarG(i,j,1) = IniVal diff --git a/ROMS/Nonlinear/set_zeta.F b/ROMS/Nonlinear/set_zeta.F index c941cc587..920a5c7aa 100644 --- a/ROMS/Nonlinear/set_zeta.F +++ b/ROMS/Nonlinear/set_zeta.F @@ -1,7 +1,8 @@ #include "cppdefs.h" MODULE set_zeta_mod -#ifdef SOLVE3D +#if defined SOLVE3D && \ + !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) ! !git $Id$ !================================================== Hernan G. Arango === @@ -83,7 +84,7 @@ SUBROUTINE set_zeta_tile (ng, tile, & # else real(r8), intent(in) :: Zt_avg1(LBi:UBi,LBj:UBj) - real(r8), intent(out) :: zeta(LBi:UBi,LBj:UBj,3) + real(r8), intent(out) :: zeta(LBi:UBi,LBj:UBj,:) # endif ! ! Local variable declarations. diff --git a/ROMS/Nonlinear/step2d.F b/ROMS/Nonlinear/step2d.F index 75fed07d1..af7d8a476 100644 --- a/ROMS/Nonlinear/step2d.F +++ b/ROMS/Nonlinear/step2d.F @@ -8,16 +8,27 @@ ! See License_ROMS.md Alexander F. Shchepetkin ! !==================================================== John C. Warner === ! ! -! This subroutine performs a fast (predictor or corrector) time-step ! -! for the free-surface and 2D momentum nonlinear equations. +! This module timesteps the Nonlinear Model (NLM) vertically- ! +! integrated primitive (2D shallow-water) equations for the ! +! free-surface and 2D momentum. In 3D applications, the ROMS ! +! numerical kernel is split between baroclinic and barotropic ! +! dynamics. The barotropic engine uses a smaller timestep in this ! +! routine to resolve fast gravity wave processes. ! # ifdef SOLVE3D +! ! ! It also calculates the time filtering variables over all fast-time ! -! steps to damp high frequency signals in 3D applications. ! +! steps to damp high frequency signals in 3D applications. ! # endif ! ! !======================================================================= ! -# include "step2d_LF_AM3.h" +# if defined STEP2D_FB_AB3_AM4 +# include "step2d_FB.h" +# elif defined STEP2D_FB_LF_AM3 +# include "step2d_FB_LF_AM3.h" +# else +# include "step2d_LF_AM3.h" +# endif #else MODULE step2d_mod END MODULE step2d_mod diff --git a/ROMS/Nonlinear/step2d_FB.h b/ROMS/Nonlinear/step2d_FB.h index be89222c1..e39d52480 100644 --- a/ROMS/Nonlinear/step2d_FB.h +++ b/ROMS/Nonlinear/step2d_FB.h @@ -134,6 +134,12 @@ & MIXING(ng) % visc4_p, MIXING(ng) % visc4_r, & # endif #endif +#ifdef WEC_MELLOR + & MIXING(ng) % rustr2d, MIXING(ng) % rvstr2d, & + & OCEAN(ng) % rulag2d, OCEAN(ng) % rvlag2d, & + & OCEAN(ng) % ubar_stokes, & + & OCEAN(ng) % vbar_stokes, & +#endif #if defined TIDE_GENERATING_FORCES && !defined SOLVE3D & OCEAN(ng) % eq_tide, & #endif @@ -211,6 +217,11 @@ #if defined SEDIMENT && defined SED_MORPH & bed_thick, & #endif +#ifdef WEC_MELLOR + & rustr2d, rvstr2d, & + & rulag2d, rvlag2d, & + & ubar_stokes, vbar_stokes, & +#endif #if defined TIDE_GENERATING_FORCES && !defined SOLVE3D & eq_tide, & #endif @@ -303,6 +314,14 @@ # if defined SEDIMENT && defined SED_MORPH real(r8), intent(in ) :: bed_thick(LBi:,LBj:,:) # endif +# ifdef WEC_MELLOR + real(r8), intent(in ) :: rustr2d(LBi:,LBj:) + real(r8), intent(in ) :: rvstr2d(LBi:,LBj:) + real(r8), intent(in ) :: rulag2d(LBi:,LBj:) + real(r8), intent(in ) :: rvlag2d(LBi:,LBj:) + real(r8), intent(in ) :: ubar_stokes(LBi:,LBj:) + real(r8), intent(in ) :: vbar_stokes(LBi:,LBj:) +# endif # if defined TIDE_GENERATING_FORCES && !defined SOLVE3D real(r8), intent(in ) :: eq_tide(LBi:,LBj:) # endif @@ -400,6 +419,14 @@ # if defined SEDIMENT && defined SED_MORPH real(r8), intent(in ) :: bed_thick(LBi:UBi,LBj:UBj,1:3) # endif +# ifdef WEC_MELLOR + real(r8), intent(in ) :: rustr2d(LBi:UBi,LBj:UBj) + real(r8), intent(in ) :: rvstr2d(LBi:UBi,LBj:UBj) + real(r8), intent(in ) :: rulag2d(LBi:UBi,LBj:UBj) + real(r8), intent(in ) :: rvlag2d(LBi:UBi,LBj:UBj) + real(r8), intent(in ) :: ubar_stokes(LBi:UBi,LBj:UBj) + real(r8), intent(in ) :: vbar_stokes(LBi:UBi,LBj:UBj) +# endif # if defined TIDE_GENERATING_FORCES && !defined SOLVE3D real(r8), intent(in ) :: eq_tide(LBi:UBi,LBj:UBj) # endif @@ -468,7 +495,7 @@ #ifdef DEBUG real(r8), parameter :: IniVal = 0.0_r8 #endif -! +! #if defined UV_C4ADVECTION && !defined SOLVE3D real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dgrad #endif @@ -481,6 +508,10 @@ real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Dstp real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DUon real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DVom +#ifdef WEC_MELLOR + real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DUSon + real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: DVSom +#endif #if defined STEP2D_CORIOLIS || !defined SOLVE3D real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: UFx real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: VFe @@ -517,7 +548,7 @@ #include "set_bounds.h" #ifdef DEBUG -! +! !----------------------------------------------------------------------- ! Initialize private arrays for debugging. !----------------------------------------------------------------------- @@ -647,12 +678,18 @@ ! equations. ! #if defined DISTRIBUTE && !defined NESTING -# define IR_RANGE IstrUm2-1,Iendp2 -# define JR_RANGE JstrVm2-1,Jendp2 -# define IU_RANGE IstrUm1-1,Iendp2 -# define JU_RANGE Jstrm1-1,Jendp2 -# define IV_RANGE Istrm1-1,Iendp2 -# define JV_RANGE JstrVm1-1,Jendp2 +# define IR_RANGE IstrU-2,Iendp2 +# define JR_RANGE JstrV-2,Jendp2 +# define IU_RANGE IstrU-1,Iendp2 +# define JU_RANGE JstrV-2,Jendp2 +# define IV_RANGE IstrU-2,Iendp2 +# define JV_RANGE JstrV-1,Jendp2 +!!# define IR_RANGE IstrUm2-1,Iendp2 +!!# define JR_RANGE JstrVm2-1,Jendp2 +!!# define IU_RANGE IstrUm1-1,Iendp2 +!!# define JU_RANGE Jstrm1-1,Jendp2 +!!# define IV_RANGE Istrm1-1,Iendp2 +!!# define JV_RANGE JstrVm1-1,Jendp2 #else # define IR_RANGE IstrUm2-1,Iendp2 # define JR_RANGE JstrVm2-1,Jendp2 @@ -663,7 +700,7 @@ #endif DO j=JR_RANGE - DO i=IR_RANGE + DO i=IR_RANGE Drhs(i,j)=h(i,j)+fwd0*zeta(i,j,kstp)+ & & fwd1*zeta(i,j,kbak)+ & & fwd2*zeta(i,j,kold) @@ -747,17 +784,17 @@ ! ! Notice that the new local free-surface is allocated so it can be ! passed as an argumment to "zetabc_local". An automatic array cannot -! be used here because of weird memory problems. +! be used here because of weird memory problems. ! allocate ( zeta_new(IminS:ImaxS,JminS:JmaxS) ) zeta_new = 0.0_r8 ! ! Compute "zeta_new" at new time step and interpolate it half-step -! backward, "zwrk" for the subsequent computation of the tangent +! backward, "zwrk" for the subsequent computation of the tangent ! linear barotropic pressure gradient. Here, we use the BASIC STATE ! values. Thus, the nonlinear correction to the pressure-gradient ! term from "kstp" to "knew" is not needed for Forward-Euler to -! Forward-Backward steps (PGF_FB_CORRECTION method). +! Forward-Backward steps (PGF_FB_CORRECTION method). ! DO j=JstrV-1,Jend DO i=IstrU-1,Iend @@ -880,7 +917,7 @@ #ifdef SOLVE3D ! ! Notice that we are suppressing the computation of momentum advection, -! Coriolis, and lateral viscosity terms in 3D Applications because +! Coriolis, and lateral viscosity terms in 3D Applications because ! these terms are already included in the baroclinic-to-barotropic ! forcing arrays "rufrc" and "rvfrc". It does not mean we are entirely ! omitting them, but it is a choice between recomputing them at every @@ -999,6 +1036,10 @@ UFx(i,j)=0.25_r8* & & (DUon(i,j)+DUon(i+1,j))* & & (urhs(i ,j)+ & +# ifdef WEC_MELLOR + & ubar_stokes(i ,j)+ & + & ubar_stokes(i+1,j)+ & +# endif & urhs(i+1,j)) END IF ! @@ -1008,6 +1049,10 @@ # endif & (DUon(i+1,j)+DUon(i+1,j-1))* & & (vrhs(i+1,j)+ & +# ifdef WEC_MELLOR + & vbar_stokes(i ,j)+ & + & vbar_stokes(i-1,j)+ & +# endif & vrhs(i ,j)) END DO END DO @@ -1018,6 +1063,10 @@ VFe(i,j)=0.25_r8* & & (DVom(i,j)+DVom(i,j+1))* & & (vrhs(i,j )+ & +# ifdef WEC_MELLOR + & vbar_stokes(i,j )+ & + & vbar_stokes(i,j+1)+ & +# endif & vrhs(i,j+1)) END IF ! @@ -1027,6 +1076,10 @@ # endif & (DVom(i,j+1)+DVom(i-1,j+1))* & & (urhs(i,j+1)+ & +# ifdef WEC_MELLOR + & ubar_stokes(i,j+1)+ & + & ubar_stokes(i,j )+ & +# endif & urhs(i,j )) END DO END DO @@ -1038,6 +1091,10 @@ DO j=Jstr,Jend DO i=IstrUm1,Iendp1 grad (i,j)=urhs(i-1,j)-2.0_r8*urhs(i,j)+ & +# ifdef WEC_MELLOR + & ubar_stokes(i-1,j)-2.0_r8*ubar_stokes(i,j)+ & + & ubar_stokes(i+1,j)+ & +# endif & urhs(i+1,j) Dgrad(i,j)=DUon(i-1,j)-2.0_r8*DUon(i,j)+DUon(i+1,j) END DO @@ -1063,6 +1120,10 @@ DO j=Jstr,Jend DO i=IstrU-1,Iend UFx(i,j)=0.25_r8*(urhs(i ,j)+ & +# ifdef WEC_MELLOR + & ubar_stokes(i ,j)+ & + & ubar_stokes(i+1,j)+ & +# endif & urhs(i+1,j)- & & cff*(grad (i,j)+grad (i+1,j)))* & & (DUon(i,j)+DUon(i+1,j)- & @@ -1073,6 +1134,10 @@ DO j=Jstrm1,Jendp1 DO i=IstrU,Iend grad(i,j)=urhs(i,j-1)-2.0_r8*urhs(i,j)+ & +# ifdef WEC_MELLOR + & ubar_stokes(i,j-1)-2.0_r8*ubar_stokes(i,j)+ & + & ubar_stokes(i,j+1)+ & +# endif & urhs(i,j+1) END DO END DO @@ -1100,6 +1165,10 @@ DO j=Jstr,Jend+1 DO i=IstrU,Iend UFe(i,j)=0.25_r8*(urhs(i,j )+ & +# ifdef WEC_MELLOR + & ubar_stokes(i,j )+ & + & ubar_stokes(i,j-1)+ & +# endif & urhs(i,j-1)- & & cff*(grad (i,j)+grad (i,j-1)))* & & (DVom(i,j)+DVom(i-1,j)- & @@ -1112,6 +1181,10 @@ DO j=JstrV,Jend DO i=Istrm1,Iendp1 grad(i,j)=vrhs(i-1,j)-2.0_r8*vrhs(i,j)+ & +# ifdef WEC_MELLOR + & vbar_stokes(i-1,j)-2.0_r8*vbar_stokes(i,j)+ & + & vbar_stokes(i+1,j)+ & +# endif & vrhs(i+1,j) END DO END DO @@ -1139,6 +1212,10 @@ DO j=JstrV,Jend DO i=Istr,Iend+1 VFx(i,j)=0.25_r8*(vrhs(i ,j)+ & +# ifdef WEC_MELLOR + & vbar_stokes(i ,j)+ & + & vbar_stokes(i-1,j)+ & +# endif & vrhs(i-1,j)- & & cff*(grad (i,j)+grad (i-1,j)))* & & (DUon(i,j)+DUon(i,j-1)- & @@ -1149,6 +1226,10 @@ DO j=JstrVm1,Jendp1 DO i=Istr,Iend grad(i,j)=vrhs(i,j-1)-2.0_r8*vrhs(i,j)+ & +# ifdef WEC_MELLOR + & vbar_stokes(i,j-1)-2.0_r8*vbar_stokes(i,j)+ & + & vbar_stokes(i,j+1)+ & +# endif & vrhs(i,j+1) Dgrad(i,j)=DVom(i,j-1)-2.0_r8*DVom(i,j)+DVom(i,j+1) END DO @@ -1174,6 +1255,10 @@ DO j=JstrV-1,Jend DO i=Istr,Iend VFe(i,j)=0.25_r8*(vrhs(i,j )+ & +# ifdef WEC_MELLOR + & vbar_stokes(i,j )+ & + & vbar_stokes(i,j+1)+ & +# endif & vrhs(i,j+1)- & & cff*(grad (i,j)+grad (i,j+1)))* & & (DVom(i,j)+DVom(i,j+1)- & @@ -1223,8 +1308,16 @@ DO i=IstrU-1,Iend cff=0.5_r8*Drhs(i,j)*fomn(i,j) UFx(i,j)=cff*(vrhs(i,j )+ & +# ifdef WEC_MELLOR + & vbar_stokes(i,j )+ & + & vbar_stokes(i,j+1)+ & +# endif & vrhs(i,j+1)) VFe(i,j)=cff*(urhs(i ,j)+ & +# ifdef WEC_MELLOR + & ubar_stokes(i ,j)+ & + & ubar_stokes(i+1,j)+ & +# endif & urhs(i+1,j)) END DO END DO @@ -1260,8 +1353,16 @@ DO j=JstrV-1,Jend DO i=IstrU-1,Iend cff1=0.5_r8*(vrhs(i,j )+ & +# ifdef WEC_MELLOR + & vbar_stokes(i,j )+ & + & vbar_stokes(i,j+1)+ & +# endif & vrhs(i,j+1)) cff2=0.5_r8*(urhs(i ,j)+ +# ifdef WEC_MELLOR + & ubar_stokes(i ,j)+ & + & ubar_stokes(i+1,j)+ & +# endif & urhs(i+1,j)) cff3=cff1*dndx(i,j) cff4=cff2*dmde(i,j) @@ -1399,8 +1500,8 @@ ! subtracting the fast-time "rubar" and "rvbar" from them. ! ! In the predictor-coupled mode, the resultant forcing terms "rufrc" -! and "rvfrc" are extrapolated forward in time, so they become -! centered effectively at time n+1/2. This is done using optimized +! and "rvfrc" are extrapolated forward in time, so they become +! centered effectively at time n+1/2. This is done using optimized ! Adams-Bashforth weights. In the code below, rufrc_bak(:,:,nstp) is ! at (n-1)time step, while rufrc_bak(:,:,3-nstp) is at (n-2). After ! its use as input, the latter is overwritten by the value at time @@ -1424,9 +1525,9 @@ cfwd0=1.5_r8 cfwd1=-0.5_r8 cfwd2=0.0_r8 - ELSE - cfwd2=0.281105_r8 - cfwd1=-0.5_r8-2.0_r8*cfwd2 + ELSE + cfwd2=0.281105_r8 + cfwd1=-0.5_r8-2.0_r8*cfwd2 cfwd0=1.5_r8+cfwd2 END IF ! @@ -2026,7 +2127,7 @@ ! Exchange halo tile information. !----------------------------------------------------------------------- ! - IF (EWperiodic(ng).or.NSperiodic(ng)) THEN + IF (EWperiodic(ng).or.NSperiodic(ng)) THEN CALL exchange_r2d_tile (ng, tile, & & LBi, UBi, LBj, UBj, & & zeta(:,:,knew)) diff --git a/ROMS/Nonlinear/step2d_FB_LF_AM3.h b/ROMS/Nonlinear/step2d_FB_LF_AM3.h index 5b8461a39..339c6074b 100644 --- a/ROMS/Nonlinear/step2d_FB_LF_AM3.h +++ b/ROMS/Nonlinear/step2d_FB_LF_AM3.h @@ -31,7 +31,7 @@ #endif USE mod_forces USE mod_grid -#if defined UV_VIS2 +#if defined UV_VIS2 || defined WEC_MELLOR USE mod_mixing #endif USE mod_ncparam @@ -126,6 +126,14 @@ #if defined SEDIMENT && defined SED_MORPH & SEDBED(ng) % bed_thick, & #endif +#ifdef WEC_MELLOR + & MIXING(ng) % rustr2d, & + & MIXING(ng) % rvstr2d, & + & OCEAN(ng) % rulag2d, & + & OCEAN(ng) % rvlag2d, & + & OCEAN(ng) % ubar_stokes, & + & OCEAN(ng) % vbar_stokes, & +#endif #if defined TIDE_GENERATING_FORCES && !defined SOLVE3D & OCEAN(ng) % eq_tide, & #endif @@ -203,6 +211,11 @@ #if defined SEDIMENT && defined SED_MORPH & bed_thick, & #endif +#ifdef WEC_MELLOR + & rustr2d, rvstr2d, & + & rulag2d, rvlag2d, & + & ubar_stokes, vbar_stokes, & +#endif #if defined TIDE_GENERATING_FORCES && !defined SOLVE3D & eq_tide, & #endif @@ -286,6 +299,14 @@ # if defined SEDIMENT && defined SED_MORPH real(r8), intent(in ) :: bed_thick(LBi:,LBj:,:) # endif +# ifdef WEC_MELLOR + real(r8), intent(in ) :: rustr2d(LBi:,LBj:) + real(r8), intent(in ) :: rvstr2d(LBi:,LBj:) + real(r8), intent(in ) :: rulag2d(LBi:,LBj:) + real(r8), intent(in ) :: rvlag2d(LBi:,LBj:) + real(r8), intent(in ) :: ubar_stokes(LBi:,LBj:) + real(r8), intent(in ) :: vbar_stokes(LBi:,LBj:) +# endif # if defined TIDE_GENERATING_FORCES && !defined SOLVE3D real(r8), intent(in ) :: eq_tide(LBi:,LBj:) # endif @@ -388,6 +409,14 @@ # if defined SEDIMENT && defined SED_MORPH real(r8), intent(in ) :: bed_thick(LBi:UBi,LBj:UBj,1:3) # endif +# ifdef WEC_MELLOR + real(r8), intent(in ) :: rustr2d(LBi:UBi,LBj:UBj) + real(r8), intent(in ) :: rvstr2d(LBi:UBi,LBj:UBj) + real(r8), intent(in ) :: rulag2d(LBi:UBi,LBj:UBj) + real(r8), intent(in ) :: rvlag2d(LBi:UBi,LBj:UBj) + real(r8), intent(in ) :: ubar_stokes(LBi:UBi,LBj:UBj) + real(r8), intent(in ) :: vbar_stokes(LBi:UBi,LBj:UBj) +# endif # if defined TIDE_GENERATING_FORCES && !defined SOLVE3D real(r8), intent(in ) :: eq_tide(LBi:UBi,LBj:UBj) # endif @@ -540,8 +569,8 @@ IF (FIRST_2D_STEP) THEN kbak=kstp ! "kbak" is used as "from" ELSE ! time index for LF timestep - kbak=3-kstp - END IF + kbak=3-kstp + END IF ! !----------------------------------------------------------------------- ! Preliminary steps. @@ -717,7 +746,7 @@ ! "rufrc, rvfrc" are finalized, a correction term based on the ! difference zeta_new(:,:)-zeta(:,:,kstp) to "rubar, rvbar" to make ! them consistent with generalized RK2 stepping for pressure gradient -! terms. +! terms. ! IF (PREDICTOR_2D_STEP) THEN IF (FIRST_2D_STEP) THEN ! Modified RK2 time step (with @@ -874,7 +903,7 @@ #ifdef SOLVE3D ! ! Notice that we are suppressing the computation of momentum advection, -! Coriolis, and lateral viscosity terms in 3D Applications because +! Coriolis, and lateral viscosity terms in 3D Applications because ! these terms are already included in the baroclinic-to-barotropic ! forcing arrays "rufrc" and "rvfrc". It does not mean we are entirely ! omitting them, but it is a choice between recomputing them at every @@ -995,6 +1024,10 @@ UFx(i,j)=0.25_r8* & & (DUon(i,j)+DUon(i+1,j))* & & (ubar(i ,j,krhs)+ & +# ifdef WEC_MELLOR + & ubar_stokes(i ,j)+ & + & ubar_stokes(i+1,j)+ & +# endif & ubar(i+1,j,krhs)) END DO END DO @@ -1004,6 +1037,10 @@ UFe(i,j)=0.25_r8* & & (DVom(i,j)+DVom(i-1,j))* & & (ubar(i,j ,krhs)+ & +# ifdef WEC_MELLOR + & ubar_stokes(i,j )+ & + & ubar_stokes(i,j-1)+ & +# endif & ubar(i,j-1,krhs)) END DO END DO @@ -1013,6 +1050,10 @@ VFx(i,j)=0.25_r8* & & (DUon(i,j)+DUon(i,j-1))* & & (vbar(i ,j,krhs)+ & +# ifdef WEC_MELLOR + & vbar_stokes(i ,j)+ & + & vbar_stokes(i-1,j)+ & +# endif & vbar(i-1,j,krhs)) END DO END DO @@ -1022,6 +1063,10 @@ VFe(i,j)=0.25_r8* & & (DVom(i,j)+DVom(i,j+1))* & & (vbar(i,j ,krhs)+ & +# ifdef WEC_MELLOR + & vbar_stokes(i,j )+ & + & vbar_stokes(i,j+1)+ & +# endif & vbar(i,j+1,krhs)) END DO END DO @@ -1033,6 +1078,10 @@ DO j=Jstr,Jend DO i=IstrUm1,Iendp1 grad (i,j)=ubar(i-1,j,krhs)-2.0_r8*ubar(i,j,krhs)+ & +# ifdef WEC_MELLOR + & ubar_stokes(i-1,j)-2.0_r8*ubar_stokes(i,j)+ & + & ubar_stokes(i+1,j)+ & +# endif & ubar(i+1,j,krhs) Dgrad(i,j)=DUon(i-1,j)-2.0_r8*DUon(i,j)+DUon(i+1,j) END DO @@ -1058,6 +1107,10 @@ DO j=Jstr,Jend DO i=IstrU-1,Iend UFx(i,j)=0.25_r8*(ubar(i ,j,krhs)+ & +# ifdef WEC_MELLOR + & ubar_stokes(i ,j)+ & + & ubar_stokes(i+1,j)+ & +# endif & ubar(i+1,j,krhs)- & & cff*(grad (i,j)+grad (i+1,j)))* & & (DUon(i,j)+DUon(i+1,j)- & @@ -1068,6 +1121,10 @@ DO j=Jstrm1,Jendp1 DO i=IstrU,Iend grad(i,j)=ubar(i,j-1,krhs)-2.0_r8*ubar(i,j,krhs)+ & +# ifdef WEC_MELLOR + & ubar_stokes(i,j-1)-2.0_r8*ubar_stokes(i,j)+ & + & ubar_stokes(i,j+1)+ & +# endif & ubar(i,j+1,krhs) END DO END DO @@ -1096,6 +1153,10 @@ DO j=Jstr,Jend+1 DO i=IstrU,Iend UFe(i,j)=0.25_r8*(ubar(i,j ,krhs)+ & +# ifdef WEC_MELLOR + & ubar_stokes(i,j )+ & + & ubar_stokes(i,j-1)+ & +# endif & ubar(i,j-1,krhs)- & & cff*(grad (i,j)+grad (i,j-1)))* & & (DVom(i,j)+DVom(i-1,j)- & @@ -1108,6 +1169,10 @@ DO j=JstrV,Jend DO i=Istrm1,Iendp1 grad(i,j)=vbar(i-1,j,krhs)-2.0_r8*vbar(i,j,krhs)+ & +# ifdef WEC_MELLOR + & vbar_stokes(i-1,j)-2.0_r8*vbar_stokes(i,j)+ & + & vbar_stokes(i+1,j)+ & +# endif & vbar(i+1,j,krhs) END DO END DO @@ -1136,6 +1201,10 @@ DO j=JstrV,Jend DO i=Istr,Iend+1 VFx(i,j)=0.25_r8*(vbar(i ,j,krhs)+ & +# ifdef WEC_MELLOR + & vbar_stokes(i ,j)+ & + & vbar_stokes(i-1,j)+ & +# endif & vbar(i-1,j,krhs)- & & cff*(grad (i,j)+grad (i-1,j)))* & & (DUon(i,j)+DUon(i,j-1)- & @@ -1146,6 +1215,10 @@ DO j=JstrVm1,Jendp1 DO i=Istr,Iend grad(i,j)=vbar(i,j-1,krhs)-2.0_r8*vbar(i,j,krhs)+ & +# ifdef WEC_MELLOR + & vbar_stokes(i,j-1)-2.0_r8*vbar_stokes(i,j)+ & + & vbar_stokes(i,j+1)+ & +# endif & vbar(i,j+1,krhs) Dgrad(i,j)=DVom(i,j-1)-2.0_r8*DVom(i,j)+DVom(i,j+1) END DO @@ -1171,6 +1244,10 @@ DO j=JstrV-1,Jend DO i=Istr,Iend VFe(i,j)=0.25_r8*(vbar(i,j ,krhs)+ & +# ifdef WEC_MELLOR + & vbar_stokes(i,j )+ & + & vbar_stokes(i,j+1)+ & +# endif & vbar(i,j+1,krhs)- & & cff*(grad (i,j)+grad (i,j+1)))* & & (DVom(i,j)+DVom(i,j+1)- & @@ -1210,7 +1287,7 @@ END DO #endif -#if (defined UV_COR & !defined SOLVE3D) || defined STEP2D_CORIOLIS +#if (defined UV_COR & !defined SOLVE3D) || defined STEP2D_CORIOLIS ! !----------------------------------------------------------------------- ! Add in Coriolis term. @@ -1220,8 +1297,16 @@ DO i=IstrU-1,Iend cff=0.5_r8*Drhs(i,j)*fomn(i,j) UFx(i,j)=cff*(vbar(i,j ,krhs)+ & +# ifdef WEC_MELLOR + & vbar_stokes(i,j )+ & + & vbar_stokes(i,j+1)+ & +# endif & vbar(i,j+1,krhs)) VFe(i,j)=cff*(ubar(i ,j,krhs)+ & +# ifdef WEC_MELLOR + & ubar_stokes(i ,j)+ & + & ubar_stokes(i+1,j)+ & +# endif & ubar(i+1,j,krhs)) END DO END DO @@ -1256,8 +1341,16 @@ DO j=JstrV-1,Jend DO i=IstrU-1,Iend cff1=0.5_r8*(vbar(i,j ,krhs)+ & +# ifdef WEC_MELLOR + & vbar_stokes(i,j )+ & + & vbar_stokes(i,j+1)+ & +# endif & vbar(i,j+1,krhs)) cff2=0.5_r8*(ubar(i ,j,krhs)+ & +# ifdef WEC_MELLOR + & ubar_stokes(i ,j)+ & + & ubar_stokes(i+1,j)+ & +# endif & ubar(i+1,j,krhs)) cff3=cff1*dndx(i,j) cff4=cff2*dmde(i,j) @@ -1887,7 +1980,7 @@ #ifdef SOLVE3D ! !----------------------------------------------------------------------- -! Finalize computation of barotropic mode averages. +! Finalize computation of barotropic mode averages. !----------------------------------------------------------------------- ! ! This procedure starts with filling in boundary rows of total depths @@ -2054,7 +2147,7 @@ ! Exchange boundary information. !----------------------------------------------------------------------- ! - IF (EWperiodic(ng).or.NSperiodic(ng)) THEN + IF (EWperiodic(ng).or.NSperiodic(ng)) THEN CALL exchange_r2d_tile (ng, tile, & & LBi, UBi, LBj, UBj, & & zeta(:,:,knew)) diff --git a/ROMS/Representer/rp_main2d.F b/ROMS/Representer/rp_main2d.F index 4f8493d93..65b25e409 100644 --- a/ROMS/Representer/rp_main2d.F +++ b/ROMS/Representer/rp_main2d.F @@ -9,11 +9,19 @@ SUBROUTINE rp_main2d (RunInterval) ! See License_ROMS.md ! !======================================================================= ! ! -! This routine is the main driver for representers tangent linear ! -! ROMS when configure as shallow water (barotropic ) ocean ! -! model only. It advances advances forward the representer model ! -! for all nested grids, if any, by the specified time interval ! -! (seconds), RunInterval. ! +! This routine is the main driver for ROMS finite amplitude ! +! tangent linear (Representers) model (RPM) when configured as a ! +! 2D barotropic shallow water ocean model. It advances advances ! +! forward the RPM for all nested grids, if any, by the specified ! +! time interval (seconds), RunInterval. ! +! ! +# if defined STEP2D_FB_LF_AM3 +! Numerical 2D time-stepping kernel: FB AB3-AM4 ! +# elif defined STEP2D_FB_LF_AM3 +! Numerical 2D time-stepping kernel: FB LF-AM3 ! +# else +! Numerical 2D time-stepping kernel: LF-AM3 (Legacy scheme) ! +# endif ! ! !======================================================================= ! @@ -23,6 +31,9 @@ SUBROUTINE rp_main2d (RunInterval) USE mod_coupler # endif USE mod_iounits +# ifdef NESTING + USE mod_nesting +# endif USE mod_scalars USE mod_stepping ! @@ -53,16 +64,12 @@ SUBROUTINE rp_main2d (RunInterval) # ifdef FLOATS_NOT_YET !! USE rp_step_floats_mod, ONLY : rp_step_floats # endif -# ifdef WEAK_CONSTRAINT +# if defined WEAK_CONSTRAINT || defined FORCING_SV USE tl_forcing_mod, ONLY : tl_forcing # endif # ifdef RP_AVERAGES USE rp_set_avg_mod, ONLY : tl_set_avg # endif -# if defined PROPAGATOR || \ - (defined MASKING && (defined READ_WATER || defined WRITE_WATER)) - USE wpoints_mod, ONLY : wpoints -# endif ! implicit none ! @@ -72,13 +79,14 @@ SUBROUTINE rp_main2d (RunInterval) ! ! Local variable declarations. ! - integer :: ng, tile + logical :: DoNestLayer, Time_Step +! + integer :: Nsteps, Rsteps + integer :: ig, il, istep, ng, nl, tile integer :: next_indx1 # ifdef FLOATS_NOT_YET integer :: Lend, Lstr, chunk_size # endif -! - real(r8) :: MaxDT, my_StepTime ! character (len=*), parameter :: MyFile = & & __FILE__ @@ -87,49 +95,72 @@ SUBROUTINE rp_main2d (RunInterval) ! Time-step tangent linear vertically integrated equations. !======================================================================= ! - my_StepTime=0.0_r8 - MaxDT=MAXVAL(dt) - - STEP_LOOP : DO WHILE (my_StepTime.le.(RunInterval+0.5_r8*MaxDT)) - - my_StepTime=my_StepTime+MaxDT +! Time-step the 3D kernel for the specified time interval (seconds), +! RunInterval. ! -! Set time clock. + Time_Step=.TRUE. + DoNestLayer=.TRUE. ! - DO ng=1,Ngrids - iic(ng)=iic(ng)+1 -!$OMP MASTER - time(ng)=time(ng)+dt(ng) - tdays(ng)=time(ng)*sec2day - CALL time_string (time(ng), time_code(ng)) -!$OMP END MASTER - END DO -!$OMP BARRIER + KERNEL_LOOP : DO WHILE (Time_Step) +! +! In nesting applications, the number of nesting layers (NestLayers) is +! used to facilitate refinement grids and composite/refinament grids +! combinations. Otherwise, the solution it is looped once for a single +! grid application (NestLayers = 1). +! + nl=0 +# ifdef NESTING + TwoWayInterval(1:Ngrids)=0.0_r8 +# endif +! + NEST_LAYER : DO WHILE (DoNestLayer) +! +! Determine number of time steps to compute in each nested grid layer +! based on the specified time interval (seconds), RunInterval. Non +! nesting applications have NestLayers=1. Notice that RunInterval is +! set in the calling driver. Its value may span the full period of the +! simulation, a multi-model coupling interval (RunInterval > ifac*dt), +! or just a single step (RunInterval=0). +! + CALL ntimesteps (iRPM, RunInterval, nl, Nsteps, Rsteps) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + IF ((nl.le.0).or.(nl.gt.NestLayers)) EXIT +! +! Time-step governing equations for Nsteps. +! + STEP_LOOP : DO istep=1,Nsteps +! +! Set time indices and time clock. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + tdays(ng)=time(ng)*sec2day + IF (step_counter(ng).eq.Rsteps) Time_Step=.FALSE. + END DO ! !----------------------------------------------------------------------- ! Read in required data, if any, from input NetCDF files. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids -!$OMP MASTER - CALL rp_get_data (ng) -!$OMP END MASTER -!$OMP BARRIER - IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN - END DO + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + CALL rp_get_data (ng) + IF (FoundError(exit_flag, NoError, & + & __LINE__, MyFile)) RETURN + END DO ! !----------------------------------------------------------------------- ! If applicable, process input data: time interpolate between data ! snapshots. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 - CALL rp_set_data (ng, tile) - END DO -!$OMP BARRIER - END DO - IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=first_tile(ng),last_tile(ng),+1 + CALL rp_set_data (ng, tile) + END DO + END DO + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN # ifdef WEAK_CONSTRAINT ! @@ -141,39 +172,47 @@ SUBROUTINE rp_main2d (RunInterval) ! snapshots (FrequentImpulse=TRUE). !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (FrequentImpulse(ng)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL tl_forcing (ng, tile, kstp(ng), nstp(ng)) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (FrequentImpulse(ng)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL tl_forcing (ng, tile, kstp(ng), nstp(ng)) + END DO + END IF END DO -!$OMP BARRIER - END IF - END DO # endif ! !----------------------------------------------------------------------- -! If not a restart, initialize all time levels and compute other -! initial fields. +! Initialize all time levels and compute other initial fields. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (iic(ng).eq.ntstart(ng)) THEN + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (iic(ng).eq.ntstart(ng)) THEN ! ! Initialize free-surface. ! - DO tile=first_tile(ng),last_tile(ng),+1 - CALL rp_ini_zeta (ng, tile, iRPM) - END DO -!$OMP BARRIER + DO tile=first_tile(ng),last_tile(ng),+1 + CALL rp_ini_zeta (ng, tile, iRPM) + END DO ! ! Initialize other state variables. ! - DO tile=last_tile(ng),first_tile(ng),-1 - CALL rp_ini_fields (ng, tile, iRPM) + DO tile=last_tile(ng),first_tile(ng),-1 + CALL rp_ini_fields (ng, tile, iRPM) + END DO + +# ifdef NESTING +! +! Extract donor grid initial data at contact points and store it in +! REFINED structure so it can be used for the space-time interpolation. +! + IF (RefinedGrid(ng)) THEN + CALL rp_nesting (ng, iRPM, ngetD) + END IF +# endif + END IF END DO -!$OMP BARRIER - END IF - END DO ! !----------------------------------------------------------------------- ! Compute and report diagnostics. If appropriate, accumulate time- @@ -181,38 +220,39 @@ SUBROUTINE rp_main2d (RunInterval) ! jobs. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 ! irreversible + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=first_tile(ng),last_tile(ng),+1 ! irreversible # ifdef RP_AVERAGES - CALL tl_set_avg (ng, tile) + CALL tl_set_avg (ng, tile) # endif # ifdef DIAGNOSTICS -!! CALL rp_set_diags (ng, tile) +!! CALL rp_set_diags (ng, tile) # endif # ifdef TIDE_GENERATING_FORCES - CALL equilibrium_tide (ng, tile, iRPM) + CALL equilibrium_tide (ng, tile, iRPM) # endif - CALL rp_diag (ng, tile) - END DO -!$OMP BARRIER - END DO + CALL rp_diag (ng, tile) + END DO + END DO + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN # if defined ATM_COUPLING_NOT_YET && defined MCT_LIB ! !----------------------------------------------------------------------- -! Couple to atmospheric model every CoupleSteps(Iatmos) timesteps: get -! air/sea fluxes. +! Couple ocean to atmosphere model every "CoupleSteps(Iatmos)" +! timesteps: get air/sea fluxes. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF ((iic(ng).ne.ntstart(ng)).and. & - & MOD(iic(ng)-1,CoupleSteps(Iatmos,ng)).eq.0) THEN - DO tile=last_tile(ng),first_tile(ng),-1 - CALL ocn2atm_coupling (ng, tile) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF ((iic(ng).ne.ntstart(ng)).and. & + & MOD(iic(ng),CoupleSteps(Iatmos,ng)).eq.0) THEN + DO tile=last_tile(ng),first_tile(ng),-1 + CALL ocn2atm_coupling (ng, tile) + END DO + END IF END DO -!$OMP BARRIER - END IF - END DO # endif # if defined WAV_COUPLING_NOT_YET && defined MCT_LIB @@ -254,14 +294,14 @@ SUBROUTINE rp_main2d (RunInterval) ! Skip the last output timestep. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (iic(ng).lt.(ntend(ng)+1)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL rp_obc_adjust (ng, tile, Lbinp(ng)) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (iic(ng).lt.(ntend(ng)+1)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL rp_obc_adjust (ng, tile, Lbinp(ng)) + END DO + END IF END DO -!$OMP BARRIER - END IF - END DO # endif # ifdef ADJUST_WSTRESS @@ -271,14 +311,73 @@ SUBROUTINE rp_main2d (RunInterval) ! Skip the last output timestep. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (iic(ng).lt.(ntend(ng)+1)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL rp_frc_adjust (ng, tile, Lfinp(ng)) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (iic(ng).lt.(ntend(ng)+1)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL rp_frc_adjust (ng, tile, Lfinp(ng)) + END DO + END IF + END DO +# endif + +# if defined WAV_COUPLING_NOT_YET && defined MCT_LIB +! +!----------------------------------------------------------------------- +! Couple ocean to waves model every "CoupleSteps(Iwaves)" +! timesteps: get waves/sea fluxes. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF ((iic(ng).ne.ntstart(ng)).and. & + & MOD(iic(ng)-1,CoupleSteps(Iwaves,ng)).eq.0) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ocn2wav_coupling (ng, tile) + END DO + END IF + END DO +# endif + +# ifdef WEC_MELLOR_NOT_YET +! +!----------------------------------------------------------------------- +! Compute radiation stress terms. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=last_tile(ng),first_tile(ng),-1 + CALL rp_radiation_stress (ng, tile) + END DO + END DO +# endif +! +!----------------------------------------------------------------------- +! Set vertical boundary conditions. Process tidal forcing. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=first_tile(ng),last_tile(ng),+1 + CALL tl_set_vbc (ng, tile) +# if defined SSH_TIDES_NOT_YET || defined UV_TIDES_NOT_YET + CALL tl_set_tides (ng, tile) +# endif + END DO + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for bottom stress variables. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL rp_nesting (ng, iRPM, nbstr) + END IF END DO -!$OMP BARRIER - END IF - END DO # endif ! !----------------------------------------------------------------------- @@ -287,69 +386,255 @@ SUBROUTINE rp_main2d (RunInterval) ! time step. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids -!$OMP MASTER - CALL rp_output (ng) -!$OMP END MASTER -!$OMP BARRIER - IF ((FoundError(exit_flag, NoError, __LINE__, MyFile)).or. & - & ((iic(ng).eq.(ntend(ng)+1)).and.(ng.eq.Ngrids))) RETURN - END DO + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + CALL rp_output (ng) + IF ((FoundError(exit_flag, NoError, __LINE__, MyFile)).or.& + & ((iic(ng).eq.(ntend(ng)+1)).and.(ng.eq.Ngrids))) THEN + RETURN + END IF + END DO + +# ifdef NESTING ! !----------------------------------------------------------------------- -! Solve the vertically integrated primitive equations for the -! free-surface and momentum components. +! If refinement grid, interpolate (space, time) state variables +! contact points from donor grid extracted data. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (RefinedGrid(ng).and.(RefineScale(ng).gt.0)) THEN + CALL rp_nesting (ng, iRPM, nputD) + END IF + END DO +# endif + +# ifdef STEP2D_FB_AB3_AM4 +! +!----------------------------------------------------------------------- +! Solve representers vertically integrated primitive equations for +! free-surface and momentum components using a generalized Forward- +! Backward, 3rd-order Adams-Bashforth / 4th-order Adams-Moulton +! (FB AB3-AM4) time stepping scheme (Shchepetkin and McWilliams, +! 2009). +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + iif(ng)=1 + nfast(ng)=1 + kstp(ng)=knew(ng) + knew(ng)=kstp(ng)+1 + IF (knew(ng).gt.4) knew(ng)=1 + IF (MOD(knew(ng),2).eq.0) THEN ! zig-zag + DO tile=first_tile(ng),last_tile(ng),+1 ! processing + CALL rp_step2d (ng, tile) ! sequence + END DO + ELSE + DO tile=last_tile(ng),first_tile(ng),-1 + CALL rp_step2d (ng, tile) + END DO + END IF + END DO + +# else + +# ifdef STEP2D_FB_LF_AM3 +! +!----------------------------------------------------------------------- +! Solve representers vertically integrated primitive equations for +! free-surface and momentum components using a predictor-corrector +! LeapFrog / 3rd-order Adams-Moulton with a Forward-Backward +! feeback (FB LF-AM3) stepping scheme (Shchepetkin and McWilliams, +! 2009). +!----------------------------------------------------------------------- +! +! Predictor LF substep with FB-feedback. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + iif(ng)=1 + nfast(ng)=1 + kstp(ng)=next_kstp(ng) + knew(ng)=3 + + DO tile=last_tile(ng),first_tile(ng),-1 + CALL rp_step2d (ng, tile) + END DO + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine PREDICTOR STEP section. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL rp_nesting (ng, iRPM, n2dPS) + END IF + END DO +# endif +! +! Corrector AM3 substep with FB-feedback. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + knew(ng)=3-kstp(ng) + next_kstp(ng)=knew(ng) + + DO tile=first_tile(ng),last_tile(ng),+1 + CALL rp_step2d (ng, tile) + END DO + END DO + +# else +! +!----------------------------------------------------------------------- +! Solve representers vertically integrated primitive equations for +! free-surface and momentum components using a predictor-corrector +! LeapFrog with 3rd-order Adams-Moulton (LF-AM3) time stepping scheme +! (ROMS legacy 2D kernel). !----------------------------------------------------------------------- ! ! Set time indices for predictor step. The PREDICTOR_2D_STEP switch ! it is assumed to be false before the first time-step. ! - DO ng=1,Ngrids - iif(ng)=1 - nfast(ng)=1 - next_indx1=3-indx1(ng) - IF (.not.PREDICTOR_2D_STEP(ng)) THEN - PREDICTOR_2D_STEP(ng)=.TRUE. - IF (FIRST_2D_STEP) THEN - kstp(ng)=indx1(ng) - ELSE - kstp(ng)=3-indx1(ng) - END IF - knew(ng)=3 - krhs(ng)=indx1(ng) - END IF + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + iif(ng)=1 + nfast(ng)=1 + next_indx1=3-indx1(ng) + IF (.not.PREDICTOR_2D_STEP(ng)) THEN + PREDICTOR_2D_STEP(ng)=.TRUE. + IF (FIRST_2D_STEP) THEN + kstp(ng)=indx1(ng) + ELSE + kstp(ng)=3-indx1(ng) + END IF + knew(ng)=3 + krhs(ng)=indx1(ng) + END IF ! ! Predictor step - Advance barotropic equations using 2D time-step ! ============== predictor scheme. ! - DO tile=last_tile(ng),first_tile(ng),-1 - CALL rp_step2d (ng, tile) - END DO -!$OMP BARRIER - END DO + DO tile=last_tile(ng),first_tile(ng),-1 + CALL rp_step2d (ng, tile) + END DO + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine PREDICTOR STEP section. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL rp_nesting (ng, iRPM, n2dPS) + END IF + END DO +# endif ! ! Set time indices for corrector step. ! - DO ng=1,Ngrids - IF (PREDICTOR_2D_STEP(ng)) THEN - PREDICTOR_2D_STEP(ng)=.FALSE. - knew(ng)=next_indx1 - kstp(ng)=3-knew(ng) - krhs(ng)=3 - IF (iif(ng).lt.(nfast(ng)+1)) indx1(ng)=next_indx1 - END IF + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (PREDICTOR_2D_STEP(ng)) THEN + PREDICTOR_2D_STEP(ng)=.FALSE. + knew(ng)=next_indx1 + kstp(ng)=3-knew(ng) + krhs(ng)=3 + IF (iif(ng).lt.(nfast(ng)+1)) indx1(ng)=next_indx1 + END IF ! ! Corrector step - Apply 2D time-step corrector scheme. Notice that ! ============== there is not need for a corrector step during the ! auxiliary (nfast+1) time-step. ! - IF (iif(ng).lt.(nfast(ng)+1)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL rp_step2d (ng, tile) + IF (iif(ng).lt.(nfast(ng)+1)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL rp_step2d (ng, tile) + END DO + END IF END DO -!$OMP BARRIER - END IF - END DO +# endif + +# endif + +# ifdef NESTING +# if defined MASKING && defined WET_DRY +! +!----------------------------------------------------------------------- +! If nesting and wetting and drying, scale horizontal interpolation +! weights to account for land/sea masking in contact areas. This needs +! to be done at very time-step since the Land/Sea masking is time +! dependent. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + CALL rp_nesting (ng, iRPM, nmask) + END DO +# endif +! +!----------------------------------------------------------------------- +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine CORRECTOR STEP section (KNEW INDEX). +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL rp_nesting (ng, iRPM, n2dCS) + END IF + END DO +# endif + +# ifdef NESTING +# ifndef ONE_WAY +! +!----------------------------------------------------------------------- +! If refinement grids, perform two-way coupling between fine and +! coarse grids. Correct coarse grid tracers values at the refinement +! grid with refined accumulated fluxes. Then, replace coarse grid +! state variable with averaged refined grid values (two-way nesting). +! Update coarse grid depth variables. +! +! The two-way exchange of infomation between nested grids needs to be +! done at the correct time-step and in the right sequence. +!----------------------------------------------------------------------- +! + DO il=NestLayers,1,-1 + DO ig=1,GridsInLayer(il) + ng=GridNumber(ig,il) + IF (do_twoway(iNLM, nl, il, ng, istep)) THEN + CALL rp_nesting (ng, iRPM, n2way) + END IF + END DO + END DO +# endif +! +!----------------------------------------------------------------------- +! If donor to a finer grid, extract data for the external contact +! points. This is the latest solution for the coarser grid. +! +! It is stored in the REFINED structure so it can be used for the +! space-time interpolation. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (DonorToFiner(ng)) THEN + CALL rp_nesting (ng, iRPM, ngetD) + END IF + END DO +# endif # ifdef FLOATS_NOT_YET ! @@ -361,31 +646,48 @@ SUBROUTINE rp_main2d (RunInterval) ! variables do not have a global scope. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (Lfloats(Ng)) THEN + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (Lfloats(ng)) THEN # ifdef _OPENMP - chunk_size=(Nfloats(ng)+numthreads-1)/numthreads - Lstr=1+Mythread*chunk_size - Lend=MIN(Nfloats(ng),Lstr+chunk_size-1) + chunk_size=(Nfloats(ng)+numthreads-1)/numthreads + Lstr=1+MyThread*chunk_size + Lend=MIN(Nfloats(ng),Lstr+chunk_size-1) # else - Lstr=1 - Lend=Nfloats(ng) + Lstr=1 + Lend=Nfloats(ng) # endif - CALL rp_step_floats (ng, Lstr, Lend) -!$OMP BARRIER + CALL rp_step_floats (ng, Lstr, Lend) ! ! Shift floats time indices. ! - nfp1(ng)=MOD(nfp1(ng)+1,NFT+1) - nf (ng)=MOD(nf (ng)+1,NFT+1) - nfm1(ng)=MOD(nfm1(ng)+1,NFT+1) - nfm2(ng)=MOD(nfm2(ng)+1,NFT+1) - nfm3(ng)=MOD(nfm3(ng)+1,NFT+1) - END IF - END DO + nfp1(ng)=MOD(nfp1(ng)+1,NFT+1) + nf (ng)=MOD(nf (ng)+1,NFT+1) + nfm1(ng)=MOD(nfm1(ng)+1,NFT+1) + nfm2(ng)=MOD(nfm2(ng)+1,NFT+1) + nfm3(ng)=MOD(nfm3(ng)+1,NFT+1) + END IF + END DO # endif - END DO STEP_LOOP +! +!----------------------------------------------------------------------- +! Advance time index and time clock. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + iic(ng)=iic(ng)+1 + time(ng)=time(ng)+dt(ng) + step_counter(ng)=step_counter(ng)-1 + CALL time_string (time(ng), time_code(ng)) + END DO + END DO STEP_LOOP + + END DO NEST_LAYER + + END DO KERNEL_LOOP +! RETURN END SUBROUTINE rp_main2d #else diff --git a/ROMS/Representer/rp_main3d.F b/ROMS/Representer/rp_main3d.F index 0ceedca9d..6bfb0ba72 100644 --- a/ROMS/Representer/rp_main3d.F +++ b/ROMS/Representer/rp_main3d.F @@ -9,11 +9,19 @@ SUBROUTINE rp_main3d (RunInterval) ! See License_ROMS.md ! !======================================================================= ! ! -! This routine is the main driver for representers tangent linear ! -! ROMS when configure as a full 3D baroclinic ocean model. ! -! It advances forward the representer model equations for all ! -! nested grids, if any, for the specified time interval (seconds), ! -! RunInterval. ! +! This routine is the main driver for ROMS finite amplitude ! +! tangent linear (Representers) model (RPM) when configure as a ! +! full 3D baroclinic ocean model. It advances forward the RPM for ! +! all nested grids, if any, for the specified time interval ! +! (seconds), RunInterval. ! +! ! +# if defined STEP2D_FB_LF_AM3 +! Numerical 2D time-stepping kernel: FB AB3-AM4 ! +# elif defined STEP2D_FB_LF_AM3 +! Numerical 2D time-stepping kernel: FB LF-AM3 ! +# else +! Numerical 2D time-stepping kernel: LF-AM3 (Legacy scheme) ! +# endif ! ! !======================================================================= ! @@ -23,6 +31,9 @@ SUBROUTINE rp_main3d (RunInterval) USE mod_coupler # endif USE mod_iounits +# ifdef NESTING + USE mod_nesting +# endif USE mod_scalars USE mod_stepping ! @@ -92,7 +103,9 @@ SUBROUTINE rp_main3d (RunInterval) !! USE rp_set_tides_mod, ONLY : rp_set_tides # endif USE rp_set_vbc_mod, ONLY : rp_set_vbc +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) USE rp_set_zeta_mod, ONLY : rp_set_zeta +# endif USE rp_step2d_mod, ONLY : rp_step2d # ifndef TS_FIXED USE rp_step3d_t_mod, ONLY : rp_step3d_t @@ -117,7 +130,10 @@ SUBROUTINE rp_main3d (RunInterval) ! ! Local variable declarations. ! - integer :: ng, tile + logical :: DoNestLayer, Time_Step + + integer :: Nsteps, Rsteps + integer :: ig, il, istep, ng, nl, tile integer :: my_iif, next_indx1 # ifdef FLOATS_NOT_YET integer :: Lend, Lstr, chunk_size @@ -132,55 +148,78 @@ SUBROUTINE rp_main3d (RunInterval) ! Time-step representers tangent linear 3D primitive equations. !======================================================================= ! - my_StepTime=0.0_r8 - MaxDT=MAXVAL(dt) - - STEP_LOOP : DO WHILE (my_StepTime.le.(RunInterval+0.5_r8*MaxDT)) - - my_StepTime=my_StepTime+MaxDT +! Time-step the 3D kernel for the specified time interval (seconds), +! RunInterval. +! + Time_Step=.TRUE. + DoNestLayer=.TRUE. +! + KERNEL_LOOP : DO WHILE (Time_Step) +! +! In nesting applications, the number of nesting layers (NestLayers) is +! used to facilitate refinement grids and composite/refinament grids +! combinations. Otherwise, the solution it is looped once for a single +! grid application (NestLayers = 1). +! + nl=0 +#ifdef NESTING + TwoWayInterval(1:Ngrids)=0.0_r8 +#endif +! + NEST_LAYER : DO WHILE (DoNestLayer) +! +! Determine number of time steps to compute in each nested grid layer +! based on the specified time interval (seconds), RunInterval. Non +! nesting applications have NestLayers=1. Notice that RunInterval is +! set in the calling driver. Its value may span the full period of the +! simulation, a multi-model coupling interval (RunInterval > ifac*dt), +! or just a single step (RunInterval=0). +! + CALL ntimesteps (iRPM, RunInterval, nl, Nsteps, Rsteps) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + IF ((nl.le.0).or.(nl.gt.NestLayers)) EXIT +! +! Time-step governing equations for Nsteps. +! + STEP_LOOP : DO istep=1,Nsteps ! ! Set time indices and time clock. ! - DO ng=1,Ngrids - iic(ng)=iic(ng)+1 - nstp(ng)=1+MOD(iic(ng)-ntstart(ng),2) - nnew(ng)=3-nstp(ng) - nrhs(ng)=nstp(ng) -!$OMP MASTER - time(ng)=time(ng)+dt(ng) - tdays(ng)=time(ng)*sec2day - CALL time_string (time(ng), time_code(ng)) -!$OMP END MASTER - END DO -!$OMP BARRIER + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + nstp(ng)=1+MOD(iic(ng)-ntstart(ng),2) + nnew(ng)=3-nstp(ng) + nrhs(ng)=nstp(ng) + tdays(ng)=time(ng)*sec2day + IF (step_counter(ng).eq.Rsteps) Time_Step=.FALSE. + END DO ! !----------------------------------------------------------------------- -! Read in required data, if any, data from input NetCDF files. +! Read in required data, if any, from input NetCDF files. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids -!$OMP MASTER - CALL rp_get_data (ng) -!$OMP END MASTER -!$OMP BARRIER - IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN - END DO + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + CALL rp_get_data (ng) + IF (FoundError(exit_flag, NoError, & + & __LINE__, MyFile)) RETURN + END DO ! !----------------------------------------------------------------------- ! If applicable, process input data: time interpolate between data ! snapshots. Compute BASIC STATE depths and thickness. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 - CALL rp_set_data (ng, tile) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=first_tile(ng),last_tile(ng),+1 + CALL rp_set_data (ng, tile) # ifdef FORWARD_READ - CALL set_depth (ng, tile, iRPM) + CALL set_depth (ng, tile, iRPM) # endif - END DO -!$OMP BARRIER - END DO - IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + END DO + END DO + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN # ifdef FORWARD_READ ! @@ -188,13 +227,14 @@ SUBROUTINE rp_main3d (RunInterval) ! Compute BASIC STATE horizontal mass fluxes (Hz*u/n and Hz*v/m). !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=last_tile(ng),first_tile(ng),-1 - CALL set_massflux (ng, tile, iRPM) - END DO -!$OMP BARRIER - END DO + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=last_tile(ng),first_tile(ng),-1 + CALL set_massflux (ng, tile, iRPM) + END DO + END DO # endif + # ifdef WEAK_CONSTRAINT ! !----------------------------------------------------------------------- @@ -205,14 +245,14 @@ SUBROUTINE rp_main3d (RunInterval) ! snapshots (FrequentImpulse=TRUE). !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (FrequentImpulse(ng)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL tl_forcing (ng, tile, kstp(ng), nstp(ng)) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (FrequentImpulse(ng)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL tl_forcing (ng, tile, kstp(ng), nstp(ng)) + END DO + END IF END DO -!$OMP BARRIER - END IF - END DO # endif ! !----------------------------------------------------------------------- @@ -222,11 +262,14 @@ SUBROUTINE rp_main3d (RunInterval) ! and applies lateral boundary conditions. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (iic(ng).eq.ntstart(ng)) THEN - CALL rp_post_initial (ng, iRPM) - END IF - END DO + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (iic(ng).eq.ntstart(ng)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL rp_post_initial (ng, iRPM) + END DO + END IF + END DO ! !----------------------------------------------------------------------- ! Compute horizontal mass fluxes (Hz*u/n and Hz*v/m), density related @@ -234,23 +277,23 @@ SUBROUTINE rp_main3d (RunInterval) ! vertical velocity. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 - CALL rp_set_massflux (ng, tile, iRPM) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=first_tile(ng),last_tile(ng),+1 + CALL rp_set_massflux (ng, tile, iRPM) # ifndef TS_FIXED - CALL rp_rho_eos (ng, tile, iRPM) + CALL rp_rho_eos (ng, tile, iRPM) # endif # ifdef TIDE_GENERATING_FORCES - CALL equilibrium_tide (ng, tile, iTLM) + CALL equilibrium_tide (ng, tile, iRPM) # endif - CALL rp_diag (ng, tile) + CALL rp_diag (ng, tile) # ifdef FORWARD_READ - CALL omega (ng, tile, iRPM) + CALL omega (ng, tile, iRPM) # endif - END DO -!$OMP BARRIER - END DO - IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + END DO + END DO + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN # if defined ATM_COUPLING_NOT_YET && defined MCT_LIB ! @@ -259,15 +302,15 @@ SUBROUTINE rp_main3d (RunInterval) ! air/sea fluxes. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF ((iic(ng).ne.ntstart(ng)).and. & - & MOD(iic(ng)-1,CoupleSteps(Iatmos,ng)).eq.0) THEN - DO tile=last_tile(ng),first_tile(ng),-1 - CALL ocn2atm_coupling (ng, tile) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF ((iic(ng).ne.ntstart(ng)).and. & + & MOD(iic(ng)-1,CoupleSteps(Iatmos,ng)).eq.0) THEN + DO tile=last_tile(ng),first_tile(ng),-1 + CALL ocn2atm_coupling (ng, tile) + END DO + END IF END DO -!$OMP BARRIER - END IF - END DO # endif # if defined WAV_COUPLING_NOT_YET && defined MCT_LIB @@ -277,15 +320,15 @@ SUBROUTINE rp_main3d (RunInterval) ! waves/sea fluxes. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF ((iic(ng).ne.ntstart(ng)).and. & - & MOD(iic(ng),CoupleSteps(Iwaves,ng)).eq.0) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL ocn2wav_coupling (ng, tile) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF ((iic(ng).ne.ntstart(ng)).and. & + & MOD(iic(ng)-1,CoupleSteps(Iwaves,ng)).eq.0) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ocn2wav_coupling (ng, tile) + END DO + END IF END DO -!$OMP BARRIER - END IF - END DO # endif ! !----------------------------------------------------------------------- @@ -293,21 +336,34 @@ SUBROUTINE rp_main3d (RunInterval) ! if any. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=first_tile(ng),last_tile(ng),+1 # if defined BULK_FLUXES_NOT_YET && !defined PRIOR_BULK_FLUXES - CALL rp_bulk_flux (ng, tile) + CALL rp_bulk_flux (ng, tile) # endif # ifdef BBL_MODEL_NOT_YET - CALL rp_bblm (ng, tile) + CALL rp_bblm (ng, tile) # endif - CALL rp_set_vbc (ng, tile) + CALL rp_set_vbc (ng, tile) # if defined SSH_TIDES_NOT_YET || defined UV_TIDES_NOT_YET - CALL rp_set_tides (ng, tile) + CALL rp_set_tides (ng, tile) +# endif + END DO + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for bottom stress variables. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL rp_nesting (ng, iRPM, nbstr) + END IF + END DO # endif - END DO -!$OMP BARRIER - END DO # ifdef ADJUST_BOUNDARY ! @@ -316,16 +372,16 @@ SUBROUTINE rp_main3d (RunInterval) ! Skip the last output timestep. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF ((Nrun.ne.1).and.(iic(ng).lt.(ntend(ng)+1))) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL rp_obc_adjust (ng, tile, Lbinp(ng)) - CALL rp_set_depth_bry (ng, tile, iRPM) - CALL rp_obc2d_adjust (ng, tile, Lbinp(ng)) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (iic(ng).lt.(ntend(ng)+1)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL rp_obc_adjust (ng, tile, Lbinp(ng)) + CALL rp_set_depth_bry (ng, tile, iRPM) + CALL rp_obc2d_adjust (ng, tile, Lbinp(ng)) + END DO + END IF END DO -!$OMP BARRIER - END IF - END DO # endif # if defined ADJUST_STFLUX || defined ADJUST_WSTRESS @@ -335,14 +391,14 @@ SUBROUTINE rp_main3d (RunInterval) ! Skip the last output timestep. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (iic(ng).lt.(ntend(ng)+1)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL rp_frc_adjust (ng, tile, Lfinp(ng)) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (iic(ng).lt.(ntend(ng)+1)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL rp_frc_adjust (ng, tile, Lfinp(ng)) + END DO + END IF END DO -!$OMP BARRIER - END IF - END DO # endif ! !----------------------------------------------------------------------- @@ -351,20 +407,23 @@ SUBROUTINE rp_main3d (RunInterval) ! horizontal mass divergence. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=last_tile(ng),first_tile(ng),-1 + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=last_tile(ng),first_tile(ng),-1 # if defined ANA_VMIX_NOT_YET - CALL rp_ana_vmix (ng, tile) + CALL rp_ana_vmix (ng, tile) # elif defined LMD_MIXING_NOT_YET - CALL rp_lmd_vmix (ng, tile) + CALL rp_lmd_vmix (ng, tile) # elif defined BVF_MIXING_NOT_YET - CALL rp_bvf_mix (ng, tile) + CALL rp_bvf_mix (ng, tile) # endif - CALL rp_omega (ng, tile, iRPM) -!! CALL wvelocity (ng, tile, nstp(ng)) - END DO -!$OMP BARRIER - END DO + CALL rp_omega (ng, tile, iRPM) +!! CALL wvelocity (ng, tile, nstp(ng)) + END DO + END DO + +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) || \ + defined DIAGNOSTICS || defined AVERAGES ! !----------------------------------------------------------------------- ! Set free-surface to it time-averaged value. If applicable, @@ -372,18 +431,34 @@ SUBROUTINE rp_main3d (RunInterval) ! loop in shared-memory jobs. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 ! irreversible - CALL rp_set_zeta (ng, tile) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=first_tile(ng),last_tile(ng),+1 ! irreversible +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) + CALL rp_set_zeta (ng, tile) +# endif # ifdef DIAGNOSTICS -!! CALL rp_set_diags (ng, tile) +!! CALL rp_set_diags (ng, tile) # endif # ifdef RP_AVERAGES - CALL tl_set_avg (ng, tile) + CALL tl_set_avg (ng, tile) # endif - END DO -!$OMP BARRIER - END DO + END DO + END DO +# endif + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for 3D kernel free-surface. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL rp_nesting (ng, iRPM, nzeta) + END IF + END DO +# endif ! !----------------------------------------------------------------------- ! If appropriate, write out fields into output NetCDF files. Notice @@ -391,55 +466,218 @@ SUBROUTINE rp_main3d (RunInterval) ! time step. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids -!$OMP MASTER - CALL rp_output (ng) -!$OMP END MASTER -!$OMP BARRIER - IF ((FoundError(exit_flag, NoError, __LINE__, MyFile)).or. & - & ((iic(ng).eq.(ntend(ng)+1)).and.(ng.eq.Ngrids))) RETURN - END DO + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + CALL rp_output (ng) + IF ((FoundError(exit_flag, NoError, __LINE__, MyFile)).or.& + & ((iic(ng).eq.(ntend(ng)+1)).and.(ng.eq.Ngrids))) THEN + RETURN + END IF + END DO + +# ifdef NESTING +! +!----------------------------------------------------------------------- +! If refinement grid, interpolate (space, time) state variables +! contact points from donor grid extracted data. +# ifdef NESTING_DEBUG +! +! Also, fill BRY_CONTACT(:,:)%Mflux to check for mass conservation +! between coarse and fine grids. This is only done for diagnostic +! purposes. Also, debugging is possible with very verbose output +! to fort.300 is allowed by activating uppercase(nesting_debug). +# endif +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (RefinedGrid(ng).and.(RefineScale(ng).gt.0)) THEN + CALL rp_nesting (ng, iRPM, nputD) +# ifdef NESTING_DEBUG + CALL rp_nesting (ng, iRPM, nmflx) +# endif + END IF + END DO +# endif ! !----------------------------------------------------------------------- ! Compute right-hand-side terms for 3D equations. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 - CALL rp_rhs3d (ng, tile) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=last_tile(ng),first_tile(ng),-1 + CALL rp_rhs3d (ng, tile) # ifdef MY25_MIXING_NOT_YET - CALL rp_my25_prestep (ng, tile) + CALL rp_my25_prestep (ng, tile) # elif defined GLS_MIXING_NOT_YET - CALL rp_gls_prestep (ng, tile) + CALL rp_gls_prestep (ng, tile) # endif - END DO -!$OMP BARRIER - END DO + END DO + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for right-hand-side terms +! (tracers). +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL rp_nesting (ng, iRPM, nrhst) + END IF + END DO +# endif + +# ifdef STEP2D_FB_AB3_AM4 +! +!----------------------------------------------------------------------- +! Solve representers vertically integrated primitive equations for +! free-surface and barotropic momentum components using a generalized +! Forward-Backward, 3rd-order Adams-Bashforth / 4th-order Adams-Moulton +! (FB AB3-AM4) time stepping scheme (Shchepetkin and McWilliams, +! 2009). +!----------------------------------------------------------------------- +! + LOOP_2D : DO my_iif=1,MAXVAL(nfast) + + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (my_iif.le.nfast(ng)) THEN + iif(ng)=my_iif + kstp(ng)=knew(ng) + knew(ng)=kstp(ng)+1 + IF (knew(ng).gt.4) knew(ng)=1 + + IF (MOD(knew(ng),2).eq.0) THEN ! zig-zag + DO tile=first_tile(ng),last_tile(ng),+1 ! processing + CALL rp_step2d (ng, tile) ! sequence + END DO + ELSE + DO tile=last_tile(ng),first_tile(ng),-1 + CALL rp_step2d (ng, tile) + END DO + END IF + END IF + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine CORRECTOR STEP section (KNEW INDEX). +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL rp_nesting (ng, iRPM, n2dCS) + END IF + END DO +# endif + END DO LOOP_2D + +# else + +# ifdef STEP2D_FB_LF_AM3 +! +!----------------------------------------------------------------------- +! Solve the vertically integrated primitive equations for the +! free-surface and barotropic momentum components using a predictor- +! corrector LeapFrog / 3rd-order Adams-Moulton with a Forward-Backward +! feeback (FB LF-AM3) stepping scheme (Shchepetkin and McWilliams, +! 2009). +!----------------------------------------------------------------------- +! + LOOP_2D : DO my_iif=1,MAXVAL(nfast) +! +! Predictor LF substep with FB-feedback. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (my_iif.le.nfast(ng)) THEN + iif(ng)=my_iif + kstp(ng)=next_kstp(ng) + knew(ng)=3 + + DO tile=last_tile(ng),first_tile(ng),-1 + CALL rp_step2d (ng, tile) + END DO + END IF + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine PREDICTOR STEP section. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL rp_nesting (ng, iRPM, n2dPS) + END IF + END DO +# endif +! +! Corrector AM3 substep with FB-feedback. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (my_iif.le.nfast(ng)) THEN + knew(ng)=3-kstp(ng) + next_kstp(ng)=knew(ng) + + DO tile=first_tile(ng),last_tile(ng),+1 + CALL rp_step2d (ng, tile) + END DO + END IF + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine CORRECTOR STEP section (KNEW INDEX). +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL rp_nesting (ng, iRPM, n2dCS) + END IF + END DO +# endif + END DO LOOP_2D + +# else ! !----------------------------------------------------------------------- ! Solve the vertically integrated primitive equations for the -! free-surface and barotropic momentum components. +! free-surface and barotropic momentum components using a predictor- +! corrector LeapFrog with 3rd-order Adams-Moulton (LF-AM3) time +! stepping scheme. !----------------------------------------------------------------------- ! - LOOP_2D : DO my_iif=1,MAXVAL(nfast)+1 + LOOP_2D : DO my_iif=1,MAXVAL(nfast)+1 ! ! Set time indices for predictor step. The PREDICTOR_2D_STEP switch ! it is assumed to be false before the first time-step. ! - DO ng=1,Ngrids - next_indx1=3-indx1(ng) - IF (.not.PREDICTOR_2D_STEP(ng).and. & - & my_iif.le.(nfast(ng)+1)) THEN - PREDICTOR_2D_STEP(ng)=.TRUE. - iif(ng)=my_iif - IF (FIRST_2D_STEP) THEN - kstp(ng)=indx1(ng) - ELSE - kstp(ng)=3-indx1(ng) - END IF - knew(ng)=3 - krhs(ng)=indx1(ng) - END IF + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + next_indx1=3-indx1(ng) + IF (.not.PREDICTOR_2D_STEP(ng).and. & + & my_iif.le.(nfast(ng)+1)) THEN + PREDICTOR_2D_STEP(ng)=.TRUE. + iif(ng)=my_iif + IF (FIRST_2D_STEP) THEN + kstp(ng)=indx1(ng) + ELSE + kstp(ng)=3-indx1(ng) + END IF + knew(ng)=3 + krhs(ng)=indx1(ng) + END IF ! ! Predictor step - Advance barotropic equations using 2D time-step ! ============== predictor scheme. No actual time-stepping is @@ -447,50 +685,123 @@ SUBROUTINE rp_main3d (RunInterval) ! to finalize the fast-time averaging of 2D fields, if any, and ! compute the new time-evolving depths. ! - IF (my_iif.le.(nfast(ng)+1)) THEN - DO tile=last_tile(ng),first_tile(ng),-1 - CALL rp_step2d (ng, tile) + IF (my_iif.le.(nfast(ng)+1)) THEN + DO tile=last_tile(ng),first_tile(ng),-1 + CALL rp_step2d (ng, tile) + END DO + END IF END DO -!$OMP BARRIER - END IF - END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine PREDICTOR STEP section. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL rp_nesting (ng, iRPM, n2dPS) + END IF + END DO +# endif ! ! Set time indices for corrector step. ! - DO ng=1,Ngrids - IF (PREDICTOR_2D_STEP(ng)) THEN - PREDICTOR_2D_STEP(ng)=.FALSE. - knew(ng)=next_indx1 - kstp(ng)=3-knew(ng) - krhs(ng)=3 - IF (iif(ng).lt.(nfast(ng)+1)) indx1(ng)=next_indx1 - END IF + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (PREDICTOR_2D_STEP(ng)) THEN + PREDICTOR_2D_STEP(ng)=.FALSE. + knew(ng)=next_indx1 + kstp(ng)=3-knew(ng) + krhs(ng)=3 + IF (iif(ng).lt.(nfast(ng)+1)) indx1(ng)=next_indx1 + END IF ! ! Corrector step - Apply 2D time-step corrector scheme. Notice that ! ============== there is not need for a corrector step during the ! auxiliary (nfast+1) time-step. ! - IF (iif(ng).lt.(nfast(ng)+1)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL rp_step2d (ng, tile) + IF (iif(ng).lt.(nfast(ng)+1)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL rp_step2d (ng, tile) + END DO + END IF + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine CORRECTOR STEP section (KNEW INDEX). +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL rp_nesting (ng, iRPM, n2dCS) + END IF END DO -!$OMP BARRIER - END IF - END DO +# endif + END DO LOOP_2D +# endif + +# endif + +# ifdef NESTING +# if defined MASKING && defined WET_DRY +! +!----------------------------------------------------------------------- +! If nesting and wetting and drying, scale horizontal interpolation +! weights to account for land/sea masking in contact areas. This needs +! to be done at very time-step since the Land/Sea masking is time +! dependent. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + CALL rp_nesting (ng, iRPM, nmask) + END DO +# endif +! +!----------------------------------------------------------------------- +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the time-averaged +! momentum fluxes (DU_avg1, DV_avg1) and free-surface (Zt_avg). +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL rp_nesting (ng, iRPM, n2dfx) + END IF + END DO +# endif - END DO LOOP_2D +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) ! !----------------------------------------------------------------------- ! Recompute depths and thicknesses using the new time filtered ! free-surface. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 - CALL rp_set_depth (ng, tile, iRPM) - END DO -!$OMP BARRIER - END DO + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=last_tile(ng),first_tile(ng),-1 + CALL rp_set_depth (ng, tile, iRPM) + END DO + END DO +# endif + +# ifdef NESTING +! +! If nesting, determine vertical indices and vertical interpolation +! weights in the contact zone using new depth arrays. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + CALL rp_nesting (ng, iRPM, nzwgt) + END DO +# endif ! !----------------------------------------------------------------------- ! Time-step 3D momentum equations. @@ -499,35 +810,49 @@ SUBROUTINE rp_main3d (RunInterval) ! Time-step 3D momentum equations and couple with vertically ! integrated equations. ! - DO ng=1,Ngrids - DO tile=last_tile(ng),first_tile(ng),-1 - CALL rp_step3d_uv (ng, tile) - END DO -!$OMP BARRIER - END DO + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=last_tile(ng),first_tile(ng),-1 + CALL rp_step3d_uv (ng, tile) + END DO + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for 3D momentum (u,v), +! adjusted 2D momentum (ubar,vbar), and fluxes (Huon, Hvom). +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL rp_nesting (ng, iRPM, n3duv) + END IF + END DO +# endif ! !----------------------------------------------------------------------- ! Time-step vertical mixing turbulent equations and passive tracer ! source and sink terms, if applicable. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 - CALL rp_omega (ng, tile, iRPM) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=first_tile(ng),last_tile(ng),+1 + CALL rp_omega (ng, tile, iRPM) # ifdef MY25_MIXING_NOT_YET - CALL rp_my25_corstep (ng, tile) + CALL rp_my25_corstep (ng, tile) # elif defined GLS_MIXING_NOT_YET - CALL rp_gls_corstep (ng, tile) + CALL rp_gls_corstep (ng, tile) # endif # ifdef BIOLOGY - CALL rp_biology (ng, tile) + CALL rp_biology (ng, tile) # endif # ifdef SEDIMENT_NOT_YET - CALL rp_sediment (ng, tile) + CALL rp_sediment (ng, tile) # endif - END DO -!$OMP BARRIER - END DO + END DO + END DO # ifndef TS_FIXED ! @@ -535,12 +860,65 @@ SUBROUTINE rp_main3d (RunInterval) ! Time-step tracer equations. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=last_tile(ng),first_tile(ng),-1 - CALL rp_step3d_t (ng, tile) - END DO - END DO -!$OMP BARRIER + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=last_tile(ng),first_tile(ng),-1 + CALL rp_step3d_t (ng, tile) + END DO + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for Tracer Variables. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL rp_nesting (ng, iRPM, n3dTV) + END IF + END DO +# endif +# endif + +# ifdef NESTING +# ifndef ONE_WAY +! +!----------------------------------------------------------------------- +! If refinement grids, perform two-way coupling between fine and +! coarse grids. Correct coarse grid tracers values at the refinement +! grid with refined accumulated fluxes. Then, replace coarse grid +! state variable with averaged refined grid values (two-way nesting). +! Update coarse grid depth variables. +! +! The two-way exchange of infomation between nested grids needs to be +! done at the correct time-step and in the right sequence. +!----------------------------------------------------------------------- +! + DO il=NestLayers,1,-1 + DO ig=1,GridsInLayer(il) + ng=GridNumber(ig,il) + IF (do_twoway(iRPM, nl, il, ng, istep)) THEN + CALL rp_nesting (ng, iRPM, n2way) + END IF + END DO + END DO +# endif +! +!----------------------------------------------------------------------- +! If donor to a finer grid, extract data for the external contact +! points. This is the latest solution for the coarser grid. +! +! It is stored in the REFINED structure so it can be used for the +! space-time interpolation when "nputD" argument is used above. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (DonorToFiner(ng)) THEN + CALL rp_nesting (ng, iRPM, ngetD) + END IF + END DO # endif # ifdef FLOATS_NOT_YET @@ -553,31 +931,48 @@ SUBROUTINE rp_main3d (RunInterval) ! variables do not have a global scope. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (Lfloats(Ng)) THEN + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (Lfloats(ng)) THEN # ifdef _OPENMP - chunk_size=(Nfloats(ng)+numthreads-1)/numthreads - Lstr=1+my_thread*chunk_size - Lend=MIN(Nfloats(ng),Lstr+chunk_size-1) + chunk_size=(Nfloats(ng)+numthreads-1)/numthreads + Lstr=1+MyThread*chunk_size + Lend=MIN(Nfloats(ng),Lstr+chunk_size-1) # else - Lstr=1 - Lend=Nfloats(ng) + Lstr=1 + Lend=Nfloats(ng) # endif - CALL rp_step_floats (ng, Lstr, Lend) -!$OMP BARRIER + CALL rp_step_floats (ng, Lstr, Lend) ! ! Shift floats time indices. ! - nfp1(ng)=MOD(nfp1(ng)+1,NFT+1) - nf (ng)=MOD(nf (ng)+1,NFT+1) - nfm1(ng)=MOD(nfm1(ng)+1,NFT+1) - nfm2(ng)=MOD(nfm2(ng)+1,NFT+1) - nfm3(ng)=MOD(nfm3(ng)+1,NFT+1) - END IF - END DO + nfp1(ng)=MOD(nfp1(ng)+1,NFT+1) + nf (ng)=MOD(nf (ng)+1,NFT+1) + nfm1(ng)=MOD(nfm1(ng)+1,NFT+1) + nfm2(ng)=MOD(nfm2(ng)+1,NFT+1) + nfm3(ng)=MOD(nfm3(ng)+1,NFT+1) + END IF + END DO # endif - END DO STEP_LOOP +! +!----------------------------------------------------------------------- +! Advance time index and time clock. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + iic(ng)=iic(ng)+1 + time(ng)=time(ng)+dt(ng) + step_counter(ng)=step_counter(ng)-1 + CALL time_string (time(ng), time_code(ng)) + END DO + END DO STEP_LOOP + + END DO NEST_LAYER + + END DO KERNEL_LOOP +! RETURN END SUBROUTINE rp_main3d #else diff --git a/ROMS/Representer/rp_set_data.F b/ROMS/Representer/rp_set_data.F index a2db19482..51c3e9333 100644 --- a/ROMS/Representer/rp_set_data.F +++ b/ROMS/Representer/rp_set_data.F @@ -1474,7 +1474,11 @@ SUBROUTINE rp_set_data_tile (ng, tile, & ! ! Set forward free-surface. ! +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + DO k=1,4 +# else DO k=1,3 +# endif CALL set_2dfld_tile (ng, tile, iRPM, idFsur, & & LBi, UBi, LBj, UBj, & & OCEAN(ng)%zetaG, & @@ -1493,7 +1497,11 @@ SUBROUTINE rp_set_data_tile (ng, tile, & ! ! Set forward 2D momentum. ! +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + DO k=1,4 +# else DO k=1,3 +# endif CALL set_2dfld_tile (ng, tile, iRPM, idUbar, & & LBi, UBi, LBj, UBj, & & OCEAN(ng)%ubarG, & diff --git a/ROMS/Representer/rp_set_zeta.F b/ROMS/Representer/rp_set_zeta.F index b71e26c5f..d571e03fa 100644 --- a/ROMS/Representer/rp_set_zeta.F +++ b/ROMS/Representer/rp_set_zeta.F @@ -1,7 +1,8 @@ #include "cppdefs.h" MODULE rp_set_zeta_mod -#if defined TL_IOMS && defined SOLVE3D +#if defined TL_IOMS && defined SOLVE3D && \ + !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) ! !git $Id$ !================================================== Hernan G. Arango === @@ -84,7 +85,7 @@ SUBROUTINE rp_set_zeta_tile (ng, tile, & # else real(r8), intent(in) :: tl_Zt_avg1(LBi:UBi,LBj:UBj) - real(r8), intent(out) :: tl_zeta(LBi:UBi,LBj:UBj,3) + real(r8), intent(out) :: tl_zeta(LBi:UBi,LBj:UBj,:) # endif ! ! Local variable declarations. diff --git a/ROMS/Representer/rp_step2d_FB.h b/ROMS/Representer/rp_step2d_FB.h index 6bf49894e..de77ad342 100644 --- a/ROMS/Representer/rp_step2d_FB.h +++ b/ROMS/Representer/rp_step2d_FB.h @@ -152,7 +152,7 @@ & FORCES(ng) % Pair, & # endif #else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET & COUPLING(ng) % rhoA, & & COUPLING(ng) % tl_rhoA, & & COUPLING(ng) % rhoS, & @@ -247,7 +247,7 @@ & Pair, & # endif #else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET & rhoA, tl_rhoA, & & rhoS, tl_rhoS, & # endif @@ -349,7 +349,7 @@ real(r8), intent(in ) :: Pair(LBi:,LBj:) # endif # else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET real(r8), intent(in ) :: rhoA(LBi:,LBj:) real(r8), intent(in ) :: rhoS(LBi:,LBj:) real(r8), intent(in ) :: tl_rhoA(LBi:,LBj:) @@ -468,7 +468,7 @@ real(r8), intent(in ) :: Pair(LBi:UBi,LBj:UBj) # endif # else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET real(r8), intent(in ) :: rhoA(LBi:UBi,LBj:UBj) real(r8), intent(in ) :: rhoS(LBi:UBi,LBj:UBj) real(r8), intent(in ) :: tl_rhoA(LBi:UBi,LBj:UBj) @@ -573,7 +573,7 @@ real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: grad #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta2 -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzetaSA #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rubar @@ -617,7 +617,7 @@ real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_grad #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzeta2 -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzetaSA #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzeta @@ -661,7 +661,7 @@ grad=IniVal # endif rzeta2=IniVal -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D rzetaSA=IniVal # endif rzeta=IniVal @@ -991,7 +991,7 @@ & bkw1*tl_zeta(i,j,kbak)+ & & bkw2*tl_zeta(i,j,kold) -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j) tl_rzeta(i,j)=(1.0_r8+rhoS(i,j))*tl_zwrk(i,j)+ & & tl_rhoS(i,j)*zwrk(i,j)- & @@ -1160,7 +1160,7 @@ !----------------------------------------------------------------------- ! cff1=0.5_r8*g -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D cff2=0.333333333333_r8 #endif #if defined ATM_PRESS && !defined SOLVE3D @@ -1174,7 +1174,7 @@ !^ & h(i ,j))* & !^ & (rzeta(i-1,j)- & !^ & rzeta(i ,j))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i-1,j)- & !^ & h(i ,j))* & !^ & (rzetaSA(i-1,j)+ & @@ -1204,7 +1204,7 @@ & rzeta(i ,j))+ & # endif #endif -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D # if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET & (tl_h(i-1,j)- & & tl_h(i ,j))* & @@ -1290,7 +1290,7 @@ !^ & h(i,j ))* & !^ & (rzeta(i,j-1)- & !^ & rzeta(i,j ))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i,j-1)- & !^ & h(i,j ))* & !^ & (rzetaSA(i,j-1)+ & @@ -1320,7 +1320,7 @@ & rzeta(i,j ))+ & # endif #endif -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D # if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET & (tl_h(i,j-1)- & & tl_h(i,j ))* & @@ -2275,7 +2275,7 @@ !^ zwrk(i,j)=zeta_new(i,j)-zeta(i,j,kstp) !^ tl_zwrk(i,j)=tl_zeta_new(i,j)-tl_zeta(i,j,kstp) -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j) !^ tl_rzeta(i,j)=(1.0_r8+rhoS(i,j))*tl_zwrk(i,j)+ & @@ -2319,7 +2319,7 @@ END DO ! cff1=0.5*g -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D cff2=0.333333333333_r8 # endif DO j=Jstr,Jend @@ -2331,7 +2331,7 @@ !^ & h(i ,j))* & !^ & (rzeta(i-1,j)- & !^ & rzeta(i ,j))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i-1,j)- & !^ & h(i ,j))* & !^ & (rzetaSA(i-1,j)+ & @@ -2362,7 +2362,7 @@ & rzeta(i ,j))+ & # endif #endif -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D # if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET & (tl_h(i-1,j)- & & tl_h(i ,j))* & @@ -2416,7 +2416,7 @@ !^ & h(i,j ))* & !^ & (rzeta(i,j-1)- & !^ & rzeta(i,j ))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i,j-1)- & !^ & h(i,j ))* & !^ & (rzetaSA(i,j-1)+ & @@ -2447,7 +2447,7 @@ & rzeta(i,j ))+ & # endif #endif -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D # if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET & (tl_h(i,j-1)- & & tl_h(i,j ))* & diff --git a/ROMS/Representer/rp_step2d_FB_LF_AM3.h b/ROMS/Representer/rp_step2d_FB_LF_AM3.h index 8dabbd4cc..bb6344542 100644 --- a/ROMS/Representer/rp_step2d_FB_LF_AM3.h +++ b/ROMS/Representer/rp_step2d_FB_LF_AM3.h @@ -143,7 +143,7 @@ & FORCES(ng) % Pair, & # endif #else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET & COUPLING(ng) % rhoA, & & COUPLING(ng) % tl_rhoA, & & COUPLING(ng) % rhoS, & @@ -231,7 +231,7 @@ & Pair, & # endif #else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET & rhoA, tl_rhoA, & & rhoS, tl_rhoS, & # endif @@ -324,7 +324,7 @@ real(r8), intent(in ) :: Pair(LBi:,LBj:) # endif # else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET real(r8), intent(in ) :: rhoA(LBi:,LBj:) real(r8), intent(in ) :: rhoS(LBi:,LBj:) real(r8), intent(in ) :: tl_rhoA(LBi:,LBj:) @@ -432,7 +432,7 @@ real(r8), intent(in ) :: Pair(LBi:UBi,LBj:UBj) # endif # else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET real(r8), intent(in ) :: rhoA(LBi:UBi,LBj:UBj) real(r8), intent(in ) :: rhoS(LBi:UBi,LBj:UBj) real(r8), intent(in ) :: tl_rhoA(LBi:UBi,LBj:UBj) @@ -528,7 +528,7 @@ real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rvbar real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta2 -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzetaSA #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: zeta_new @@ -566,7 +566,7 @@ real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_grad #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzeta2 -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzetaSA #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzeta @@ -931,7 +931,7 @@ tl_zwrk(i,j)=cff1*tl_zeta_new(i,j)+ & & cff2*tl_zeta(i,j,kstp)+ & & cff3*tl_zeta(i,j,kbak) -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j) tl_rzeta(i,j)=(1.0_r8+rhoS(i,j))*tl_zwrk(i,j)+ & & tl_rhoS(i,j)*zwrk(i,j)- & @@ -1005,7 +1005,7 @@ & cff1*tl_zeta_new(i,j)+ & & cff2*tl_zeta(i,j,kstp)+ & & cff3*tl_zeta(i,j,kbak) -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j) tl_rzeta(i,j)=(1.0_r8+rhoS(i,j))*tl_zwrk(i,j)+ & & tl_rhoS(i,j)*zwrk(i,j)- & @@ -1157,7 +1157,7 @@ !^ & h(i ,j))* & !^ & (rzeta(i-1,j)- & !^ & rzeta(i ,j))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i-1,j)- & !^ & h(i ,j))* & !^ & (rzetaSA(i-1,j)+ & @@ -1187,7 +1187,7 @@ & rzeta(i ,j))+ & # endif #endif -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D # if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET & (tl_h(i-1,j)- & & tl_h(i ,j))* & @@ -1273,7 +1273,7 @@ !^ & h(i,j ))* & !^ & (rzeta(i,j-1)- & !^ & rzeta(i,j ))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i,j-1)- & !^ & h(i,j ))* & !^ & (rzetaSA(i,j-1)+ & @@ -1303,7 +1303,7 @@ & rzeta(i,j ))+ & # endif #endif -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D # if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET & (tl_h(i,j-1)- & & tl_h(i,j ))* & @@ -2267,7 +2267,7 @@ !^ zwrk(i,j)=cff2*(zeta_new(i,j)-zeta(i,j,kstp)) !^ tl_zwrk(i,j)=cff2*(tl_zeta_new(i,j)-tl_zeta(i,j,kstp)) -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j) !^ tl_rzeta(i,j)=(1.0_r8+rhoS(i,j))*tl_zwrk(i,j)+ & @@ -2327,7 +2327,7 @@ !^ & h(i ,j))* & !^ & (rzeta(i-1,j)- & !^ & rzeta(i ,j))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i-1,j)- & !^ & h(i ,j))* & !^ & (rzetaSA(i-1,j)+ & @@ -2358,7 +2358,7 @@ & rzeta(i ,j))+ & # endif # endif -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D # if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET & (tl_h(i-1,j)- & & tl_h(i ,j))* & @@ -2412,7 +2412,7 @@ !^ & h(i,j ))* & !^ & (rzeta(i,j-1)- & !^ & rzeta(i,j ))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i,j-1)- & !^ & h(i,j ))* & !^ & (rzetaSA(i,j-1)+ & @@ -2443,7 +2443,7 @@ & rzeta(i,j ))+ & # endif # endif -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D # if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET & (tl_h(i,j-1)- & & tl_h(i,j ))* & diff --git a/ROMS/Representer/rp_step3d_uv.F b/ROMS/Representer/rp_step3d_uv.F index a80e3a76c..6d10d93d2 100644 --- a/ROMS/Representer/rp_step3d_uv.F +++ b/ROMS/Representer/rp_step3d_uv.F @@ -75,6 +75,9 @@ SUBROUTINE rp_step3d_uv (ng, tile) & LBi, UBi, LBj, UBj, & & IminS, ImaxS, JminS, JmaxS, & & nrhs(ng), nstp(ng), nnew(ng), & +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + & knew(ng), & +# endif # ifdef MASKING & GRID(ng) % umask, & & GRID(ng) % vmask, & @@ -85,6 +88,10 @@ SUBROUTINE rp_step3d_uv (ng, tile) # endif & GRID(ng) % om_v, & & GRID(ng) % on_u, & +# ifdef OMEGA_IMPLICIT + & GRID(ng) % om_u, & + & GRID(ng) % on_v, & +# endif & GRID(ng) % pm, & & GRID(ng) % pn, & & GRID(ng) % Hz, & @@ -130,6 +137,10 @@ SUBROUTINE rp_step3d_uv (ng, tile) & OCEAN(ng) % tl_u_stokes, & & OCEAN(ng) % v_stokes, & & OCEAN(ng) % tl_v_stokes, & +# endif +# ifdef OMEGA_IMPLICIT + & OCEAN(ng) % Wi, & + & OCEAN(ng) % tl_Wi, & # endif & GRID(ng) % Huon, & & GRID(ng) % tl_Huon, & @@ -147,13 +158,20 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & & LBi, UBi, LBj, UBj, & & IminS, ImaxS, JminS, JmaxS, & & nrhs, nstp, nnew, & +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + & knew, & +# endif # ifdef MASKING & umask, vmask, & # endif # ifdef WET_DRY_NOT_YET & umask_wet, vmask_wet, & # endif - & om_v, on_u, pm, pn, & + & om_v, on_u, & +# ifdef OMEGA_IMPLICIT + & om_u, on_v, & +# endif + & pm, pn, & & Hz, tl_Hz, & & z_r, tl_z_r, & & z_w, tl_z_w, & @@ -177,6 +195,9 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & & vbar_stokes, tl_vbar_stokes, & & u_stokes, tl_u_stokes, & & v_stokes, tl_v_stokes, & +# endif +# ifdef OMEGA_IMPLICIT + & Wi, tl_Wi, & # endif & Huon, tl_Huon, & & Hvom, tl_Hvom) @@ -188,6 +209,9 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & integer, intent(in) :: LBi, UBi, LBj, UBj integer, intent(in) :: IminS, ImaxS, JminS, JmaxS integer, intent(in) :: nrhs, nstp, nnew +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + integer, intent(in) :: knew +# endif ! # ifdef ASSUMED_SHAPE # ifdef MASKING @@ -200,6 +224,10 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & # endif real(r8), intent(in) :: om_v(LBi:,LBj:) real(r8), intent(in) :: on_u(LBi:,LBj:) +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: om_u(LBi:,LBj:) + real(r8), intent(in) :: on_v(LBi:,LBj:) +# endif real(r8), intent(in) :: pm(LBi:,LBj:) real(r8), intent(in) :: pn(LBi:,LBj:) real(r8), intent(in) :: Hz(LBi:,LBj:,:) @@ -213,10 +241,10 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & real(r8), intent(in) :: u(LBi:,LBj:,:,:) real(r8), intent(in) :: v(LBi:,LBj:,:,:) # ifdef WEC_NOT_YET + real(r8), intent(in) :: u_stokes(LBi:,LBj:,:) + real(r8), intent(in) :: v_stokes(LBi:,LBj:,:) real(r8), intent(in) :: ubar_stokes(LBi:,LBj:) real(r8), intent(in) :: vbar_stokes(LBi:,LBj:) - real(r8), intent(in) :: tl_ubar_stokes(LBi:,LBj:) - real(r8), intent(in) :: tl_vbar_stokes(LBi:,LBj:) # endif real(r8), intent(in) :: tl_Hz(LBi:,LBj:,:) real(r8), intent(in) :: tl_z_r(LBi:,LBj:,:) @@ -228,7 +256,9 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & real(r8), intent(in) :: tl_DV_avg2(LBi:,LBj:) real(r8), intent(in) :: tl_ru(LBi:,LBj:,0:,:) real(r8), intent(in) :: tl_rv(LBi:,LBj:,0:,:) - +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: tl_Wi(LBi:,LBj:,0:) +# endif # ifdef DIAGNOSTICS_UV !! real(r8), intent(inout) :: DiaU2wrk(LBi:,LBj:,:) !! real(r8), intent(inout) :: DiaV2wrk(LBi:,LBj:,:) @@ -244,10 +274,10 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:) real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:) # ifdef WEC_NOT_YET - real(r8), intent(inout) :: u_stokes(LBi:,LBj:,:) - real(r8), intent(inout) :: v_stokes(LBi:,LBj:,:) real(r8), intent(inout) :: tl_u_stokes(LBi:,LBj:,:) real(r8), intent(inout) :: tl_v_stokes(LBi:,LBj:,:) + real(r8), intent(inout) :: tl_ubar_stokes(LBi:,LBj:) + real(r8), intent(inout) :: tl_vbar_stokes(LBi:,LBj:) # endif real(r8), intent(out) :: tl_ubar(LBi:,LBj:,:) real(r8), intent(out) :: tl_vbar(LBi:,LBj:,:) @@ -266,6 +296,10 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & # endif real(r8), intent(in) :: om_v(LBi:UBi,LBj:UBj) real(r8), intent(in) :: on_u(LBi:UBi,LBj:UBj) +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: om_u(LBi:UBi,LBj:UBj) + real(r8), intent(in) :: on_v(LBi:UBi,LBj:UBj) +# endif real(r8), intent(in) :: pm(LBi:UBi,LBj:UBj) real(r8), intent(in) :: pn(LBi:UBi,LBj:UBj) real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng)) @@ -279,12 +313,14 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & real(r8), intent(in) :: u(LBi:UBi,LBj:UBj,N(ng),2) real(r8), intent(in) :: v(LBi:UBi,LBj:UBj,N(ng),2) # ifdef WEC_NOT_YET + real(r8), intent(in) :: u_stokes(LBi:UBi,LBj:UBj,N(ng)) + real(r8), intent(in) :: v_stokes(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(in) :: ubar_stokes(LBi:UBi,LBj:UBj) real(r8), intent(in) :: vbar_stokes(LBi:UBi,LBj:UBj) - real(r8), intent(in) :: tl_ubar_stokes(LBi:UBi,LBj:UBj) - real(r8), intent(in) :: tl_vbar_stokes(LBi:UBi,LBj:UBj) # endif - +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: Wi(LBi:UBi,LBj:UBj,0:N(ng)) +# endif real(r8), intent(in) :: tl_Hz(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(in) :: tl_z_r(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(in) :: tl_z_w(LBi:UBi,LBj:UBj,0:N(ng)) @@ -295,6 +331,9 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & real(r8), intent(in) :: tl_DV_avg2(LBi:UBi,LBj:UBj) real(r8), intent(in) :: tl_ru(LBi:UBi,LBj:UBj,0:N(ng),2) real(r8), intent(in) :: tl_rv(LBi:UBi,LBj:UBj,0:N(ng),2) +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: tl_Wi(LBi:UBi,LBj:UBj,0:N(ng)) +# endif # ifdef DIAGNOSTICS_UV !! real(r8), intent(inout) :: DiaU2wrk(LBi:UBi,LBj:UBj,NDM2d) !! real(r8), intent(inout) :: DiaV2wrk(LBi:UBi,LBj:UBj,NDM2d) @@ -310,13 +349,13 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2) real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2) # ifdef WEC_NOT_YET - real(r8), intent(inout) :: u_stokes(LBi:UBi,LBj:UBj,N(ng)) - real(r8), intent(inout) :: v_stokes(LBi:UBi,LBj:UBj,N(ng)) + real(r8), intent(inout) :: tl_u_stokes(LBi:UBi,LBj:UBj,N(ng)) + real(r8), intent(inout) :: tl_v_stokes(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(inout) :: tl_u_stokes(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(inout) :: tl_v_stokes(LBi:UBi,LBj:UBj,N(ng)) # endif - real(r8), intent(out) :: tl_ubar(LBi:UBi,LBj:UBj,3) - real(r8), intent(out) :: tl_vbar(LBi:UBi,LBj:UBj,3) + real(r8), intent(out) :: tl_ubar(LBi:UBi,LBj:UBj,:) + real(r8), intent(out) :: tl_vbar(LBi:UBi,LBj:UBj,:) real(r8), intent(out) :: tl_Huon(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(out) :: tl_Hvom(LBi:UBi,LBj:UBj,N(ng)) # endif @@ -340,6 +379,11 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & real(r8), dimension(IminS:ImaxS,0:N(ng)) :: DC real(r8), dimension(IminS:ImaxS,0:N(ng)) :: DC1 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FC +# ifdef OMEGA_IMPLICIT + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FCmin + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FCmax + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: WK +# endif # ifdef WEC_NOT_YET real(r8), dimension(IminS:ImaxS,0:N(ng)) :: CFs real(r8), dimension(IminS:ImaxS,0:N(ng)) :: DCs @@ -355,6 +399,11 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_CF real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_DC real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_FC +# ifdef OMEGA_IMPLICIT + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_FCmin + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_FCmax + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_WK +# endif # ifdef WEC_NOT_YET real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_CFs real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_DCs @@ -720,6 +769,136 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & END DO END DO # endif +# ifdef OMEGA_IMPLICIT +! +! Adaptive, Courant-number based implicit vertical advection +! contribution for u-momentum. +! + DO i=IstrU,Iend + WK(i,0)=0.5_r8*(Wi(i-1,j,0)+ & + & Wi(i ,j,0)) + tl_WK(i,0)=0.5_r8*(tl_Wi(i-1,j,0)+ & + & tl_Wi(i ,j,0)) + DO k=1,N(ng) + WK(i,k)=0.5_r8*(Wi(i-1,j,k)+ & + & Wi(i ,j,k)) + tl_WK(i,k)=0.5_r8*(tl_Wi(i-1,j,k)+ & + & tl_Wi(i ,j,k)) + Hzk(i,k)=0.5_r8*(Hz(i-1,j,k)+ & + & Hz(i ,j,k)) + tl_Hzk(i,k)=0.5_r8*(tl_Hz(i-1,j,k)+ & + & tl_Hz(i ,j,k)) + END DO + END DO +! +! Compute off-diagonal coefficients [dt*Wi*pm*pn] for the +! implicit vertical viscosity term at horizontal U-points and +! vertical W-points. +! + cff=dt(ng) + DO k=1,N(ng)-1 + DO i=IstrU,Iend + cff1=cff/(on_u(i,j)*om_u(i,j)) + FCmax(i,k)=MAX(WK(i,k),0.0_r8)*cff1 + FCmin(i,k)=MIN(WK(i,k),0.0_r8)*cff1 + tl_FCmax(i,k)=(0.5_r8+SIGN(0.5_r8, WK(i,k)))* & + & tl_WK(i,k)*cff1 + tl_FCmin(i,k)=(0.5_r8+SIGN(0.5_r8,-WK(i,k)))* & + & tl_WK(i,k)*cff1 + END DO + END DO + DO i=IstrU,Iend + FCmax(i,0)=0.0_r8 + FCmin(i,0)=0.0_r8 + FCmax(i,N(ng))=0.0_r8 + FCmin(i,N(ng))=0.0_r8 + + tl_FCmax(i,0)=0.0_r8 + tl_FCmin(i,0)=0.0_r8 + tl_FCmax(i,N(ng))=0.0_r8 + tl_FCmin(i,N(ng))=0.0_r8 + END DO +! +! Solve the tridiagonal system. +! + DO k=1,N(ng) + DO i=IstrU,Iend + BC(i,k)=Hzk(i,k)+FCmax(i,k)-FCmin(i,k-1) + tl_BC(i,k)=tl_Hzk(i,k)+tl_FCmax(i,k)-tl_FCmin(i,k-1) + DC(i,k)=u(i,j,k,nnew)*Hzk(i,k) + tl_DC(i,k)=tl_u(i,j,k,nnew)*Hzk(i,k)+ & + & u(i,j,k,nnew)*tl_Hzk(i,k) + END DO + END DO + DO i=IstrU,Iend + cff=1.0_r8/BC(i,1) + tl_cff=-cff*cff*tl_BC(i,1) + CF(i,1)=cff*FCmin(i,1) + tl_CF(i,1)=tl_cff*FCmin(i,1)+cff*tl_FCmin(i,1) + DC(i,1)=cff*DC(i,1) + tl_DC(i,1)=tl_cff*DC(i,1)+cff*tl_DC(i,1) + END DO + DO k=2,N(ng)-1 + DO i=IstrU,Iend + cff=1.0_r8/(BC(i,k)+FCmax(i,k-1)*CF(i,k-1)) + tl_cff=-cff*cff*(tl_BC(i,k)+ & + & tl_FCmax(i,k-1)*CF(i,k-1)+ & + & FCmax(i,k-1)*tl_CF(i,k-1)) + CF(i,k)=cff*FCmin(i,k) + tl_CF(i,k)=tl_cff*FCmin(i,k)+cff*tl_FCmin(i,k) + DC(i,k)=cff*(DC(i,k)+FCmax(i,k-1)*DC(i,k-1)) + tl_DC(i,k)=tl_cff*(DC(i,k)+FCmax(i,k-1)*DC(i,k-1))+ & + & cff*(DC(i,k)+ & + & tl_FCmax(i,k-1)*DC(i,k-1)+ & + & FCmax(i,k-1)*tl_DC(i,k-1)) + END DO + END DO +! +! Compute new solution by back substitution. +! + DO i=IstrU,Iend +# ifdef DIAGNOSTICS_UV +!! cff1=u(i,j,N(ng),nnew) +# endif + cff=1.0_r8/(BC(i,N(ng))+FCmax(i,N(ng)-1)*CF(i,N(ng)-1)) + tl_cff=-cff*cff*(tl_BC(i,N(ng))+ & + & tl_FCmax(i,N(ng)-1)*CF(i,N(ng)-1)+ & + & FCmax(i,N(ng)-1)*tl_CF(i,N(ng)-1)) + DC(i,N(ng))=cff*(DC(i,N(ng))+ & + & FCmax(i,N(ng)-1)*DC(i,N(ng)-1)) + tl_DC(i,N(ng))=tl_cff*(DC(i,N(ng))+ & + & FCmax(i,N(ng)-1)*DC(i,N(ng)-1))+ & + & cff*(tl_DC(i,N(ng))+ & + & tl_FCmax(i,N(ng)-1)*DC(i,N(ng)-1)+ & + & FCmax(i,N(ng)-1)*tl_DC(i,N(ng)-1)) +!^ u(i,j,N(ng),nnew)=DC(i,N(ng)) +!^ + tl_u(i,j,N(ng),nnew)=tl_DC(i,N(ng)) +# ifdef DIAGNOSTICS_UV +!! DiaRU(i,j,N(ng),nrhs,M3vadv)=DiaRU(i,j,N(ng),nrhs,M3vadv)+ & +!! & u(i,j,N(ng),nnew)-cff1 +# endif + END DO +! + DO k=N(ng)-1,1,-1 + DO i=IstrU,Iend +# ifdef DIAGNOSTICS_UV +!! cff1=u(i,j,k,nnew) +# endif + DC(i,k)=DC(i,k)-CF(i,k)*DC(i,k+1) + tl_DC(i,k)=tl_DC(i,k)- & + & tl_CF(i,k)*DC(i,k+1)- & + & CF(i,k)*tl_DC(i,k+1) +!^ u(i,j,k,nnew)=DC(i,k) +!^ + tl_u(i,j,k,nnew)=tl_DC(i,k) +# ifdef DIAGNOSTICS_UV +!! DiaRU(i,j,k,nrhs,M3vadv)=DiaRU(i,j,k,nrhs,M3vadv)+ & +!! & u(i,j,k,nnew)-cff1 +# endif + END DO + END DO +# endif ! ! Replace INTERIOR POINTS incorrect vertical mean with more accurate ! barotropic component, ubar=DU_avg1/(D*on_u). Recall that, D=CF(:,0). @@ -1271,6 +1450,136 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & END DO END DO # endif +# ifdef OMEGA_IMPLICIT +! +! Adaptive, Courant-number based implicit vertical advection +! contribution for v-momentum. +! + DO i=Istr,Iend + WK(i,0)=0.5_r8*(Wi(i,j-1,0)+ & + & Wi(i,j ,0)) + tl_WK(i,0)=0.5_r8*(tl_Wi(i,j-1,0)+ & + & tl_Wi(i,j ,0)) + DO k=1,N(ng) + WK(i,k)=0.5_r8*(Wi(i,j-1,k)+ & + & Wi(i,j ,k)) + tl_WK(i,k)=0.5_r8*(tl_Wi(i,j-1,k)+ & + & tl_Wi(i,j ,k)) + Hzk(i,k)=0.5_r8*(Hz(i,j-1,k)+ & + & Hz(i,j ,k)) + tl_Hzk(i,k)=0.5_r8*(tl_Hz(i,j-1,k)+ & + & tl_Hz(i,j ,k)) + END DO + END DO +! +! Compute off-diagonal coefficients [dt*Wi*pm*pn] for the +! implicit vertical viscosity term at horizontal V-points and +! vertical W-points. +! + cff=dt(ng) + DO k=1,N(ng)-1 + DO i=Istr,Iend + cff1=cff/(on_v(i,j)*om_v(i,j)) + FCmax(i,k)=MAX(WK(i,k),0.0_r8)*cff1 + FCmin(i,k)=MIN(WK(i,k),0.0_r8)*cff1 + tl_FCmax(i,k)=(0.5_r8+SIGN(0.5_r8, WK(i,k)))* & + & tl_WK(i,k)*cff1 + tl_FCmin(i,k)=(0.5_r8+SIGN(0.5_r8,-WK(i,k)))* & + & tl_WK(i,k)*cff1 + END DO + END DO + DO i=Istr,Iend + FCmax(i,0)=0.0_r8 + FCmin(i,0)=0.0_r8 + FCmax(i,N(ng))=0.0_r8 + FCmin(i,N(ng))=0.0_r8 + + tl_FCmax(i,0)=0.0_r8 + tl_FCmin(i,0)=0.0_r8 + tl_FCmax(i,N(ng))=0.0_r8 + tl_FCmin(i,N(ng))=0.0_r8 + END DO +! +! Solve the tridiagonal system. +! + DO k=1,N(ng) + DO i=Istr,Iend + BC(i,k)=Hzk(i,k)+FCmax(i,k)-FCmin(i,k-1) + tl_BC(i,k)=tl_Hzk(i,k)+tl_FCmax(i,k)-tl_FCmin(i,k-1) + DC(i,k)=v(i,j,k,nnew)*Hzk(i,k) + tl_DC(i,k)=tl_v(i,j,k,nnew)*Hzk(i,k)+ & + & v(i,j,k,nnew)*tl_Hzk(i,k) + END DO + END DO + DO i=Istr,Iend + cff=1.0_r8/BC(i,1) + tl_cff=-cff*cff*tl_BC(i,1) + CF(i,1)=cff*FCmin(i,1) + tl_CF(i,1)=tl_cff*FCmin(i,1)+cff*tl_FCmin(i,1) + DC(i,1)=cff*DC(i,1) + tl_DC(i,1)=tl_cff*DC(i,1)+cff*tl_DC(i,1) + END DO + DO k=2,N(ng)-1 + DO i=Istr,Iend + cff=1.0_r8/(BC(i,k)+FCmax(i,k-1)*CF(i,k-1)) + tl_cff=-cff*cff*(tl_BC(i,k)+ & + & tl_FCmax(i,k-1)*CF(i,k-1)+ & + & FCmax(i,k-1)*tl_CF(i,k-1)) + CF(i,k)=cff*FCmin(i,k) + tl_CF(i,k)=tl_cff*FCmin(i,k)+cff*tl_FCmin(i,k) + DC(i,k)=cff*(DC(i,k)+FCmax(i,k-1)*DC(i,k-1)) + tl_DC(i,k)=tl_cff*(DC(i,k)+FCmax(i,k-1)*DC(i,k-1))+ & + & cff*(DC(i,k)+ & + & tl_FCmax(i,k-1)*DC(i,k-1)+ & + & FCmax(i,k-1)*tl_DC(i,k-1)) + END DO + END DO +! +! Compute new solution by back substitution. +! + DO i=Istr,Iend +# ifdef DIAGNOSTICS_UV +!! cff1=v(i,j,N(ng),nnew) +# endif + cff=1.0_r8/(BC(i,N(ng))+FCmax(i,N(ng)-1)*CF(i,N(ng)-1)) + tl_cff=-cff*cff*(tl_BC(i,N(ng))+ & + & tl_FCmax(i,N(ng)-1)*CF(i,N(ng)-1)+ & + & FCmax(i,N(ng)-1)*tl_CF(i,N(ng)-1)) + DC(i,N(ng))=cff*(DC(i,N(ng))+ & + & FCmax(i,N(ng)-1)*DC(i,N(ng)-1)) + tl_DC(i,N(ng))=tl_cff*(DC(i,N(ng))+ & + & FCmax(i,N(ng)-1)*DC(i,N(ng)-1))+ & + & cff*(tl_DC(i,N(ng))+ & + & tl_FCmax(i,N(ng)-1)*DC(i,N(ng)-1)+ & + & FCmax(i,N(ng)-1)*tl_DC(i,N(ng)-1)) +!^ v(i,j,N(ng),nnew)=DC(i,N(ng)) +!^ + tl_v(i,j,N(ng),nnew)=tl_DC(i,N(ng)) +# ifdef DIAGNOSTICS_UV +!! DiaRV(i,j,N(ng),nrhs,M3vadv)=DiaRV(i,j,N(ng),nrhs,M3vadv)+ & +!! & v(i,j,N(ng),nnew)-cff1 +# endif + END DO +! + DO k=N(ng)-1,1,-1 + DO i=Istr,Iend +# ifdef DIAGNOSTICS_UV +!! cff1=v(i,j,k,nnew) +# endif + DC(i,k)=DC(i,k)-CF(i,k)*DC(i,k+1) + tl_DC(i,k)=tl_DC(i,k)- & + & tl_CF(i,k)*DC(i,k+1)- & + & CF(i,k)*tl_DC(i,k+1) +!^ v(i,j,k,nnew)=DC(i,k) +!^ + tl_v(i,j,k,nnew)=tl_DC(i,k) +# ifdef DIAGNOSTICS_UV +!! DiaRV(i,j,k,nrhs,M3vadv)=DiaRV(i,j,k,nrhs,M3vadv)+ & +!! & v(i,j,k,nnew)-cff1 +# endif + END DO + END DO +# endif ! ! Replace INTERIOR POINTS incorrect vertical mean with more accurate ! barotropic component, vbar=DV_avg1/(D*om_v). Recall that, D=CF(:,0). @@ -1632,16 +1941,36 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & & CFs(i,0) # endif # endif +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +!^ ubar(i,j,knew)=DC(i,0)*DU_avg1(i,j) +!^ + tl_ubar(i,j,knew)=tl_DC(i,0)*DU_avg1(i,j)+ & + & DC(i,0)*tl_DU_avg1(i,j)- & +# ifdef TL_IOMS + & DC(i,0)*DU_avg1(i,j) +# endif +# ifdef WET_DRY_NOT_YET +!^ ubar(i,j,knew)=ubar(i,j,knew)*umask_wet(i,j) +!^ +!! tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask_wet(i,j) +# endif +# else !^ ubar(i,j,1)=DC(i,0)*DU_avg1(i,j) !^ tl_ubar(i,j,1)=tl_DC(i,0)*DU_avg1(i,j)+ & & DC(i,0)*tl_DU_avg1(i,j)- & -# ifdef TL_IOMS +# ifdef TL_IOMS & DC(i,0)*DU_avg1(i,j) -# endif +# endif +# ifdef WET_DRY_NOT_YET +!^ ubar(i,j,1)=ubar(i,j,1)*umask_wet(i,j) +!^ +!! tl_ubar(i,j,1)=tl_ubar(i,j,1)*umask_wet(i,j) +# endif !^ ubar(i,j,2)=ubar(i,j,1) !^ tl_ubar(i,j,2)=tl_ubar(i,j,1) +# endif # ifdef DIAGNOSTICS_UV !! DiaU2wrk(i,j,M2rate)=ubar(i,j,1)-DiaU2int(i,j,M2rate)*DC(i,0) !! DiaU2int(i,j,M2rate)=ubar(i,j,1)*DC1(i,0) @@ -1982,16 +2311,36 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & & CF(i,0) # endif # endif +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +!^ vbar(i,j,knew)=DC(i,0)*DV_avg1(i,j) +!^ + tl_vbar(i,j,knew)=tl_DC(i,0)*DV_avg1(i,j)+ & + & DC(i,0)*tl_DV_avg1(i,j)- & +# ifdef TL_IOMS + & DC(i,0)*DV_avg1(i,j) +# endif +# ifdef WET_DRY_NOT_YET +!^ vbar(i,j,knew)=vbar(i,j,knew)*vmask_wet(i,j) +!^ +!! tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask_wet(i,j) +# endif +# else !^ vbar(i,j,1)=DC(i,0)*DV_avg1(i,j) !^ tl_vbar(i,j,1)=tl_DC(i,0)*DV_avg1(i,j)+ & & DC(i,0)*tl_DV_avg1(i,j)- & -# ifdef TL_IOMS +# ifdef TL_IOMS & DC(i,0)*DV_avg1(i,j) -# endif +# endif +# ifdef WET_DRY_NOT_YET +!^ vbar(i,j,1)=vbar(i,j,1)*vmask_wet(i,j) +!^ +!! tl_vbar(i,j,1)=tl_vbar(i,j,1)*vmask_wet(i,j) +# endif !^ vbar(i,j,2)=vbar(i,j,1) !^ tl_vbar(i,j,2)=tl_vbar(i,j,1) +# endif # ifdef DIAGNOSTICS_UV !! DiaV2wrk(i,j,M2rate)=vbar(i,j,1)- & !! & DiaV2int(i,j,M2rate)*DC(i,0) @@ -2138,7 +2487,7 @@ SUBROUTINE rp_step3d_uv_tile (ng, tile, & !^ v(i,j,k,nnew)=v(i,j,k,nnew)* & !^ & vmask_wet(i,j) !^ - tl_v(i,j,k,nnew)=tl_v(i,j,k,nnew)* + tl_v(i,j,k,nnew)=tl_v(i,j,k,nnew)* & & vmask_wet(i,j) # endif # ifdef WEC_NOT_YET diff --git a/ROMS/Representer/rp_zetabc.F b/ROMS/Representer/rp_zetabc.F index 1b564e799..76f751c41 100644 --- a/ROMS/Representer/rp_zetabc.F +++ b/ROMS/Representer/rp_zetabc.F @@ -9,28 +9,41 @@ MODULE rp_zetabc_mod ! See License_ROMS.md ! !======================================================================= ! ! -! This subroutine sets repesenters tangent linear lateral boundary ! -! conditions for free-surface. It updates the specified "kout" time ! -! index. ! +! This routine sets finite amplitude tangent linear lateral boundary ! +! conditions for free-surface. ! +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +! +! Notice that "zetabc_local" is used for either the Forward-Backward ! +! AB3-AM4 or Forward-Backward LF-AM3 barotropic kernels where the ! +! boundary conditions are loaded into private array "zeta_new". ! +# endif ! ! ! BASIC STATE variables fields needed: zeta ! ! ! !======================================================================= +! + USE mod_param + USE mod_boundary + USE mod_grid + USE mod_ncparam + USE mod_ocean + USE mod_scalars + USE mod_stepping ! implicit none ! PRIVATE - PUBLIC :: rp_zetabc, rp_zetabc_tile + PUBLIC :: rp_zetabc +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + PUBLIC :: rp_zetabc_local +# endif + PUBLIC :: rp_zetabc_tile ! CONTAINS ! !*********************************************************************** SUBROUTINE rp_zetabc (ng, tile, kout) !*********************************************************************** -! - USE mod_param - USE mod_ocean - USE mod_stepping ! ! Imported variable declarations. ! @@ -57,12 +70,6 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & & krhs, kstp, kout, & & zeta, tl_zeta) !*********************************************************************** -! - USE mod_param - USE mod_boundary - USE mod_grid - USE mod_ncparam - USE mod_scalars ! ! Imported variable declarations. ! @@ -72,13 +79,13 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & integer, intent(in) :: krhs, kstp, kout ! # ifdef ASSUMED_SHAPE - real(r8), intent(in) :: zeta(LBi:,LBj:,:) + real(r8), intent(in ) :: zeta(LBi:,LBj:,:) real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:) # else - real(r8), intent(in) :: zeta(LBi:UBi,LBj:UBj,3) + real(r8), intent(in ) :: zeta(LBi:UBi,LBj:UBj,:) - real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,3) + real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:) # endif ! ! Local variable declarations. @@ -99,6 +106,10 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & ! Set time-indices !----------------------------------------------------------------------- ! +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + know=kstp + dt2d=dtfast(ng) +# else IF (FIRST_2D_STEP) THEN know=krhs dt2d=dtfast(ng) @@ -109,6 +120,7 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & know=kstp dt2d=dtfast(ng) END IF +# endif ! !----------------------------------------------------------------------- ! Lateral boundary conditions at the western edge. @@ -144,7 +156,6 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & Ce=0.0_r8 # endif cff=BOUNDARY(ng)%zeta_west_C2(j) -# endif !^ zeta(Istr-1,j,kout)=(cff*zeta(Istr-1,j,know)+ & !^ & Cx *zeta(Istr ,j,kout)- & !^ & MAX(Ce,0.0_r8)*grad(Istr-1,j )- & @@ -167,6 +178,11 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & tl_zeta(Istr-1,j,kout)=tl_zeta(Istr-1,j,kout)- & & tau*tl_zeta(Istr-1,j,know) END IF +# else +!^ zeta(Istr-1,j,kout)=zeta(Istr,j,kout) ! gradient +!^ + tl_zeta(Istr-1,j,kout)=tl_zeta(Istr,j,kout) +# endif # ifdef MASKING !^ zeta(Istr-1,j,kout)=zeta(Istr-1,j,kout)* & !^ & GRID(ng)%rmask(Istr-1,j) @@ -199,9 +215,10 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & tl_zeta(Istr-1,j,kout)=(1.0_r8-Cx)*tl_zeta(Istr-1,j,know)+& & tl_Cx*(zeta(Istr-1,j,know)+ & & zeta(Istr ,j,know))+ & - & Cx*tl_zeta(Istr,j,know) + & Cx*tl_zeta(Istr,j,know)+ & # ifdef TL_IOMS -!! HGA: we need code here... + & Cx*(zeta(Istr-1,j,know)- & + & zeta(Istr ,j,know)) # endif # ifdef MASKING !^ zeta(Istr-1,j,kout)=zeta(Istr-1,j,kout)* & @@ -257,7 +274,7 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & ! ! Western edge, clamped boundary condition. ! - ELSE IF (tl_LBC(iwest,isFsur,ng)%gradient) THEN + ELSE IF (tl_LBC(iwest,isFsur,ng)%clamped) THEN DO j=Jstr,Jend IF (LBC_apply(ng)%west(j)) THEN !^ zeta(Istr-1,j,kout)=BOUNDARY(ng)%zeta_west(j) @@ -345,7 +362,7 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & Ce=0.0_r8 # endif cff=BOUNDARY(ng)%zeta_east_C2(j) -# endif + !^ zeta(Iend+1,j,kout)=(cff*zeta(Iend+1,j,know)+ & !^ & Cx *zeta(Iend ,j,kout)- & !^ & MAX(Ce,0.0_r8)*grad(Iend+1,j )- & @@ -368,6 +385,11 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & tl_zeta(Iend+1,j,kout)=tl_zeta(Iend+1,j,kout)- & & tau*tl_zeta(Iend+1,j,know) END IF +# else +!^ zeta(Iend+1,j,kout)=zeta(Iend,j,kout) ! gradient +!^ + tl_zeta(Iend+1,j,kout)=tl_zeta(Iend,j,kout) +# endif # ifdef MASKING !^ zeta(Iend+1,j,kout)=zeta(Iend+1,j,kout)* & !^ & GRID(ng)%rmask(Iend+1,j) @@ -400,9 +422,10 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & tl_zeta(Iend+1,j,kout)=(1.0_r8-Cx)*tl_zeta(Iend+1,j,know)+& & tl_Cx*(zeta(Iend+1,j,know)+ & & zeta(Iend ,j,know))+ & - & Cx*tl_zeta(Iend,j,know) + & Cx*tl_zeta(Iend,j,know)+ & # ifdef TL_IOMS -!! HGA: we need code here... + & Cx*(zeta(Iend+1,j,know)- & + & zeta(Iend ,j,know)) # endif # ifdef MASKING !^ zeta(Iend+1,j,kout)=zeta(Iend+1,j,kout)* & @@ -546,7 +569,7 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & # endif Ce=BOUNDARY(ng)%zeta_south_Ce(i) cff=BOUNDARY(ng)%zeta_south_C2(i) -# endif + !^ zeta(i,Jstr-1,kout)=(cff*zeta(i,Jstr-1,know)+ & !^ & Ce *zeta(i,Jstr ,kout)- & !^ & MAX(Cx,0.0_r8)*grad(i ,Jstr)- & @@ -569,6 +592,11 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & tl_zeta(i,Jstr-1,kout)=tl_zeta(i,Jstr-1,kout)- & & tau*tl_zeta(i,Jstr-1,know) END IF +# else +!^ zeta(i,Jstr-1,kout)=zeta(i,Jstr,kout) ! gradient +!^ + tl_zeta(i,Jstr-1,kout)=tl_zeta(i,Jstr,kout) +# endif # ifdef MASKING !^ zeta(i,Jstr-1,kout)=zeta(i,Jstr-1,kout)* & !^ & GRID(ng)%rmask(i,Jstr-1) @@ -601,9 +629,10 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & tl_zeta(i,Jstr-1,kout)=(1.0_r8-Ce)*tl_zeta(i,Jstr-1,know)+& & tl_Ce*(zeta(i,Jstr-1,know)+ & & zeta(i,Jstr ,know))+ & - & Ce*tl_zeta(i,Jstr,know) + & Ce*tl_zeta(i,Jstr,know)+ & # ifdef TL_IOMS -!! HGA: we need code here... + & Ce*(zeta(i,Jstr-1,know)- & + & zeta(i,Jstr ,know)) # endif # ifdef MASKING !^ zeta(i,Jstr-1,kout)=zeta(i,Jstr-1,kout)* & @@ -747,7 +776,7 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & # endif Ce=BOUNDARY(ng)%zeta_north_Ce(i) cff=BOUNDARY(ng)%zeta_north_C2(i) -# endif + !^ zeta(i,Jend+1,kout)=(cff*zeta(i,Jend+1,know)+ & !^ & Ce *zeta(i,Jend ,kout)- & !^ & MAX(Cx,0.0_r8)*grad(i ,Jend+1)- & @@ -770,6 +799,11 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & tl_zeta(i,Jend+1,kout)=tl_zeta(i,Jend+1,kout)- & & tau*tl_zeta(i,Jend+1,know) END IF +# else +!^ zeta(i,Jend+1,kout)=zeta(i,Jend,kout) ! gradient +!^ + tl_zeta(i,Jend+1,kout)=tl_zeta(i,Jend,kout) +# endif # ifdef MASKING !^ zeta(i,Jend+1,kout)=zeta(i,Jend+1,kout)* & !^ & GRID(ng)%rmask(i,Jend+1) @@ -802,9 +836,10 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & tl_zeta(i,Jend+1,kout)=(1.0_r8-Ce)*tl_zeta(i,Jend+1,know)+& & tl_Ce*(zeta(i,Jend+1,know)+ & & zeta(i,Jend ,know))+ & - & Ce*tl_zeta(i,Jend,know) + & Ce*tl_zeta(i,Jend,know)+ & # ifdef TL_IOMS -!! HGA: we need code here... + & Ce*(zeta(i,Jend+1,know)- & + & zeta(i,Jend ,know)) # endif # ifdef MASKING !^ zeta(i,Jend+1,kout)=zeta(i,Jend+1,kout)* & @@ -998,7 +1033,7 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & END DO END IF END IF - +! IF (.not.NSperiodic(ng)) THEN IF (DOMAIN(ng)%Southern_Edge(tile)) THEN DO i=Istr,Iend @@ -1025,7 +1060,7 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & END DO END IF END IF - +! IF (.not.(EWperiodic(ng).or.NSperiodic(ng))) THEN IF (DOMAIN(ng)%SouthWest_Corner(tile)) THEN IF (LBC_apply(ng)%south(Istr-1).and. & @@ -1073,9 +1108,1049 @@ SUBROUTINE rp_zetabc_tile (ng, tile, & END IF END IF # endif - +! RETURN END SUBROUTINE rp_zetabc_tile -#endif - END MODULE rp_zetabc_mod +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +! +!*********************************************************************** + SUBROUTINE rp_zetabc_local (ng, tile, & + & LBi, UBi, LBj, UBj, & + & IminS, ImaxS, JminS, JmaxS, & + & kstp, & + & zeta, tl_zeta, & + & zeta_new, tl_zeta_new) +!*********************************************************************** +! +! Imported variable declarations. +! + integer, intent(in) :: ng, tile + integer, intent(in) :: LBi, UBi, LBj, UBj + integer, intent(in) :: IminS, ImaxS, JminS, JmaxS + integer, intent(in) :: kstp +! +# ifdef ASSUMED_SHAPE + real(r8), intent(in ) :: zeta(LBi:,LBj:,:) + real(r8), intent(in ) :: tl_zeta(LBi:,LBj:,:) + real(r8), intent(in ) :: zeta_new(IminS:,JminS:) + + real(r8), intent(inout) :: tl_zeta_new(IminS:,JminS:) +# else + real(r8), intent(in ) :: zeta(LBi:UBi,LBj:UBj,:) + real(r8), intent(in ) :: tl_zeta(LBi:UBi,LBj:UBj,:) + real(r8), intent(in ) :: zeta_new(IminS:ImaxS,JminS:JmaxS) + + real(r8), intent(inout) :: tl_zeta_new(IminS:ImaxS,JminS:JmaxS) +# endif +! +! Local variable declarations. +! + integer :: i, j, know + + real(r8) :: Ce, Cx + real(r8) :: cff, cff1, cff2, dt2d, tau + + real(r8) :: tl_Ce, tl_Cx + real(r8) :: tl_cff1, tl_cff2 + + real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_grad + +# include "set_bounds.h" +! +!----------------------------------------------------------------------- +! Set time-indices +!----------------------------------------------------------------------- +! + know=kstp + dt2d=dtfast(ng) +! +!----------------------------------------------------------------------- +! Lateral boundary conditions at the western edge. +!----------------------------------------------------------------------- +! + IF (DOMAIN(ng)%Western_Edge(tile)) THEN +! +! Western edge, implicit upstream radiation condition. +! + IF (tl_LBC(iwest,isFsur,ng)%radiation) THEN + IF (iic(ng).ne.0) THEN + DO j=JstrV-1,Jend+1 +!^ grad(Istr-1,j)=zeta(Istr-1,j ,know)- & +!^ & zeta(Istr-1,j-1,know) +!^ + tl_grad(Istr-1,j)=0.0_r8 + END DO + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN +# if defined CELERITY_READ && defined FORWARD_READ + IF (tl_LBC(iwest,isFsur,ng)%nudging) THEN + IF (BOUNDARY(ng)%zeta_west_Cx(j).eq.0.0_r8) THEN + tau=FSobc_in(ng,iwest) + ELSE + tau=FSobc_out(ng,iwest) + END IF + tau=tau*dt2d + END IF + Cx=BOUNDARY(ng)%zeta_west_Cx(j) +# ifdef RADIATION_2D + Ce=BOUNDARY(ng)%zeta_west_Ce(j) +# else + Ce=0.0_r8 +# endif + cff=BOUNDARY(ng)%zeta_west_C2(j) + +!^ zeta_new(Istr-1,j)=(cff*zeta(Istr-1,j,know)+ & +!^ & Cx *zeta_new(Istr,j)- & +!^ & MAX(Ce,0.0_r8)*grad(Istr-1,j )- & +!^ & MIN(Ce,0.0_r8)*grad(Istr-1,j+1))/ & +!^ & (cff+Cx) +!^ + tl_zeta_new(Istr-1,j)=(cff*tl_zeta(Istr-1,j,know)+ & + & Cx *tl_zeta_new(Istr,j)- & + & MAX(Ce,0.0_r8)* & + & tl_grad(Istr-1,j )- & + & MIN(Ce,0.0_r8)* & + & tl_grad(Istr-1,j+1))/ & + & (cff+Cx) + + IF (tl_LBC(iwest,isFsur,ng)%nudging) THEN +!^ zeta_new(Istr-1,j)=zeta_new(Istr-1,j)+ & +!^ & tau*(BOUNDARY(ng)%zeta_west(j)- & +!^ & zeta(Istr-1,j,know)) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)- & + & tau*tl_zeta(Istr-1,j,know) + END IF +# else +!^ zeta_new(Istr-1,j)=zeta_new(Istr,j) ! gradient +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr,j) +# endif +# ifdef MASKING +!^ zeta_new(Istr-1,j)=zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif + END IF + END DO + END IF +! +! Western edge, explicit Chapman boundary condition. +! + ELSE IF (tl_LBC(iwest,isFsur,ng)%Chapman_explicit) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN + cff=dt2d*GRID(ng)%pm(Istr,j) + cff1=SQRT(g*(GRID(ng)%h(Istr,j)+ & + & zeta(Istr,j,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(Istr,j)+ & + & tl_zeta(Istr,j,know))/cff1+ & +# ifdef TL_IOMS + & 0.5_r8*cff1 +# endif + Cx=cff*cff1 + tl_Cx=cff*tl_cff1 +!^ zeta_new(Istr-1,j)=(1.0_r8-Cx)*zeta(Istr-1,j,know)+ & +!^ & Cx*zeta(Istr,j,know) +!^ + tl_zeta_new(Istr-1,j)=(1.0_r8-Cx)*tl_zeta(Istr-1,j,know)+ & + & tl_Cx*(zeta(Istr-1,j,know)+ & + & zeta(Istr ,j,know))+ & + & Cx*tl_zeta(Istr,j,know) +# ifdef MASKING +!^ zeta_new(Istr-1,j)=zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif + END IF + END DO +! +! Western edge, implicit Chapman boundary condition. +! + ELSE IF (tl_LBC(iwest,isFsur,ng)%Chapman_implicit) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN + cff=dt2d*GRID(ng)%pm(Istr,j) + cff1=SQRT(g*(GRID(ng)%h(Istr,j)+ & + & zeta(Istr,j,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(Istr,j)+ & + & tl_zeta(Istr,j,know))/cff1+ & +# ifdef TL_IOMS + & 0.5_r8*cff1 +# endif + Cx=cff*cff1 + tl_Cx=cff*tl_cff1 + cff2=1.0_r8/(1.0_r8+Cx) + tl_cff2=-cff2*cff2*tl_Cx+ & +# ifdef TL_IOMS + & cff2*cff2*(1.0_r8+2.0_r8*Cx) +# endif +!^ zeta_new(Istr-1,j)=cff2*(zeta(Istr-1,j,know)+ & +!^ & Cx*zeta_new(Istr,j)) +!^ + tl_zeta_new(Istr-1,j)=tl_cff2*(zeta(Istr-1,j,know)+ & + & Cx*zeta_new(Istr,j))+ & + & cff2*(tl_zeta(Istr-1,j,know)+ & + & tl_Cx*zeta_new(Istr,j)+ & + & Cx*tl_zeta_new(Istr,j))- & +# ifdef TL_IOMS + & cff2*(zeta(Istr-1,j,know)+ & + & 2.0_r8*Cx*zeta_new(Istr,j)) +# endif +# ifdef MASKING +!^ zeta_new(Istr-1,j)=zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif + END IF + END DO +! +! Western edge, clamped boundary condition. +! + ELSE IF (tl_LBC(iwest,isFsur,ng)%clamped) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN +!^ zeta_new(Istr-1,j)=BOUNDARY(ng)%zeta_west(j) +!^ + tl_zeta_new(Istr-1,j)=BOUNDARY(ng)%tl_zeta_west(j) +# ifdef MASKING +!^ zeta_new(Istr-1,j)=zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif + END IF + END DO +! +! Western edge, gradient boundary condition. +! + ELSE IF (tl_LBC(iwest,isFsur,ng)%gradient) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN +!^ zeta_new(Istr-1,j)=zeta_new(Istr,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr,j) +# ifdef MASKING +!^ zeta_new(Istr-1,j)=zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif + END IF + END DO +! +! Western edge, closed boundary condition. +! + ELSE IF (tl_LBC(iwest,isFsur,ng)%closed) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN +!^ zeta_new(Istr-1,j)=zeta_new(Istr,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr,j) +# ifdef MASKING +!^ zeta_new(Istr-1,j)=zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif + END IF + END DO + END IF + END IF +! +!----------------------------------------------------------------------- +! Lateral boundary conditions at the eastern edge. +!----------------------------------------------------------------------- +! + IF (DOMAIN(ng)%Eastern_Edge(tile)) THEN +! +! Eastern edge, implicit upstream radiation condition. +! + IF (tl_LBC(ieast,isFsur,ng)%radiation) THEN + IF (iic(ng).ne.0) THEN + DO j=JstrV-1,Jend+1 +!^ grad(Iend+1,j)=zeta(Iend+1,j ,know)- & +!^ & zeta(Iend+1,j-1,know) +!^ + tl_grad(Iend+1,j)=0.0_r8 + END DO + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN +# if defined CELERITY_READ && defined FORWARD_READ + IF (tl_LBC(ieast,isFsur,ng)%nudging) THEN + IF (BOUNDARY(ng)%zeta_east_Cx(j).eq.0.0_r8) THEN + tau=FSobc_in(ieast) + ELSE + tau=FSobc_out(ieast) + END IF + tau=tau*dt2d + END IF + Cx=BOUNDARY(ng)%zeta_east_Cx(j) +# ifdef RADIATION_2D + Ce=BOUNDARY(ng)%zeta_east_Ce(j) +# else + Ce=0.0_r8 +# endif + cff=BOUNDARY(ng)%zeta_east_C2(j) + +!^ zeta_new(Iend+1,j)=(cff*zeta(Iend+1,j,know)+ & +!^ & Cx *zeta_new(Iend,j)- & +!^ & MAX(Ce,0.0_r8)*grad(Iend+1,j )- & +!^ & MIN(Ce,0.0_r8)*grad(Iend+1,j+1))/ & +!^ & (cff+Cx) +!^ + tl_zeta_new(Iend+1,j)=(cff*tl_zeta(Iend+1,j,know)+ & + & Cx *tl_zeta_new(Iend,j)- & + & MAX(Ce,0.0_r8)* & + & tl_grad(Iend+1,j )- & + & MIN(Ce,0.0_r8)* & + & tl_grad(Iend+1,j+1))/ & + & (cff+Cx) + + IF (tl_LBC(ieast,isFsur,ng)%nudging) THEN +!^ zeta_new(Iend+1,j)=zeta_new(Iend+1,j)+ & +!^ & tau*(BOUNDARY(ng)%zeta_east(j)- & +!^ & zeta(Iend+1,j,know)) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)- & + & tau*tl_zeta(Iend+1,j,know) + END IF +# else +!^ zeta_new(Iend+1,j)=zeta_new(Iend,j) ! gradient +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend,j) +# endif +# ifdef MASKING +!^ zeta_new(Iend+1,j)=zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif + END IF + END DO + END IF +! +! Eastern edge, explicit Chapman boundary condition. +! + ELSE IF (tl_LBC(ieast,isFsur,ng)%Chapman_explicit) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN + cff=dt2d*GRID(ng)%pm(Iend,j) + cff1=SQRT(g*(GRID(ng)%h(Iend,j)+ & + & zeta(Iend,j,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(Iend,j)+ & + & tl_zeta(Iend,j,know))/cff1+ & +# ifdef TL_IOMS + & 0.5_r8*cff1 +# endif + Cx=cff*cff1 + tl_Cx=cff*tl_cff1 +!^ zeta_new(Iend+1,j)=(1.0_r8-Cx)*zeta(Iend+1,j,know)+ & +!^ & Cx*zeta(Iend,j,know) +!^ + tl_zeta_new(Iend+1,j)=(1.0_r8-Cx)*tl_zeta(Iend+1,j,know)+ & + & tl_Cx*(zeta(Iend+1,j,know)+ & + & zeta(Iend ,j,know))+ & + & Cx*tl_zeta(Iend,j,know)+ & +# ifdef TL_IOMS + & Cx*(zeta(Iend+1,j,know)- & + & zeta(Iend ,j,know)) +# endif +# ifdef MASKING +!^ zeta_new(Iend+1,j)=zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif + END IF + END DO +! +! Eastern edge, implicit Chapman boundary condition. +! + ELSE IF (tl_LBC(ieast,isFsur,ng)%Chapman_implicit) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN + cff=dt2d*GRID(ng)%pm(Iend,j) + cff1=SQRT(g*(GRID(ng)%h(Iend,j)+ & + & zeta(Iend,j,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(Iend,j)+ & + & tl_zeta(Iend,j,know))/cff1+ & +# ifdef TL_IOMS + & 0.5_r8*cff1 +# endif + Cx=cff*cff1 + tl_Cx=cff*tl_cff1 + cff2=1.0_r8/(1.0_r8+Cx) + tl_cff2=-cff2*cff2*tl_Cx+ & +# ifdef TL_IOMS + & cff2*cff2*(1.0_r8+2.0_r8*Cx) +# endif +!^ zeta_new(Iend+1,j)=cff2*(zeta(Iend+1,j,know)+ & +!^ & Cx*zeta_new(Iend,j)) +!^ + tl_zeta_new(Iend+1,j)=tl_cff2*(zeta(Iend+1,j,know)+ & + & Cx*zeta_new(Iend,j))+ & + & cff2*(tl_zeta(Iend+1,j,know)+ & + & tl_Cx*zeta_new(Iend,j)+ & + & Cx*tl_zeta_new(Iend,j))- & +# ifdef TL_IOMS + & cff2*(zeta(Iend+1,j,know)+ & + & 2.0_r8*Cx*zeta_new(Iend,j)) +# endif +# ifdef MASKING +!^ zeta_new(Iend+1,j)=zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif + END IF + END DO +! +! Eastern edge, clamped boundary condition. +! + ELSE IF (tl_LBC(ieast,isFsur,ng)%clamped) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN +!^ zeta_new(Iend+1,j)=BOUNDARY(ng)%zeta_east(j) +!^ + tl_zeta_new(Iend+1,j)=BOUNDARY(ng)%tl_zeta_east(j) +# ifdef MASKING +!^ zeta_new(Iend+1,j)=zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif + END IF + END DO +! +! Eastern edge, gradient boundary condition. +! + ELSE IF (tl_LBC(ieast,isFsur,ng)%gradient) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN +!^ zeta_new(Iend+1,j)=zeta_new(Iend,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend,j) +# ifdef MASKING +!^ zeta_new(Iend+1,j)=zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif + END IF + END DO +! +! Eastern edge, closed boundary condition. +! + ELSE IF (tl_LBC(ieast,isFsur,ng)%closed) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN +!^ zeta_new(Iend+1,j)=zeta_new(Iend,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend,j) +# ifdef MASKING +!^ zeta_new(Iend+1,j)=zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif + END IF + END DO + END IF + END IF +! +!----------------------------------------------------------------------- +! Lateral boundary conditions at the southern edge. +!----------------------------------------------------------------------- +! + IF (DOMAIN(ng)%Southern_Edge(tile)) THEN +! +! Southern edge, implicit upstream radiation condition. +! + IF (tl_LBC(isouth,isFsur,ng)%radiation) THEN + IF (iic(ng).ne.0) THEN + DO i=IstrU-1,Iend+1 +!^ grad(i,Jstr)=zeta(i ,Jstr,know)- & +!^ & zeta(i-1,Jstr,know) +!^ + tl_grad(i,Jstr)=0.0_r8 + END DO + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN +# if defined CELERITY_READ && defined FORWARD_READ + IF (tl_LBC(isouth,isFsur,ng)%nudging) THEN + IF (BOUNDARY(ng)%zeta_south_Ce(i).eq.0.0_r8) THEN + tau=FSobc_in(ng,isouth) + ELSE + tau=FSobc_out(ng,isouth) + END IF + tau=tau*dt2d + END IF +# ifdef RADIATION_2D + Cx=BOUNDARY(ng)%zeta_south_Cx(i) +# else + Cx=0.0_r8 +# endif + Ce=BOUNDARY(ng)%zeta_south_Ce(i) + cff=BOUNDARY(ng)%zeta_south_C2(i) + +!^ zeta_new(i,Jstr-1)=(cff*zeta(i,Jstr-1,know)+ & +!^ & Ce *zeta_new(i,Jstr)- & +!^ & MAX(Cx,0.0_r8)*grad(i ,Jstr)- & +!^ & MIN(Cx,0.0_r8)*grad(i+1,Jstr))/ & +!^ & (cff+Ce) +!^ + tl_zeta_new(i,Jstr-1)=(cff*tl_zeta(i,Jstr-1,know)+ & + & Ce *tl_zeta_new(i,Jstr)- & + & MAX(Cx,0.0_r8)* & + & tl_grad(i ,Jstr-1)- & + & MIN(Cx,0.0_r8)* & + & tl_grad(i+1,Jstr-1))/ & + & (cff+Ce) + + IF (tl_LBC(isouth,isFsur,ng)%nudging) THEN +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr-1)+ & +!^ & tau*(BOUNDARY(ng)%zeta_south(i)- & +!^ & zeta(i,Jstr-1,know)) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)- & + & tau*tl_zeta(i,Jstr-1,know) + END IF +# else +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr) ! gradient +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr) +# endif +# ifdef MASKING +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif + END IF + END DO + END IF +! +! Southern edge, explicit Chapman boundary condition. +! + ELSE IF (tl_LBC(isouth,isFsur,ng)%Chapman_explicit) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN + cff=dt2d*GRID(ng)%pn(i,Jstr) + cff1=SQRT(g*(GRID(ng)%h(i,Jstr)+ & + & zeta(i,Jstr,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(i,Jstr)+ & + & tl_zeta(i,Jstr,know))/cff1+ & +# ifdef TL_IOMS + & 0.5_r8*cff1 +# endif + Ce=cff*cff1 + tl_Ce=cff*tl_cff1 +!^ zeta_new(i,Jstr-1)=(1.0_r8-Ce)*zeta(i,Jstr-1,know)+ & +!^ & Ce*zeta(i,Jstr,know) +!^ + tl_zeta_new(i,Jstr-1)=(1.0_r8-Ce)*tl_zeta(i,Jstr-1,know)+ & + & tl_Ce*(zeta(i,Jstr-1,know)+ & + & zeta(i,Jstr ,know))+ & + & Ce*tl_zeta(i,Jstr,know)+ & +# ifdef TL_IOMS + & Ce*(zeta(i,Jstr-1,know)- & + & zeta(i,Jstr ,know)) +# endif +# ifdef MASKING +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif + END IF + END DO +! +! Southern edge, implicit Chapman boundary condition. +! + ELSE IF (tl_LBC(isouth,isFsur,ng)%Chapman_implicit) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN + cff=dt2d*GRID(ng)%pn(i,Jstr) + cff1=SQRT(g*(GRID(ng)%h(i,Jstr)+ & + & zeta(i,Jstr,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(i,Jstr)+ & + & tl_zeta(i,Jstr,know))/cff1+ & +# ifdef TL_IOMS + & 0.5_r8*cff1 +# endif + Ce=cff*cff1 + tl_Ce=cff*tl_cff1 + cff2=1.0_r8/(1.0_r8+Ce) + tl_cff2=-cff2*cff2*tl_Ce+ & +# ifdef TL_IOMS + & cff2*cff2*(1.0_r8+2.0_r8*Ce) +# endif +!^ zeta_new(i,Jstr-1)=cff2*(zeta(i,Jstr-1,know)+ & +!^ & Ce*zeta_new(i,Jstr)) +!^ + tl_zeta_new(i,Jstr-1)=tl_cff2*(zeta(i,Jstr-1,know)+ & + & Ce*zeta_new(i,Jstr))+ & + & cff2*(tl_zeta(i,Jstr-1,know)+ & + & tl_Ce*zeta_new(i,Jstr)+ & + & Ce*tl_zeta_new(i,Jstr))- & +# ifdef TL_IOMS + & cff2*(zeta(i,Jstr-1,know)+ & + & 2.0_r8*Ce*zeta_new(i,Jstr)) +# endif +# ifdef MASKING +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif + END IF + END DO +! +! Southern edge, clamped boundary condition. +! + ELSE IF (tl_LBC(isouth,isFsur,ng)%clamped) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN +!^ zeta_new(i,Jstr-1)=BOUNDARY(ng)%zeta_south(i) +!^ + tl_zeta_new(i,Jstr-1)=BOUNDARY(ng)%tl_zeta_south(i) +# ifdef MASKING +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif + END IF + END DO +! +! Southern edge, gradient boundary condition. +! + ELSE IF (tl_LBC(isouth,isFsur,ng)%gradient) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr) +# ifdef MASKING +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif + END IF + END DO +! +! Southern edge, closed boundary condition. +! + ELSE IF (tl_LBC(isouth,isFsur,ng)%closed) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr) +# ifdef MASKING +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif + END IF + END DO + END IF + END IF +! +!----------------------------------------------------------------------- +! Lateral boundary conditions at the northern edge. +!----------------------------------------------------------------------- +! + IF (DOMAIN(ng)%Northern_Edge(tile)) THEN +! +! Northern edge, implicit upstream radiation condition. +! + IF (tl_LBC(inorth,isFsur,ng)%radiation) THEN + IF (iic(ng).ne.0) THEN + DO i=IstrU-1,Iend+1 +!^ grad(i,Jend+1)=zeta(i ,Jend+1,know)- & +!^ & zeta(i-1,Jend+1,know) +!^ + tl_grad(i,Jend+1)=0.0_r8 + END DO + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN +# if defined CELERITY_READ && defined FORWARD_READ + IF (tl_LBC(inorth,isFsur,ng)%nudging) THEN + IF (BOUNDARY(ng)%zeta_north_Ce(i).eq.0.0_r8) THEN + tau=FSobc_in(ng,inorth) + ELSE + tau=FSobc_out(ng,inorth) + END IF + tau=tau*dt2d + END IF +# ifdef RADIATION_2D + Cx=BOUNDARY(ng)%zeta_north_Cx(i) +# else + Cx=0.0_r8 +# endif + Ce=BOUNDARY(ng)%zeta_north_Ce(i) + cff=BOUNDARY(ng)%zeta_north_C2(i) + +!^ zeta_new(i,Jend+1)=(cff*zeta(i,Jend+1,know)+ & +!^ & Ce *zeta_new(i,Jend)- & +!^ & MAX(Cx,0.0_r8)*grad(i ,Jend+1)- & +!^ & MIN(Cx,0.0_r8)*grad(i+1,Jend+1))/ & +!^ & (cff+Ce) +!^ + tl_zeta_new(i,Jend+1)=(cff*tl_zeta(i,Jend+1,know)+ & + & Ce *tl_zeta_new(i,Jend)- & + & MAX(Cx,0.0_r8)* & + & tl_grad(i ,Jend+1)- & + & MIN(Cx,0.0_r8)* & + & tl_grad(i+1,Jend+1))/ & + & (cff+Ce) + + IF (tl_LBC(inorth,isFsur,ng)%nudging) THEN +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend+1)+ & +!^ & tau*(BOUNDARY(ng)%zeta_north(i)- & +!^ & zeta(i,Jend+1,know)) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)- & + & tau*tl_zeta(i,Jend+1,know) + END IF +# else +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend) ! gradient +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend) +# endif +# ifdef MASKING +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif + END IF + END DO + END IF +! +! Northern edge, explicit Chapman boundary condition. +! + ELSE IF (tl_LBC(inorth,isFsur,ng)%Chapman_explicit) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN + cff=dt2d*GRID(ng)%pn(i,Jend) + cff1=SQRT(g*(GRID(ng)%h(i,Jend)+ & + & zeta(i,Jend,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(i,Jend)+ & + & tl_zeta(i,Jend,know))/cff1+ & +# ifdef TL_IOMS + & 0.5_r8*cff1 +# endif + Ce=cff*cff1 + tl_Ce=cff*tl_cff1 +!^ zeta_new(i,Jend+1)=(1.0_r8-Ce)*zeta(i,Jend+1,know)+ & +!^ & Ce*zeta(i,Jend,know) +!^ + tl_zeta_new(i,Jend+1)=(1.0_r8-Ce)*tl_zeta(i,Jend+1,know)+ & + & tl_Ce*(zeta(i,Jend+1,know)+ & + & zeta(i,Jend ,know))+ & + & Ce*tl_zeta(i,Jend,know)+ & +# ifdef TL_IOMS + & Ce*(zeta(i,Jend+1,know)- & + & zeta(i,Jend ,know)) +# endif +# ifdef MASKING +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif + END IF + END DO +! +! Northern edge, implicit Chapman boundary condition. +! + ELSE IF (tl_LBC(inorth,isFsur,ng)%Chapman_implicit) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN + cff=dt2d*GRID(ng)%pn(i,Jend) + cff1=SQRT(g*(GRID(ng)%h(i,Jend)+ & + & zeta(i,Jend,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(i,Jend)+ & + & tl_zeta(i,Jend,know))/cff1+ & +# ifdef TL_IOMS + & 0.5_r8*cff1 +# endif + Ce=cff*cff1 + tl_Ce=cff*tl_cff1 + cff2=1.0_r8/(1.0_r8+Ce) + tl_cff2=-cff2*cff2*tl_Ce+ & +# ifdef TL_IOMS + & cff2*cff2*(1.0_r8+2.0_r8*Ce) +# endif +!^ zeta_new(i,Jend+1)=cff2*(zeta(i,Jend+1,know)+ & +!^ & Ce*zeta_new(i,Jend)) +!^ + tl_zeta_new(i,Jend+1)=tl_cff2*(zeta(i,Jend+1,know)+ & + & Ce*zeta_new(i,Jend))+ & + & cff2*(tl_zeta(i,Jend+1,know)+ & + & tl_Ce*zeta_new(i,Jend)+ & + & Ce*tl_zeta_new(i,Jend))- & +# ifdef TL_IOMS + & cff2*(zeta(i,Jend+1,know)+ & + & 2.0_r8*Ce*zeta_new(i,Jend)) +# endif +# ifdef MASKING +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif + END IF + END DO +! +! Northern edge, clamped boundary condition. +! + ELSE IF (tl_LBC(inorth,isFsur,ng)%clamped) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN +!^ zeta_new(i,Jend+1)=BOUNDARY(ng)%zeta_north(i) +!^ + tl_zeta_new(i,Jend+1)=BOUNDARY(ng)%tl_zeta_north(i) +# ifdef MASKING +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif + END IF + END DO +! +! Northern edge, gradient boundary condition. +! + ELSE IF (tl_LBC(inorth,isFsur,ng)%gradient) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend) +# ifdef MASKING +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif + END IF + END DO +! +! Northern edge, closed boundary condition. +! + ELSE IF (tl_LBC(inorth,isFsur,ng)%closed) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend) +# ifdef MASKING +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif + END IF + END DO + END IF + END IF +! +!----------------------------------------------------------------------- +! Boundary corners. +!----------------------------------------------------------------------- +! + IF (.not.(EWperiodic(ng).or.NSperiodic(ng))) THEN + IF (DOMAIN(ng)%SouthWest_Corner(tile)) THEN + IF (LBC_apply(ng)%south(Istr-1).and. & + & LBC_apply(ng)%west (Jstr-1)) THEN +!^ zeta_new(Istr-1,Jstr-1)=0.5_r8*(zeta_new(Istr ,Jstr-1)+ & +!^ & zeta_new(Istr-1,Jstr )) +!^ + tl_zeta_new(Istr-1,Jstr-1)=0.5_r8* & + & (tl_zeta_new(Istr ,Jstr-1)+ & + & tl_zeta_new(Istr-1,Jstr )) + END IF + END IF + IF (DOMAIN(ng)%SouthEast_Corner(tile)) THEN + IF (LBC_apply(ng)%south(Iend+1).and. & + & LBC_apply(ng)%east (Jstr-1)) THEN +!^ zeta_new(Iend+1,Jstr-1)=0.5_r8*(zeta_new(Iend ,Jstr-1)+ & +!^ & zeta_new(Iend+1,Jstr )) +!^ + tl_zeta_new(Iend+1,Jstr-1)=0.5_r8* & + & (tl_zeta_new(Iend ,Jstr-1)+ & + & tl_zeta_new(Iend+1,Jstr )) + END IF + END IF + IF (DOMAIN(ng)%NorthWest_Corner(tile)) THEN + IF (LBC_apply(ng)%north(Istr-1).and. & + & LBC_apply(ng)%west (Jend+1)) THEN +!^ zeta_new(Istr-1,Jend+1)=0.5_r8*(zeta_new(Istr-1,Jend )+ & +!^ & zeta_new(Istr ,Jend+1)) +!^ + tl_zeta_new(Istr-1,Jend+1)=0.5_r8* & + & (tl_zeta_new(Istr-1,Jend )+ & + & tl_zeta_new(Istr ,Jend+1)) + END IF + END IF + IF (DOMAIN(ng)%NorthEast_Corner(tile)) THEN + IF (LBC_apply(ng)%north(Iend+1).and. & + & LBC_apply(ng)%east (Jend+1)) THEN +!^ zeta_new(Iend+1,Jend+1)=0.5_r8*(zeta_new(Iend+1,Jend )+ & +!^ & zeta_new(Iend ,Jend+1)) +!^ + tl_zeta_new(Iend+1,Jend+1)=0.5_r8* & + & (tl_zeta_new(Iend+1,Jend )+ & + & tl_zeta_new(Iend ,Jend+1)) + END IF + END IF + END IF + +# if defined WET_DRY +! +!----------------------------------------------------------------------- +! Ensure that water level on boundary cells is above bed elevation. +!----------------------------------------------------------------------- +! + cff=Dcrit(ng)-eps + IF (.not.EWperiodic(ng)) THEN + IF (DOMAIN(ng)%Western_Edge(tile)) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN + IF (zeta_new(Istr-1,j).le. & + & (Dcrit(ng)-GRID(ng)%h(Istr-1,j))) THEN +!^ zeta_new(Istr-1,j)=cff-GRID(ng)%h(Istr-1,j) +!^ + tl_zeta_new(Istr-1,j)=-GRID(ng)%tl_h(Istr-1,j) + END IF + END IF + END DO + END IF + IF (DOMAIN(ng)%Eastern_Edge(tile)) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN + IF (zeta_new(Iend+1,j).le. & + & (Dcrit(ng)-GRID(ng)%h(Iend+1,j))) THEN +!^ zeta_new(Iend+1,j)=cff-GRID(ng)%h(Iend+1,j) +!^ + tl_zeta_new(Iend+1,j)=-GRID(ng)%tl_h(Iend+1,j) + END IF + END IF + END DO + END IF + END IF +! + IF (.not.NSperiodic(ng)) THEN + IF (DOMAIN(ng)%Southern_Edge(tile)) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN + IF (zeta_new(i,Jstr-1).le. & + & (Dcrit(ng)-GRID(ng)%h(i,Jstr-1))) THEN +!^ zeta_new(i,Jstr-1)=cff-GRID(ng)%h(i,Jstr-1) +!^ + tl_zeta_new(i,Jstr-1)=-GRID(ng)%tl_h(i,Jstr-1) + END IF + END IF + END DO + END IF + IF (DOMAIN(ng)%Northern_Edge(tile)) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN + IF (zeta_new(i,Jend+1).le. & + & (Dcrit(ng)-GRID(ng)%h(i,Jend+1))) THEN +!^ zeta_new(i,Jend+1)=cff-GRID(ng)%h(i,Jend+1) +!^ + tl_zeta_new(i,Jend+1)=-GRID(ng)%tl_h(i,Jend+1) + END IF + END IF + END DO + END IF + END IF +! + IF (.not.(EWperiodic(ng).or.NSperiodic(ng))) THEN + IF (DOMAIN(ng)%SouthWest_Corner(tile)) THEN + IF (LBC_apply(ng)%south(Istr-1).and. & + & LBC_apply(ng)%west (Jstr-1)) THEN + IF (zeta_new(Istr-1,Jstr-1).le. & + & (Dcrit(ng)-GRID(ng)%h(Istr-1,Jstr-1))) THEN +!^ zeta_new(Istr-1,Jstr-1)=cff-GRID(ng)%h(Istr-1,Jstr-1) +!^ + tl_zeta_new(Istr-1,Jstr-1)=-GRID(ng)%tl_h(Istr-1,Jstr-1) + END IF + END IF + END IF + IF (DOMAIN(ng)%SouthEast_Corner(tile)) THEN + IF (LBC_apply(ng)%south(Iend+1).and. & + & LBC_apply(ng)%east (Jstr-1)) THEN + IF (zeta_new(Iend+1,Jstr-1).le. & + & (Dcrit(ng)-GRID(ng)%h(Iend+1,Jstr-1))) THEN +!^ zeta_new(Iend+1,Jstr-1)=cff-GRID(ng)%h(Iend+1,Jstr-1) +!^ + tl_zeta_new(Iend+1,Jstr-1)=-GRID(ng)%tl_h(Iend+1,Jstr-1) + END IF + END IF + END IF + IF (DOMAIN(ng)%NorthWest_Corner(tile)) THEN + IF (LBC_apply(ng)%north(Istr-1).and. & + & LBC_apply(ng)%west (Jend+1)) THEN + IF (zeta_new(Istr-1,Jend+1).le. & + & (Dcrit(ng)-GRID(ng)%h(Istr-1,Jend+1))) THEN +!^ zeta_new(Istr-1,Jend+1)=cff-GRID(ng)%h(Istr-1,Jend+1) +!^ + tl_zeta_new(Istr-1,Jend+1)=-GRID(ng)%tl_h(Istr-1,Jend+1) + END IF + END IF + END IF + IF (DOMAIN(ng)%NorthEast_Corner(tile)) THEN + IF (LBC_apply(ng)%north(Iend+1).and. & + & LBC_apply(ng)%east (Jend+1)) THEN + IF (zeta_new(Iend+1,Jend+1).le. & + & (Dcrit(ng)-GRID(ng)%h(Iend+1,Jend+1))) THEN +!^ zeta_new(Iend+1,Jend+1)=cff-GRID(ng)%h(Iend+1,Jend+1) +!^ + tl_zeta_new(Iend+1,Jend+1)=-GRID(ng)%tl_h(Iend+1,Jend+1) + END IF + END IF + END IF + END IF +# endif +! + RETURN + END SUBROUTINE rp_zetabc_local +# endif +#endif + END MODULE rp_zetabc_mod diff --git a/ROMS/Tangent/tl_main2d.F b/ROMS/Tangent/tl_main2d.F index 68ea24849..3b93183d7 100644 --- a/ROMS/Tangent/tl_main2d.F +++ b/ROMS/Tangent/tl_main2d.F @@ -4,15 +4,24 @@ SUBROUTINE tl_main2d (RunInterval) ! !git $Id$ !================================================== Hernan G. Arango === -! Copyright (c) 2002-2025 The ROMS Group ! +! Copyright (c) 2002-2025 The ROMS Group Andrew M. Moore ! ! Licensed under a MIT/X style license ! ! See License_ROMS.md ! !======================================================================= ! ! -! This routine is the main driver for tangent linear ROMS when ! -! configurated as shallow water (barotropic ) ocean model only. It ! -! advances forward the tangent linear model for all nested grids, ! -! if any, by the specified time interval (seconds), RunInterval. ! +! This routine is the main driver for ROMS perturbation tangent ! +! linear model (TLM) when configured as a 2D barotropic shallow ! +! water ocean model. It advances advances forward the TLM for all ! +! nested grids, if any, by the specified time interval (seconds), ! +! RunInterval. ! +! ! +# if defined STEP2D_FB_LF_AM3 +! Numerical 2D time-stepping kernel: FB AB3-AM4 ! +# elif defined STEP2D_FB_LF_AM3 +! Numerical 2D time-stepping kernel: FB LF-AM3 ! +# else +! Numerical 2D time-stepping kernel: LF-AM3 (Legacy scheme) ! +# endif ! ! !======================================================================= ! @@ -22,44 +31,47 @@ SUBROUTINE tl_main2d (RunInterval) USE mod_coupler # endif USE mod_iounits +# ifdef NESTING + USE mod_nesting +# endif USE mod_scalars USE mod_stepping ! - USE dateclock_mod, ONLY : time_string + USE dateclock_mod, ONLY : time_string # ifdef TLM_CHECK - USE dotproduct_mod, ONLY : tl_dotproduct + USE dotproduct_mod, ONLY : tl_dotproduct # endif # ifdef TIDE_GENERATING_FORCES - USE equilibrium_tide_mod, ONLY : equilibrium_tide + USE equilibrium_tide_mod, ONLY : equilibrium_tide # endif # if defined ATM_COUPLING_NOT_YET && defined MCT_LIB - USE mct_coupler_mod, ONLY : ocn2atm_coupling + USE mct_coupler_mod, ONLY : ocn2atm_coupling # endif # if defined WAV_COUPLING_NOT_YET && defined MCT_LIB - USE mct_coupler_mod, ONLY : ocn2wav_coupling + USE mct_coupler_mod, ONLY : ocn2wav_coupling # endif - USE strings_mod, ONLY : FoundError - USE tl_diag_mod, ONLY : tl_diag + USE strings_mod, ONLY : FoundError + USE tl_diag_mod, ONLY : tl_diag # if defined WEAK_CONSTRAINT || defined FORCING_SV - USE tl_forcing_mod, ONLY : tl_forcing + USE tl_forcing_mod, ONLY : tl_forcing # endif # ifdef ADJUST_WSTRESS - USE tl_frc_adjust_mod, ONLY : tl_frc_adjust + USE tl_frc_adjust_mod, ONLY : tl_frc_adjust # endif - USE tl_ini_fields_mod, ONLY : tl_ini_fields, tl_ini_zeta + USE tl_ini_fields_mod, ONLY : tl_ini_fields, tl_ini_zeta # ifdef ADJUST_BOUNDARY - USE tl_obc_adjust_mod, ONLY : tl_obc_adjust + USE tl_obc_adjust_mod, ONLY : tl_obc_adjust # endif # ifdef TL_AVERAGES - USE tl_set_avg_mod, ONLY : tl_set_avg + USE tl_set_avg_mod, ONLY : tl_set_avg # endif # if defined SSH_TIDES_NOT_YET || defined UV_TIDES_NOT_YET -!! USE tl_set_tides_mod, ONLY : tl_set_tides +!! USE tl_set_tides_mod, ONLY : tl_set_tides # endif - USE tl_set_vbc_mod, ONLY : tl_set_vbc - USE tl_step2d_mod, ONLY : tl_step2d + USE tl_set_vbc_mod, ONLY : tl_set_vbc + USE tl_step2d_mod, ONLY : tl_step2d # ifdef FLOATS_NOT_YET -!! USE tl_step_floats_mod, ONLY : tl_step_floats +!! USE tl_step_floats_mod, ONLY : tl_step_floats # endif ! implicit none @@ -70,13 +82,14 @@ SUBROUTINE tl_main2d (RunInterval) ! ! Local variable declarations. ! - integer :: ng, tile + logical :: DoNestLayer, Time_Step +! + integer :: Nsteps, Rsteps + integer :: ig, il, istep, ng, nl, tile integer :: next_indx1 # ifdef FLOATS_NOT_YET integer :: Lend, Lstr, chunk_size # endif -! - real(r8) :: MaxDT, my_StepTime ! character (len=*), parameter :: MyFile = & & __FILE__ @@ -85,111 +98,141 @@ SUBROUTINE tl_main2d (RunInterval) ! Time-step tangent linear vertically integrated equations. !======================================================================= ! - my_StepTime=0.0_r8 - MaxDT=MAXVAL(dt) - - STEP_LOOP : DO WHILE (my_StepTime.le.(RunInterval+0.5_r8*MaxDT)) - - my_StepTime=my_StepTime+MaxDT +! Time-step the 3D kernel for the specified time interval (seconds), +! RunInterval. +! + Time_Step=.TRUE. + DoNestLayer=.TRUE. +! + KERNEL_LOOP : DO WHILE (Time_Step) +! +! In nesting applications, the number of nesting layers (NestLayers) is +! used to facilitate refinement grids and composite/refinament grids +! combinations. Otherwise, the solution it is looped once for a single +! grid application (NestLayers = 1). +! + nl=0 +# ifdef NESTING + TwoWayInterval(1:Ngrids)=0.0_r8 +# endif +! + NEST_LAYER : DO WHILE (DoNestLayer) +! +! Determine number of time steps to compute in each nested grid layer +! based on the specified time interval (seconds), RunInterval. Non +! nesting applications have NestLayers=1. Notice that RunInterval is +! set in the calling driver. Its value may span the full period of the +! simulation, a multi-model coupling interval (RunInterval > ifac*dt), +! or just a single step (RunInterval=0). +! + CALL ntimesteps (iTLM, RunInterval, nl, Nsteps, Rsteps) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + IF ((nl.le.0).or.(nl.gt.NestLayers)) EXIT +! +! Time-step governing equations for Nsteps. ! -! Set time clock. + STEP_LOOP : DO istep=1,Nsteps ! - DO ng=1,Ngrids - iic(ng)=iic(ng)+1 -!$OMP MASTER - time(ng)=time(ng)+dt(ng) - tdays(ng)=time(ng)*sec2day - CALL time_string (time(ng), time_code(ng)) -!$OMP END MASTER -!$OMP BARRIER - END DO +! Set time indices and time clock. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + tdays(ng)=time(ng)*sec2day + IF (step_counter(ng).eq.Rsteps) Time_Step=.FALSE. + END DO ! !----------------------------------------------------------------------- ! Read in required data, if any, from input NetCDF files. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids -!$OMP MASTER - CALL tl_get_data (ng) -!$OMP END MASTER -!$OMP BARRIER - IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN - END DO + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + CALL tl_get_data (ng) + IF (FoundError(exit_flag, NoError, & + & __LINE__, MyFile)) RETURN + END DO ! !----------------------------------------------------------------------- ! If applicable, process input data: time interpolate between data ! snapshots. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 - CALL tl_set_data (ng, tile) - END DO -!$OMP BARRIER - END DO - IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=first_tile(ng),last_tile(ng),+1 + CALL tl_set_data (ng, tile) + END DO + END DO + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN # if (defined WEAK_CONSTRAINT || defined FORCING_SV) && \ !defined SP4DVAR ! !----------------------------------------------------------------------- ! If appropriate, add convolved adjoint solution impulse forcing to -! the representer model solution. Notice that the forcing is only +! the tangent linear model solution. Notice that the forcing is only ! needed after finishing all inner loops. The forcing is continuous. ! That is, it is time interpolated at every time-step from available ! snapshots (FrequentImpulse=TRUE). !----------------------------------------------------------------------- ! - DO ng=1,Ngrids + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) # ifdef WEAK_CONSTRAINT # ifdef WEAK_NOINTERP - IF ((iic(ng).gt.1).and.(iic(ng).ne.ntend(ng)+1).and. & - & (MOD(iic(ng)-1,nadj(ng)).eq.0)) THEN - IF (Master) THEN - WRITE (stdout,*) ' FORCING TLM at iic = ',iic(ng) - END IF + IF ((iic(ng).gt.1).and.(iic(ng).ne.ntend(ng)+1).and. & + & (MOD(iic(ng)-1,nadj(ng)).eq.0)) THEN + IF (Master) THEN + WRITE (stdout,*) ' FORCING TLM at iic = ',iic(ng) + END IF # endif - IF (FrequentImpulse(ng)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL tl_forcing (ng, tile, kstp(ng), nstp(ng)) - END DO -!$OMP BARRIER - END IF + IF (FrequentImpulse(ng)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL tl_forcing (ng, tile, kstp(ng), nstp(ng)) + END DO + END IF # ifdef WEAK_NOINTERP - END IF + END IF # endif # else - DO tile=first_tile(ng),last_tile(ng),+1 - CALL tl_forcing (ng, tile, kstp(ng), nstp(ng)) - END DO -!$OMP BARRIER + DO tile=first_tile(ng),last_tile(ng),+1 + CALL tl_forcing (ng, tile, kstp(ng), nstp(ng)) + END DO # endif - END DO + END DO # endif ! !----------------------------------------------------------------------- -! If not a restart, initialize all time levels and compute other -! initial fields. +! Initialize all time levels and compute other initial fields. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (iic(ng).eq.ntstart(ng)) THEN + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (iic(ng).eq.ntstart(ng)) THEN ! ! Initialize free-surface. ! - DO tile=first_tile(ng),last_tile(ng),+1 - CALL tl_ini_zeta (ng, tile, iTLM) - END DO -!$OMP BARRIER + DO tile=first_tile(ng),last_tile(ng),+1 + CALL tl_ini_zeta (ng, tile, iTLM) + END DO ! ! Initialize other state variables. ! - DO tile=last_tile(ng),first_tile(ng),-1 - CALL tl_ini_fields (ng, tile, iTLM) + DO tile=last_tile(ng),first_tile(ng),-1 + CALL tl_ini_fields (ng, tile, iTLM) + END DO + +# ifdef NESTING +! +! Extract donor grid initial data at contact points and store it in +! REFINED structure so it can be used for the space-time interpolation. +! + IF (RefinedGrid(ng)) THEN + CALL tl_nesting (ng, iTLM, ngetD) + END IF +# endif + END IF END DO -!$OMP BARRIER - END IF - END DO ! !----------------------------------------------------------------------- ! Compute and report diagnostics. If appropriate, accumulate time- @@ -197,41 +240,42 @@ SUBROUTINE tl_main2d (RunInterval) ! jobs. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 ! irreversible + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=first_tile(ng),last_tile(ng),+1 ! irreversible # ifdef TL_AVERAGES - CALL tl_set_avg (ng, tile) + CALL tl_set_avg (ng, tile) # endif # ifdef DIAGNOSTICS -!! CALL set_diags (ng, tile) +!! CALL tl_set_diags (ng, tile) # endif # ifdef TIDE_GENERATING_FORCES - CALL equilibrium_tide (ng, tile, iTLM) + CALL equilibrium_tide (ng, tile, iTLM) # endif - CALL tl_diag (ng, tile) + CALL tl_diag (ng, tile) # ifdef TLM_CHECK - CALL tl_dotproduct (ng, tile, Lnew(ng)) + CALL tl_dotproduct (ng, tile, Lnew(ng)) # endif - END DO -!$OMP BARRIER - END DO + END DO + END DO + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN # if defined ATM_COUPLING_NOT_YET && defined MCT_LIB ! !----------------------------------------------------------------------- -! Couple to atmospheric model every CoupleSteps(Iatmos) timesteps: get -! air/sea fluxes. +! Couple ocean to atmosphere model every "CoupleSteps(Iatmos)" +! timesteps: get air/sea fluxes. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF ((iic(ng).ne.ntstart(ng)).and. & - & MOD(iic(ng)-1,CoupleSteps(Iatmos,ng)).eq.0) THEN - DO tile=last_tile(ng),first_tile(ng),-1 - CALL ocn2atm_coupling (ng, tile) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF ((iic(ng).ne.ntstart(ng)).and. & + & MOD(iic(ng),CoupleSteps(Iatmos,ng)).eq.0) THEN + DO tile=last_tile(ng),first_tile(ng),-1 + CALL ocn2atm_coupling (ng, tile) + END DO + END IF END DO -!$OMP BARRIER - END IF - END DO # endif # ifdef ADJUST_BOUNDARY @@ -241,14 +285,14 @@ SUBROUTINE tl_main2d (RunInterval) ! Skip the last output timestep. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (iic(ng).lt.(ntend(ng)+1)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL tl_obc_adjust (ng, tile, Lbinp(ng)) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (iic(ng).lt.(ntend(ng)+1)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL tl_obc_adjust (ng, tile, Lbinp(ng)) + END DO + END IF END DO -!$OMP BARRIER - END IF - END DO # endif # ifdef ADJUST_WSTRESS @@ -258,47 +302,60 @@ SUBROUTINE tl_main2d (RunInterval) ! Skip the last output timestep. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (iic(ng).lt.(ntend(ng)+1)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL tl_frc_adjust (ng, tile, Lfinp(ng)) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (iic(ng).lt.(ntend(ng)+1)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL tl_frc_adjust (ng, tile, Lfinp(ng)) + END DO + END IF END DO -!$OMP BARRIER - END IF - END DO # endif # if defined WAV_COUPLING_NOT_YET && defined MCT_LIB ! !----------------------------------------------------------------------- -! Couple to waves model every CoupleSteps(Iwaves) timesteps: get -! waves/sea fluxes. +! Couple ocean to waves model every "CoupleSteps(Iwaves)" +! timesteps: get waves/sea fluxes. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF ((iic(ng).ne.ntstart(ng)).and. & - & MOD(iic(ng)-1,CoupleSteps(Iwaves,ng)).eq.0) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL ocn2wav_coupling (ng, tile) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF ((iic(ng).ne.ntstart(ng)).and. & + & MOD(iic(ng)-1,CoupleSteps(Iwaves,ng)).eq.0) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL ocn2wav_coupling (ng, tile) + END DO + END IF END DO -!$OMP BARRIER - END IF - END DO # endif ! !----------------------------------------------------------------------- ! Set vertical boundary conditions. Process tidal forcing. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - DO tile=first_tile(ng),last_tile(ng),+1 - CALL tl_set_vbc (ng, tile) + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + DO tile=first_tile(ng),last_tile(ng),+1 + CALL tl_set_vbc (ng, tile) # if defined SSH_TIDES_NOT_YET || defined UV_TIDES_NOT_YET - CALL tl_set_tides (ng, tile) + CALL tl_set_tides (ng, tile) +# endif + END DO + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for bottom stress variables. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL tl_nesting (ng, iTLM, nbstr) + END IF + END DO # endif - END DO -!$OMP BARRIER - END DO ! !----------------------------------------------------------------------- ! If appropriate, write out fields into output NetCDF files. Notice @@ -306,69 +363,255 @@ SUBROUTINE tl_main2d (RunInterval) ! time step. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids -!$OMP MASTER - CALL tl_output (ng) -!$OMP END MASTER -!$OMP BARRIER - IF ((FoundError(exit_flag, NoError, __LINE__, MyFile)).or. & - & ((iic(ng).eq.(ntend(ng)+1)).and.(ng.eq.Ngrids))) RETURN - END DO + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + CALL tl_output (ng) + IF ((FoundError(exit_flag, NoError, __LINE__, MyFile)).or.& + & ((iic(ng).eq.(ntend(ng)+1)).and.(ng.eq.Ngrids))) THEN + RETURN + END IF + END DO + +# ifdef NESTING +! +!----------------------------------------------------------------------- +! If refinement grid, interpolate (space, time) state variables +! contact points from donor grid extracted data. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (RefinedGrid(ng).and.(RefineScale(ng).gt.0)) THEN + CALL tl_nesting (ng, iTLM, nputD) + END IF + END DO +# endif + +# ifdef STEP2D_FB_AB3_AM4 +! +!----------------------------------------------------------------------- +! Solve tangent linear vertically integrated primitive equations for +! free-surface and barotropic momentum components using a generalized +! Forward-Backward, 3rd-order Adams-Bashforth / 4th-order Adams-Moulton +! (FB AB3-AM4) time stepping scheme (Shchepetkin and McWilliams, +! 2009). +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + iif(ng)=1 + nfast(ng)=1 + kstp(ng)=knew(ng) + knew(ng)=kstp(ng)+1 + IF (knew(ng).gt.4) knew(ng)=1 + IF (MOD(knew(ng),2).eq.0) THEN ! zig-zag + DO tile=first_tile(ng),last_tile(ng),+1 ! processing + CALL tl_step2d (ng, tile) ! sequence + END DO + ELSE + DO tile=last_tile(ng),first_tile(ng),-1 + CALL tl_step2d (ng, tile) + END DO + END IF + END DO + +# else + +# ifdef STEP2D_FB_LF_AM3 +! +!----------------------------------------------------------------------- +! Solve tangent linear vertically integrated primitive equations for +! free-surface and momentum components using a predictor-corrector +! LeapFrog / 3rd-order Adams-Moulton with a Forward-Backward +! feeback (FB LF-AM3) stepping scheme (Shchepetkin and McWilliams, +! 2009). +!----------------------------------------------------------------------- +! +! Predictor LF substep with FB-feedback. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + iif(ng)=1 + nfast(ng)=1 + kstp(ng)=next_kstp(ng) + knew(ng)=3 + + DO tile=last_tile(ng),first_tile(ng),-1 + CALL tl_step2d (ng, tile) + END DO + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine PREDICTOR STEP section. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL tl_nesting (ng, iTLM, n2dPS) + END IF + END DO +# endif +! +! Corrector AM3 substep with FB-feedback. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + knew(ng)=3-kstp(ng) + next_kstp(ng)=knew(ng) + + DO tile=first_tile(ng),last_tile(ng),+1 + CALL tl_step2d (ng, tile) + END DO + END DO + +# else ! !----------------------------------------------------------------------- -! Solve the vertically integrated primitive equations for the -! free-surface and momentum components. +! Solve tangent linear vertically integrated primitive equations for +! free-surface and momentum components using a predictor-corrector +! LeapFrog with 3rd-order Adams-Moulton (LF-AM3) time stepping scheme +! (ROMS legacy 2D kernel). !----------------------------------------------------------------------- ! ! Set time indices for predictor step. The PREDICTOR_2D_STEP switch ! it is assumed to be false before the first time-step. ! - DO ng=1,Ngrids - iif(ng)=1 - nfast(ng)=1 - next_indx1=3-indx1(ng) - IF (.not.PREDICTOR_2D_STEP(ng)) THEN - PREDICTOR_2D_STEP(ng)=.TRUE. - IF (FIRST_2D_STEP) THEN - kstp(ng)=indx1(ng) - ELSE - kstp(ng)=3-indx1(ng) - END IF - knew(ng)=3 - krhs(ng)=indx1(ng) - END IF + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + iif(ng)=1 + nfast(ng)=1 + next_indx1=3-indx1(ng) + IF (.not.PREDICTOR_2D_STEP(ng)) THEN + PREDICTOR_2D_STEP(ng)=.TRUE. + IF (FIRST_2D_STEP) THEN + kstp(ng)=indx1(ng) + ELSE + kstp(ng)=3-indx1(ng) + END IF + knew(ng)=3 + krhs(ng)=indx1(ng) + END IF ! ! Predictor step - Advance barotropic equations using 2D time-step ! ============== predictor scheme. ! - DO tile=last_tile(ng),first_tile(ng),-1 - CALL tl_step2d (ng, tile) - END DO -!$OMP BARRIER - END DO + DO tile=last_tile(ng),first_tile(ng),-1 + CALL tl_step2d (ng, tile) + END DO + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine PREDICTOR STEP section. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL tl_nesting (ng, iTLM, n2dPS) + END IF + END DO +# endif ! ! Set time indices for corrector step. ! - DO ng=1,Ngrids - IF (PREDICTOR_2D_STEP(ng)) THEN - PREDICTOR_2D_STEP(ng)=.FALSE. - knew(ng)=next_indx1 - kstp(ng)=3-knew(ng) - krhs(ng)=3 - IF (iif(ng).lt.(nfast(ng)+1)) indx1(ng)=next_indx1 - END IF + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (PREDICTOR_2D_STEP(ng)) THEN + PREDICTOR_2D_STEP(ng)=.FALSE. + knew(ng)=next_indx1 + kstp(ng)=3-knew(ng) + krhs(ng)=3 + IF (iif(ng).lt.(nfast(ng)+1)) indx1(ng)=next_indx1 + END IF ! ! Corrector step - Apply 2D time-step corrector scheme. Notice that ! ============== there is not need for a corrector step during the ! auxiliary (nfast+1) time-step. ! - IF (iif(ng).lt.(nfast(ng)+1)) THEN - DO tile=first_tile(ng),last_tile(ng),+1 - CALL tl_step2d (ng, tile) + IF (iif(ng).lt.(nfast(ng)+1)) THEN + DO tile=first_tile(ng),last_tile(ng),+1 + CALL tl_step2d (ng, tile) + END DO + END IF END DO -!$OMP BARRIER - END IF - END DO +# endif + +# endif + +# ifdef NESTING +# if defined MASKING && defined WET_DRY +! +!----------------------------------------------------------------------- +! If nesting and wetting and drying, scale horizontal interpolation +! weights to account for land/sea masking in contact areas. This needs +! to be done at very time-step since the Land/Sea masking is time +! dependent. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + CALL tl_nesting (ng, iTLM, nmask) + END DO +# endif +! +!----------------------------------------------------------------------- +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine CORRECTOR STEP section (KNEW INDEX). +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL tl_nesting (ng, iTLM, n2dCS) + END IF + END DO +# endif + +# ifdef NESTING +# ifndef ONE_WAY +! +!----------------------------------------------------------------------- +! If refinement grids, perform two-way coupling between fine and +! coarse grids. Correct coarse grid tracers values at the refinement +! grid with refined accumulated fluxes. Then, replace coarse grid +! state variable with averaged refined grid values (two-way nesting). +! Update coarse grid depth variables. +! +! The two-way exchange of infomation between nested grids needs to be +! done at the correct time-step and in the right sequence. +!----------------------------------------------------------------------- +! + DO il=NestLayers,1,-1 + DO ig=1,GridsInLayer(il) + ng=GridNumber(ig,il) + IF (do_twoway(iNLM, nl, il, ng, istep)) THEN + CALL tl_nesting (ng, iTLM, n2way) + END IF + END DO + END DO +# endif +! +!----------------------------------------------------------------------- +! If donor to a finer grid, extract data for the external contact +! points. This is the latest solution for the coarser grid. +! +! It is stored in the REFINED structure so it can be used for the +! space-time interpolation. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (DonorToFiner(ng)) THEN + CALL tl_nesting (ng, iTLM, ngetD) + END IF + END DO +# endif # ifdef FLOATS_NOT_YET ! @@ -380,30 +623,47 @@ SUBROUTINE tl_main2d (RunInterval) ! variables do not have a global scope. !----------------------------------------------------------------------- ! - DO ng=1,Ngrids - IF (Lfloats(Ng)) THEN + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (Lfloats(ng)) THEN # ifdef _OPENMP - chunk_size=(Nfloats(ng)+numthreads-1)/numthreads - Lstr=1+my_thread*chunk_size - Lend=MIN(Nfloats(ng),Lstr+chunk_size-1) + chunk_size=(Nfloats(ng)+numthreads-1)/numthreads + Lstr=1+MyThread*chunk_size + Lend=MIN(Nfloats(ng),Lstr+chunk_size-1) # else - Lstr=1 - Lend=Nfloats(ng) + Lstr=1 + Lend=Nfloats(ng) # endif - CALL tl_step_floats (ng, Lstr, Lend) -!$OMP BARRIER + CALL tl_step_floats (ng, Lstr, Lend) ! ! Shift floats time indices. ! - nfp1(ng)=MOD(nfp1(ng)+1,NFT+1) - nf (ng)=MOD(nf (ng)+1,NFT+1) - nfm1(ng)=MOD(nfm1(ng)+1,NFT+1) - nfm2(ng)=MOD(nfm2(ng)+1,NFT+1) - nfm3(ng)=MOD(nfm3(ng)+1,NFT+1) - END IF - END DO + nfp1(ng)=MOD(nfp1(ng)+1,NFT+1) + nf (ng)=MOD(nf (ng)+1,NFT+1) + nfm1(ng)=MOD(nfm1(ng)+1,NFT+1) + nfm2(ng)=MOD(nfm2(ng)+1,NFT+1) + nfm3(ng)=MOD(nfm3(ng)+1,NFT+1) + END IF + END DO # endif - END DO STEP_LOOP +! +!----------------------------------------------------------------------- +! Advance time index and time clock. +!----------------------------------------------------------------------- +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + iic(ng)=iic(ng)+1 + time(ng)=time(ng)+dt(ng) + step_counter(ng)=step_counter(ng)-1 + CALL time_string (time(ng), time_code(ng)) + END DO + + END DO STEP_LOOP + + END DO NEST_LAYER + + END DO KERNEL_LOOP ! RETURN END SUBROUTINE tl_main2d diff --git a/ROMS/Tangent/tl_main3d.F b/ROMS/Tangent/tl_main3d.F index 7ffedba04..331b1a792 100644 --- a/ROMS/Tangent/tl_main3d.F +++ b/ROMS/Tangent/tl_main3d.F @@ -4,15 +4,23 @@ SUBROUTINE tl_main3d (RunInterval) ! !git $Id$ !================================================== Hernan G. Arango === -! Copyright (c) 2002-2025 The ROMS Group ! +! Copyright (c) 2002-2025 The ROMS Group Andrew M. Moore ! ! Licensed under a MIT/X style license ! ! See License_ROMS.md ! !======================================================================= ! ! -! This routine is the main driver for tangent linear ROMS when ! -! configurated as a full 3D baroclinic ocean model. It advances ! -! forward the tangent linear model equations for all nested grids, ! -! if any, by the specified time interval (seconds), RunInterval. ! +! This routine is the main driver for ROMS perturbation tangent ! +! linear model (TLM) when configurated as a full 3D baroclinic ocean ! +! model. It advances forward the TLM for all nested grids, if any, ! +! for specified time interval (seconds), RunInterval. ! +! ! +# if defined STEP2D_FB_LF_AM3 +! Numerical 2D time-stepping kernel: FB AB3-AM4 ! +# elif defined STEP2D_FB_LF_AM3 +! Numerical 2D time-stepping kernel: FB LF-AM3 ! +# else +! Numerical 2D time-stepping kernel: LF-AM3 (Legacy scheme) ! +# endif ! ! !======================================================================= ! @@ -29,99 +37,101 @@ SUBROUTINE tl_main3d (RunInterval) USE mod_stepping ! # ifdef ANA_VMIX - USE analytical_mod, ONLY : ana_vmix + USE analytical_mod, ONLY : ana_vmix # endif - USE dateclock_mod, ONLY : time_string + USE dateclock_mod, ONLY : time_string # ifdef TLM_CHECK - USE dotproduct_mod, ONLY : tl_dotproduct + USE dotproduct_mod, ONLY : tl_dotproduct # endif # ifdef TIDE_GENERATING_FORCES - USE equilibrium_tide_mod, ONLY : equilibrium_tide + USE equilibrium_tide_mod, ONLY : equilibrium_tide # endif # if defined ATM_COUPLING_NOT_YET && defined MCT_LIB - USE mct_coupler_mod, ONLY : ocn2atm_coupling + USE mct_coupler_mod, ONLY : ocn2atm_coupling # endif # if defined WAV_COUPLING_NOT_YET && defined MCT_LIB - USE mct_coupler_mod, ONLY : ocn2wav_coupling + USE mct_coupler_mod, ONLY : ocn2wav_coupling # endif # if defined FORWARD_READ || defined JEDI - USE omega_mod, ONLY : omega - USE set_depth_mod, ONLY : set_depth - USE set_massflux_mod, ONLY : set_massflux + USE omega_mod, ONLY : omega + USE set_depth_mod, ONLY : set_depth + USE set_massflux_mod, ONLY : set_massflux # endif - USE strings_mod, ONLY : FoundError + USE strings_mod, ONLY : FoundError # ifdef BIOLOGY - USE tl_biology_mod, ONLY : tl_biology + USE tl_biology_mod, ONLY : tl_biology # endif # ifdef BBL_MODEL_NOT_YET -!! USE tl_bbl_mod, ONLY : tl_bblm +!! USE tl_bbl_mod, ONLY : tl_bblm # endif # if defined BULK_FLUXES_NOT_YET && !defined PRIOR_BULK_FLUXES -!! USE tl_bulk_flux_mod, ONLY : tl_bulk_flux +!! USE tl_bulk_flux_mod, ONLY : tl_bulk_flux # endif # ifdef BVF_MIXING_NOT_YET -!! USE tl_bvf_mix_mod, ONLY : tl_bvf_mix +!! USE tl_bvf_mix_mod, ONLY : tl_bvf_mix # endif - USE tl_diag_mod, ONLY : tl_diag + USE tl_diag_mod, ONLY : tl_diag # if defined WEAK_CONSTRAINT || defined FORCING_SV - USE tl_forcing_mod, ONLY : tl_forcing + USE tl_forcing_mod, ONLY : tl_forcing # endif # if defined ADJUST_STFLUX || defined ADJUST_WSTRESS - USE tl_frc_adjust_mod, ONLY : tl_frc_adjust + USE tl_frc_adjust_mod, ONLY : tl_frc_adjust # endif # ifdef GLS_MIXING_NOT_YET -!! USE tl_gls_corstep_mod, ONLY : tl_gls_corstep -!! USE tl_gls_prestep_mod, ONLY : tl_gls_prestep +!! USE tl_gls_corstep_mod, ONLY : tl_gls_corstep +!! USE tl_gls_prestep_mod, ONLY : tl_gls_prestep # endif # ifdef LMD_MIXING_NOT_YET -!! USE tl_lmd_vmix_mod, ONLY : tl_lmd_vmix +!! USE tl_lmd_vmix_mod, ONLY : tl_lmd_vmix # endif # ifdef MY25_MIXING_NOT_YET -!! USE tl_my25_corstep_mod, ONLY : tl_my25_corstep -!! USE tl_my25_prestep_mod, ONLY : tl_my25_prestep +!! USE tl_my25_corstep_mod, ONLY : tl_my25_corstep +!! USE tl_my25_prestep_mod, ONLY : tl_my25_prestep # endif # ifdef NESTING - USE nesting_mod, ONLY : nesting - USE tl_nesting_mod, ONLY : tl_nesting + USE nesting_mod, ONLY : nesting + USE tl_nesting_mod, ONLY : tl_nesting # ifndef ONE_WAY - USE nesting_mod, ONLY : do_twoway + USE nesting_mod, ONLY : do_twoway # endif # endif # ifdef ADJUST_BOUNDARY - USE tl_obc_adjust_mod, ONLY : tl_obc_adjust - USE tl_obc_adjust_mod, ONLY : tl_obc2d_adjust - USE tl_set_depth_mod, ONLY : tl_set_depth_bry + USE tl_obc_adjust_mod, ONLY : tl_obc_adjust + USE tl_obc_adjust_mod, ONLY : tl_obc2d_adjust + USE tl_set_depth_mod, ONLY : tl_set_depth_bry # endif - USE tl_omega_mod, ONLY : tl_omega + USE tl_omega_mod, ONLY : tl_omega # if !(defined FORCING_SV || defined JEDI) - USE tl_post_initial_mod, ONLY : tl_post_initial + USE tl_post_initial_mod, ONLY : tl_post_initial # endif # ifndef TS_FIXED - USE tl_rho_eos_mod, ONLY : tl_rho_eos + USE tl_rho_eos_mod, ONLY : tl_rho_eos # endif - USE tl_rhs3d_mod, ONLY : tl_rhs3d + USE tl_rhs3d_mod, ONLY : tl_rhs3d # ifdef SEDIMENT_NOT_YET -!! USE tl_sediment_mod, ONLY : tl_sediment +!! USE tl_sediment_mod, ONLY : tl_sediment # endif # ifdef TL_AVERAGES - USE tl_set_avg_mod, ONLY : tl_set_avg + USE tl_set_avg_mod, ONLY : tl_set_avg # endif - USE tl_set_depth_mod, ONLY : tl_set_depth - USE tl_set_massflux_mod, ONLY : tl_set_massflux + USE tl_set_depth_mod, ONLY : tl_set_depth + USE tl_set_massflux_mod, ONLY : tl_set_massflux # if defined SSH_TIDES_NOT_YET || defined UV_TIDES_NOT_YET -!! USE tl_set_tides_mod, ONLY : tl_set_tides +!! USE tl_set_tides_mod, ONLY : tl_set_tides +# endif + USE tl_set_vbc_mod, ONLY : tl_set_vbc +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) + USE tl_set_zeta_mod, ONLY : tl_set_zeta # endif - USE tl_set_vbc_mod, ONLY : tl_set_vbc - USE tl_set_zeta_mod, ONLY : tl_set_zeta - USE tl_step2d_mod, ONLY : tl_step2d + USE tl_step2d_mod, ONLY : tl_step2d # ifndef TS_FIXED - USE tl_step3d_t_mod, ONLY : tl_step3d_t + USE tl_step3d_t_mod, ONLY : tl_step3d_t # endif - USE tl_step3d_uv_mod, ONLY : tl_step3d_uv + USE tl_step3d_uv_mod, ONLY : tl_step3d_uv # ifdef FLOATS_NOT_YET -!! USE tl_step_floats_mod, ONLY : tl_step_floats +!! USE tl_step_floats_mod, ONLY : tl_step_floats # endif -!! USE wvelocity_mod, ONLY : wvelocity +!! USE wvelocity_mod, ONLY : wvelocity ! implicit none ! @@ -132,15 +142,13 @@ SUBROUTINE tl_main3d (RunInterval) ! Local variable declarations. ! logical :: DoNestLayer, Time_Step - +! integer :: Nsteps, Rsteps integer :: ig, il, istep, ng, nl, tile integer :: my_iif, next_indx1 # ifdef FLOATS_NOT_YET integer :: Lend, Lstr, chunk_size # endif -! - real(r8) :: MaxDT, my_StepTime ! character (len=*), parameter :: MyFile = & & __FILE__ @@ -230,7 +238,6 @@ SUBROUTINE tl_main3d (RunInterval) CALL set_depth (ng, tile, iTLM) # endif END DO -!$OMP BARRIER END DO IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN @@ -245,7 +252,6 @@ SUBROUTINE tl_main3d (RunInterval) DO tile=last_tile(ng),first_tile(ng),-1 CALL set_massflux (ng, tile, iTLM) END DO -!$OMP BARRIER END DO # endif @@ -275,7 +281,6 @@ SUBROUTINE tl_main3d (RunInterval) CALL tl_forcing (ng, tile, kstp(ng), nstp(ng)) CALL tl_set_depth (ng, tile, iTLM) END DO -!$OMP BARRIER END IF # ifdef WEAK_NOINTERP END IF @@ -285,7 +290,6 @@ SUBROUTINE tl_main3d (RunInterval) CALL tl_forcing (ng, tile, kstp(ng), nstp(ng)) CALL tl_set_depth (ng, tile, iTLM) END DO -!$OMP BARRIER # endif END DO # endif @@ -331,15 +335,14 @@ SUBROUTINE tl_main3d (RunInterval) CALL tl_dotproduct (ng, tile, Lnew(ng)) # endif END DO -!$OMP BARRIER END DO IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN # if defined ATM_COUPLING_NOT_YET && defined MCT_LIB ! !----------------------------------------------------------------------- -! Couple to atmospheric model every CoupleSteps(Iatmos) timesteps: get -! air/sea fluxes. +! Couple ocean to atmosphere model every "CoupleSteps(Iatmos)" +! timesteps: get air/sea fluxes. !----------------------------------------------------------------------- ! DO ig=1,GridsInLayer(nl) @@ -349,7 +352,6 @@ SUBROUTINE tl_main3d (RunInterval) DO tile=last_tile(ng),first_tile(ng),-1 CALL ocn2atm_coupling (ng, tile) END DO -!$OMP BARRIER END IF END DO # endif @@ -357,8 +359,8 @@ SUBROUTINE tl_main3d (RunInterval) # if defined WAV_COUPLING_NOT_YET && defined MCT_LIB ! !----------------------------------------------------------------------- -! Couple to waves model every CoupleSteps(Iwaves) timesteps: get -! waves/sea fluxes. +! Couple to ocean to waves model every "CoupleSteps(Iwaves)" +! timesteps: get waves/ocean fluxes. !----------------------------------------------------------------------- ! DO ig=1,GridsInLayer(nl) @@ -368,7 +370,6 @@ SUBROUTINE tl_main3d (RunInterval) DO tile=first_tile(ng),last_tile(ng),+1 CALL ocn2wav_coupling (ng, tile) END DO -!$OMP BARRIER END IF END DO # endif @@ -392,7 +393,6 @@ SUBROUTINE tl_main3d (RunInterval) CALL tl_set_tides (ng, tile) # endif END DO -!$OMP BARRIER END DO # ifdef NESTING @@ -423,7 +423,6 @@ SUBROUTINE tl_main3d (RunInterval) CALL tl_set_depth_bry (ng, tile, iTLM) CALL tl_obc2d_adjust (ng, tile, Lbinp(ng)) END DO -!$OMP BARRIER END IF END DO # endif @@ -441,7 +440,6 @@ SUBROUTINE tl_main3d (RunInterval) DO tile=first_tile(ng),last_tile(ng),+1 CALL tl_frc_adjust (ng, tile, Lfinp(ng)) END DO -!$OMP BARRIER END IF END DO # endif @@ -465,8 +463,10 @@ SUBROUTINE tl_main3d (RunInterval) CALL tl_omega (ng, tile, iTLM) !! CALL wvelocity (ng, tile, nstp(ng)) END DO -!$OMP BARRIER END DO + +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) || \ + defined DIAGNOSTICS || defined AVERAGES ! !----------------------------------------------------------------------- ! Set free-surface to it time-averaged value. If applicable, @@ -477,7 +477,9 @@ SUBROUTINE tl_main3d (RunInterval) DO ig=1,GridsInLayer(nl) ng=GridNumber(ig,nl) DO tile=first_tile(ng),last_tile(ng),+1 ! irreversible +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) CALL tl_set_zeta (ng, tile) +# endif # ifdef DIAGNOSTICS !! CALL set_diags (ng, tile) # endif @@ -485,8 +487,8 @@ SUBROUTINE tl_main3d (RunInterval) CALL tl_set_avg (ng, tile) # endif END DO -!$OMP BARRIER END DO +# endif # ifdef NESTING ! @@ -509,10 +511,7 @@ SUBROUTINE tl_main3d (RunInterval) ! DO ig=1,GridsInLayer(nl) ng=GridNumber(ig,nl) -!$OMP MASTER CALL tl_output (ng) -!$OMP END MASTER -!$OMP BARRIER IF ((FoundError(exit_flag, NoError, __LINE__, MyFile)).or.& & ((iic(ng).eq.(ntend(ng)+1)).and.(ng.eq.Ngrids))) THEN RETURN @@ -558,7 +557,6 @@ SUBROUTINE tl_main3d (RunInterval) CALL tl_gls_prestep (ng, tile) # endif END DO -!$OMP BARRIER END DO # ifdef NESTING @@ -574,10 +572,133 @@ SUBROUTINE tl_main3d (RunInterval) END IF END DO # endif + +# ifdef STEP2D_FB_AB3_AM4 +! +!----------------------------------------------------------------------- +! Solve tangent linear vertically integrated primitive equations for +! free-surface and barotropic momentum components using a generalized +! Forward-Backward, 3rd-order Adams-Bashforth / 4th-order Adams-Moulton +! (FB AB3-AM4) time stepping scheme (Shchepetkin and McWilliams, +! 2009). +!----------------------------------------------------------------------- +! + LOOP_2D : DO my_iif=1,MAXVAL(nfast) + + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (my_iif.le.nfast(ng)) THEN + iif(ng)=my_iif + kstp(ng)=knew(ng) + knew(ng)=kstp(ng)+1 + IF (knew(ng).gt.4) knew(ng)=1 + + IF (MOD(knew(ng),2).eq.0) THEN ! zig-zag + DO tile=first_tile(ng),last_tile(ng),+1 ! processing + CALL tl_step2d (ng, tile) ! sequence + END DO + ELSE + DO tile=last_tile(ng),first_tile(ng),-1 + CALL tl_step2d (ng, tile) + END DO + END IF + END IF + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine CORRECTOR STEP section (KNEW INDEX). +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL tl_nesting (ng, iTLM, n2dCS) + END IF + END DO +# endif + END DO LOOP_2D + +# else + +# ifdef STEP2D_FB_LF_AM3 ! !----------------------------------------------------------------------- ! Solve the vertically integrated primitive equations for the -! free-surface and barotropic momentum components. +! free-surface and barotropic momentum components using a predictor- +! corrector LeapFrog / 3rd-order Adams-Moulton with a Forward-Backward +! feeback (FB LF-AM3) stepping scheme (Shchepetkin and McWilliams, +! 2009). +!----------------------------------------------------------------------- +! + LOOP_2D : DO my_iif=1,MAXVAL(nfast) +! +! Predictor LF substep with FB-feedback. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (my_iif.le.nfast(ng)) THEN + iif(ng)=my_iif + kstp(ng)=next_kstp(ng) + knew(ng)=3 + + DO tile=last_tile(ng),first_tile(ng),-1 + CALL tl_step2d (ng, tile) + END DO + END IF + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine PREDICTOR STEP section. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL tl_nesting (ng, iTLM, n2dPS) + END IF + END DO +# endif +! +! Corrector AM3 substep with FB-feedback. +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (my_iif.le.nfast(ng)) THEN + knew(ng)=3-kstp(ng) + next_kstp(ng)=knew(ng) + + DO tile=first_tile(ng),last_tile(ng),+1 + CALL tl_step2d (ng, tile) + END DO + END IF + END DO + +# ifdef NESTING +! +! If composite or mosaic grids, process additional points in the +! contact zone between connected grids for the state variables +! associated with the 2D engine CORRECTOR STEP section (KNEW INDEX). +! + DO ig=1,GridsInLayer(nl) + ng=GridNumber(ig,nl) + IF (ANY(CompositeGrid(:,ng))) THEN + CALL tl_nesting (ng, iTLM, n2dCS) + END IF + END DO +# endif + END DO LOOP_2D + +# else +! +!----------------------------------------------------------------------- +! Solve the vertically integrated primitive equations for the +! free-surface and barotropic momentum components using a predictor- +! corrector LeapFrog with 3rd-order Adams-Moulton (LF-AM3) time +! stepping scheme. !----------------------------------------------------------------------- ! LOOP_2D : DO my_iif=1,MAXVAL(nfast)+1 @@ -611,32 +732,22 @@ SUBROUTINE tl_main3d (RunInterval) DO tile=last_tile(ng),first_tile(ng),-1 CALL tl_step2d (ng, tile) END DO -!$OMP BARRIER END IF END DO -# ifdef NESTING +# ifdef NESTING ! ! If composite or mosaic grids, process additional points in the ! contact zone between connected grids for the state variables -! associated with the 2D engine Predictor Step section. -! If refinement, check mass flux conservation between coarse and -! fine grids during debugging. -# ifdef NESTING_DEBUG -! Warning: very verbose output to fort.300 ascii file to check -! mass flux conservation. -# endif +! associated with the 2D engine PREDICTOR STEP section. ! DO ig=1,GridsInLayer(nl) ng=GridNumber(ig,nl) IF (ANY(CompositeGrid(:,ng))) THEN CALL tl_nesting (ng, iTLM, n2dPS) END IF - IF (RefinedGrid(ng).and.(RefineScale(ng).gt.0)) THEN - CALL tl_nesting (ng, iTLM, nmflx) - END IF END DO -# endif +# endif ! ! Set time indices for corrector step. ! @@ -658,41 +769,36 @@ SUBROUTINE tl_main3d (RunInterval) DO tile=first_tile(ng),last_tile(ng),+1 CALL tl_step2d (ng, tile) END DO -!$OMP BARRIER END IF END DO -# ifdef NESTING +# ifdef NESTING ! ! If composite or mosaic grids, process additional points in the ! contact zone between connected grids for the state variables -! associated with the 2D engine Corrector step section. -! If refinement, check mass flux conservation between coarse and -! fine grids during debugging. -# ifdef NESTING_DEBUG -! Warning: very verbose output to fort.300 ascii file to check -! mass flux conservation. -# endif +! associated with the 2D engine CORRECTOR STEP section (KNEW INDEX). ! DO ig=1,GridsInLayer(nl) ng=GridNumber(ig,nl) IF (ANY(CompositeGrid(:,ng))) THEN CALL tl_nesting (ng, iTLM, n2dCS) END IF - IF (RefinedGrid(ng).and.(RefineScale(ng).gt.0)) THEN - CALL tl_nesting (ng, iTLM, nmflx) - END IF END DO -# endif +# endif END DO LOOP_2D +# endif + +# endif # ifdef NESTING # if defined MASKING && defined WET_DRY ! +!----------------------------------------------------------------------- ! If nesting and wetting and drying, scale horizontal interpolation ! weights to account for land/sea masking in contact areas. This needs ! to be done at very time-step since the Land/Sea masking is time ! dependent. +!----------------------------------------------------------------------- ! DO ig=1,GridsInLayer(nl) ng=GridNumber(ig,nl) @@ -700,9 +806,11 @@ SUBROUTINE tl_main3d (RunInterval) END DO # endif ! +!----------------------------------------------------------------------- ! If composite or mosaic grids, process additional points in the ! contact zone between connected grids for the time-averaged ! momentum fluxes (DU_avg1, DV_avg1) and free-surface (Zt_avg). +!----------------------------------------------------------------------- ! DO ig=1,GridsInLayer(nl) ng=GridNumber(ig,nl) @@ -711,6 +819,8 @@ SUBROUTINE tl_main3d (RunInterval) END IF END DO # endif + +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) ! !----------------------------------------------------------------------- ! Recompute depths and thicknesses using the new time filtered @@ -722,8 +832,8 @@ SUBROUTINE tl_main3d (RunInterval) DO tile=last_tile(ng),first_tile(ng),-1 CALL tl_set_depth (ng, tile, iTLM) END DO -!$OMP BARRIER END DO +# endif # ifdef NESTING ! @@ -748,7 +858,6 @@ SUBROUTINE tl_main3d (RunInterval) DO tile=last_tile(ng),first_tile(ng),-1 CALL tl_step3d_uv (ng, tile) END DO -!$OMP BARRIER END DO # ifdef NESTING @@ -786,7 +895,6 @@ SUBROUTINE tl_main3d (RunInterval) CALL tl_sediment (ng, tile) # endif END DO -!$OMP BARRIER END DO # ifndef TS_FIXED @@ -800,7 +908,6 @@ SUBROUTINE tl_main3d (RunInterval) DO tile=last_tile(ng),first_tile(ng),-1 CALL tl_step3d_t (ng, tile) END DO -!$OMP BARRIER END DO # ifdef NESTING @@ -879,7 +986,6 @@ SUBROUTINE tl_main3d (RunInterval) Lend=Nfloats(ng) # endif CALL tl_step_floats (ng, Lstr, Lend) -!$OMP BARRIER ! ! Shift floats time indices. ! @@ -909,7 +1015,7 @@ SUBROUTINE tl_main3d (RunInterval) END DO NEST_LAYER END DO KERNEL_LOOP - +! RETURN END SUBROUTINE tl_main3d #else diff --git a/ROMS/Tangent/tl_omega.F b/ROMS/Tangent/tl_omega.F index 102028e50..231607505 100644 --- a/ROMS/Tangent/tl_omega.F +++ b/ROMS/Tangent/tl_omega.F @@ -15,6 +15,19 @@ MODULE tl_omega_mod ! ! ! diagnostically at horizontal RHO-points and vertical W-points. ! ! ! +# ifdef OMEGA_IMPLICIT +! Added implicit vertical advection following Shchepetkin (2015). ! +! The vertical velocity is split into explicit (W) and implicit (Wi) ! +! parts that adjust automatically to the local flow conditions based ! +! on the Courant number for stability, allowing larger time steps. ! +! ! +! Reference: ! +! ! +! Shchepetkin, A.F., 2015: An adaptive, Courant-number-dependent ! +! implicit scheme for vertical advection in oceanic modeling, ! +! Ocean Modelling, 91, 38-69, doi: 10.1016/j.ocemod.2015.03.006 ! +! ! +# endif ! BASIC STATE variables needed: W, z_w. ! ! ! ! NOTE: We need to recompute basic state W in this routine since ! @@ -67,10 +80,18 @@ SUBROUTINE tl_omega (ng, tile, model) # endif & GRID(ng) % Huon, & & GRID(ng) % Hvom, & +# ifdef OMEGA_IMPLICIT + & GRID(ng) % pm, & + & GRID(ng) % pn, & +# endif & GRID(ng) % z_w, & & GRID(ng) % tl_Huon, & & GRID(ng) % tl_Hvom, & & GRID(ng) % tl_z_w, & +# ifdef OMEGA_IMPLICIT + & OCEAN(ng) % Wi, & + & OCEAN(ng) % tl_Wi, & +# endif & OCEAN(ng) % W, & & OCEAN(ng) % tl_W) # ifdef PROFILE @@ -89,8 +110,15 @@ SUBROUTINE tl_omega_tile (ng, tile, model, & & omn, & bed_thick, tl_bed_thick, & # endif - & Huon, Hvom, z_w, & + & Huon, Hvom, & +# ifdef OMEGA_IMPLICIT + & pm, pn, & +# endif + & z_w, & & tl_Huon, tl_Hvom, tl_z_w, & +# ifdef OMEGA_IMPLICIT + & Wi, tl_Wi, & +# endif & W, tl_W) !*********************************************************************** ! @@ -115,16 +143,23 @@ SUBROUTINE tl_omega_tile (ng, tile, model, & # ifdef ASSUMED_SHAPE # if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET real(r8), intent(in) :: omn(LBi:,LBj:) - real(r8), intent(in):: bed_thick(LBi:,LBj:,:) - real(r8), intent(in):: tl_bed_thick(LBi:,LBj:,:) + real(r8), intent(in) :: bed_thick(LBi:,LBj:,:) + real(r8), intent(in) :: tl_bed_thick(LBi:,LBj:,:) # endif real(r8), intent(in) :: Huon(LBi:,LBj:,:) real(r8), intent(in) :: Hvom(LBi:,LBj:,:) +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: pm(LBi:,LBj:) + real(r8), intent(in) :: pn(LBi:,LBj:) +# endif real(r8), intent(in) :: z_w(LBi:,LBj:,0:) real(r8), intent(in) :: tl_Huon(LBi:,LBj:,:) real(r8), intent(in) :: tl_Hvom(LBi:,LBj:,:) real(r8), intent(in) :: tl_z_w(LBi:,LBj:,0:) - +# ifdef OMEGA_IMPLICIT + real(r8), intent(out) :: Wi(LBi:,LBj:,0:) + real(r8), intent(out) :: tl_Wi(LBi:,LBj:,0:) +# endif real(r8), intent(out) :: W(LBi:,LBj:,0:) real(r8), intent(out) :: tl_W(LBi:,LBj:,0:) @@ -132,16 +167,23 @@ SUBROUTINE tl_omega_tile (ng, tile, model, & # if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET real(r8), intent(in) :: omn(LBi:UBi,LBj:UBj) - real(r8), intent(in):: bed_thick(LBi:UBi,LBj:UBj,2) - real(r8), intent(in):: tl_bed_thick(LBi:UBi,LBj:UBj,2) + real(r8), intent(in) :: bed_thick(LBi:UBi,LBj:UBj,3) + real(r8), intent(in) :: tl_bed_thick(LBi:UBi,LBj:UBj,3) # endif real(r8), intent(in) :: Huon(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(in) :: Hvom(LBi:UBi,LBj:UBj,N(ng)) +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: pm(LBi:UBi,LBj:UBj) + real(r8), intent(in) :: pn(LBi:UBi,LBj:UBj) +# endif real(r8), intent(in) :: z_w(LBi:UBi,LBj:UBj,0:N(ng)) real(r8), intent(in) :: tl_Huon(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(in) :: tl_Hvom(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(in) :: tl_z_w(LBi:UBi,LBj:UBj,0:N(ng)) - +# ifdef OMEGA_IMPLICIT + real(r8), intent(out) :: Wi(LBi:UBi,LBj:UBj,0:N(ng)) + real(r8), intent(out) :: tl_Wi(LBi:UBi,LBj:UBj,0:N(ng)) +# endif real(r8), intent(out) :: W(LBi:UBi,LBj:UBj,0:N(ng)) real(r8), intent(out) :: tl_W(LBi:UBi,LBj:UBj,0:N(ng)) # endif @@ -155,31 +197,47 @@ SUBROUTINE tl_omega_tile (ng, tile, model, & # endif real(r8), dimension(IminS:ImaxS) :: wrk real(r8), dimension(IminS:ImaxS) :: tl_wrk +# ifdef OMEGA_IMPLICIT + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: Cu_adv + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_Cu_adv + real(r8) :: cw, c2d, dh, cw_max, cw_max2, cw_min + real(r8) :: tl_dh +! + real(r8), parameter :: amax = 0.75_r8 ! Maximum Courant number + real(r8), parameter :: amin = 0.60_r8 ! Minimum Courant number + real(r8), parameter :: cmnx_ratio = amin/amax + real(r8), parameter :: cutoff = 2.0_r8-amin/amax + real(r8), parameter :: r4cmx = 1.0_r8/(4.0_r8-4.0_r8*amin/amax) +# endif # include "set_bounds.h" ! !------------------------------------------------------------------------ ! Vertically integrate horizontal mass flux divergence. -!------------------------------------------------------------------------ ! ! Starting with zero vertical velocity at the bottom, integrate ! from the bottom (k=0) to the free-surface (k=N). The w(:,:,N(ng)) ! contains the vertical velocity at the free-surface, d(zeta)/d(t). ! Notice that barotropic mass flux divergence is not used directly. +!------------------------------------------------------------------------ ! # if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET +! For sediment bed change, we need to include the mass change of +! water volume due to change of the sea floor. This is similar to +! the LwSrc point source approach. +! cff1=1.0_r8/dt(ng) +! # endif DO j=Jstr,Jend DO i=Istr,Iend -# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET - W(i,j,0)=-cff1*(bed_thick(i,j,nstp)- & - & bed_thick(i,j,nnew))*omn(i,j) - tl_W(i,j,0)=-cff1*(tl_bed_thick(i,j,nstp)- & - & tl_bed_thick(i,j,nnew))*omn(i,j) -# else W(i,j,0)=0.0_r8 tl_W(i,j,0)=0.0_r8 +# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET + wrk(i)=cff1*(bed_thick(i,j,nstp)- & + & bed_thick(i,j,nnew))*omn(i,j) + tl_wrk(i)=cff1*(tl_bed_thick(i,j,nstp)- & + & tl_bed_thick(i,j,nnew))*omn(i,j) # endif END DO ! @@ -193,11 +251,34 @@ SUBROUTINE tl_omega_tile (ng, tile, model, & DO k=1,N(ng) DO i=Istr,Iend W(i,j,k)=W(i,j,k-1)- & +# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET + & wrk(i)- & +# endif & (Huon(i+1,j,k)-Huon(i,j,k)+ & & Hvom(i,j+1,k)-Hvom(i,j,k)) tl_W(i,j,k)=tl_W(i,j,k-1)- & +# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET + & tl_wrk(i)- & +# endif & (tl_Huon(i+1,j,k)-tl_Huon(i,j,k)+ & & tl_Hvom(i,j+1,k)-tl_Hvom(i,j,k)) +# ifdef OMEGA_IMPLICIT +! +! Compute the horizontal Courant number. +! + Cu_adv(i,k)=MAX(Huon(i+1,j ,k),0.0_r8)- & + & MIN(Huon(i ,j ,k),0.0_r8)+ & + & MAX(Hvom(i ,j+1,k),0.0_r8)- & + & MIN(Hvom(i ,j ,k),0.0_r8) + tl_Cu_adv(i,k)=(0.5_r8+SIGN(0.5_r8, Huon(i+1,j ,k)))* & + & tl_Huon(i+1,j ,k)- & + (0.5_r8+SIGN(0.5_r8,-Huon(i ,j ,k)))* & + & tl_Huon(i ,j ,k)+ & + (0.5_r8+SIGN(0.5_r8, Hvom(i ,j+1,k)))* & + & tl_Hvom(i ,j+1,k)- & + (0.5_r8+SIGN(0.5_r8,-Hvom(i ,j ,k)))* & + & tl_Hvom(i ,j ,k) +# endif END DO END DO ! @@ -218,12 +299,24 @@ SUBROUTINE tl_omega_tile (ng, tile, model, & IF (((IstrR.le.ii).and.(ii.le.IendR)).and. & & ((JstrR.le.jj).and.(jj.le.JendR)).and. & & (j.eq.jj)) THEN +# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET + wrk(ii)=cff1*(bed_thick(ii,jj,nstp)- & + & bed_thick(ii,jj,nnew))*omn(ii,jj) + tl_wrk(ii)=cff1*(tl_bed_thick(ii,jj,nstp)- & + & tl_bed_thick(ii,jj,nnew))*omn(ii,jj) +# endif DO k=1,N(ng) W(ii,jj,k)=W(ii,jj,k-1)- & +# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET + & wrk(ii)- & +# endif & (Huon(ii+1,jj,k)-Huon(ii,jj,k)+ & & Hvom(ii,jj+1,k)-Hvom(ii,jj,k))+ & & SOURCES(ng)%Qsrc(is,k) tl_W(ii,jj,k)=tl_W(ii,jj,k-1)- & +# if defined SEDIMENT_NOT_YET && defined SED_MORPH_NOT_YET + & tl_wrk(ii)- & +# endif & (tl_Huon(ii+1,jj,k)-tl_Huon(ii,jj,k)+ & & tl_Hvom(ii,jj+1,k)-tl_Hvom(ii,jj,k))+ & & SOURCES(ng)%tl_Qsrc(is,k) @@ -238,6 +331,9 @@ SUBROUTINE tl_omega_tile (ng, tile, model, & tl_cff=-cff*cff*(tl_z_w(i,j,N(ng))-tl_z_w(i,j,0)) wrk(i)=cff*W(i,j,N(ng)) tl_wrk(i)=tl_cff*W(i,j,N(ng))+cff*tl_W(i,j,N(ng)) +# ifdef OMEGA_IMPLICIT + Cu_adv(i,0)=dt(ng)*pm(i,j)*pn(i,j) +# endif END DO ! ! In order to insure zero vertical velocity at the free-surface, @@ -254,6 +350,58 @@ SUBROUTINE tl_omega_tile (ng, tile, model, & tl_W(i,j,k)=tl_W(i,j,k)- & & tl_wrk(i)*(z_w(i,j,k)-z_w(i,j,0))- & & wrk(i)*(tl_z_w(i,j,k)-tl_z_w(i,j,0)) +# ifdef OMEGA_IMPLICIT +! +! Determine implicit part "Wi" of vertical advection: "W" becomes the +! explicit part "We". +! +! HGA: 'dh' cannot be linearized because it is the local vertical grid +! spacing. It has to be positive! We need to take the nonlinear +! value. +! Andy what should we do here for the linearization? +! + Wi(i,j,k)=W(i,j,k) + tl_Wi(i,j,k)=tl_W(i,j,k) + IF (Wi(i,j,k).ge.0.0_r8) THEN ! Three different variants + c2d=Cu_adv(i,k) ! for computing 2D Courant + dh=z_w(i,j,k)-z_w(i,j,k-1) ! number at the interface: + ELSE ! (1) use value from the + c2d=Cu_adv(i,k+1) ! grid box upstream in + dh=z_w(i,j,k+1)-z_w(i,j,k) ! vertical direction; + END IF +! +!! c2d=0.5_r8*(Cu_adv(i,k )+ & +!! & Cu_adv(i,k+1)) ! (2) average the two; or +!! dh=0.5_r8*(z_w(i,j,k+1)- & +!! & z_w(i,j,k-1)) +!! +!! c2d=MAX(Cu_adv(i,k ), & +!! & Cu_adv(i,k+1)) ! (3) pick its maximum +!! dh=MIN(z_w(i,j,k+1)-z_w(i,j,k), & +!! z_w(i,j,k)-z_w(i,j,k-1)) +!! + cw_max=amax*dh-c2d*Cu_adv(i,0) ! compare the vertical + IF (cw_max.ge.0.0_r8) THEN ! displacement to dz*amax. + cw_max2=cw_max*cw_max ! Partition W into Wi and + cw_min=cw_max*cmnx_ratio ! We. + cw=ABS(Wi(i,j,k))*Cu_adv(i,0) + IF (cw.le.cw_min) THEN + cff=cw_max2 + ELSE IF (cw.le.cutoff*cw_max) THEN + cff=cw_max2+r4cmx*(cw-cw_min)**2 + ELSE + cff=cw_max*cw + END IF +! + W(i,j,k)=cw_max2*Wi(i,j,k)/cff + tl_W(i,j,k)=cw_max2*tl_Wi(i,j,k)/cff + Wi(i,j,k)=Wi(i,j,k)-W(i,j,k) + tl_Wi(i,j,k)=tl_Wi(i,j,k)-tl_W(i,j,k) + ELSE ! All the displacement is + W(i,j,k)=0.0_r8 ! greater than amax*dz, so + tl_W(i,j,k)=0.0_r8 ! keep it all into Wi. + END IF +# endif END DO END DO DO i=Istr,Iend @@ -270,7 +418,14 @@ SUBROUTINE tl_omega_tile (ng, tile, model, & CALL bc_w3d_tile (ng, tile, & & LBi, UBi, LBj, UBj, 0, N(ng), & & tl_W) - +# ifdef OMEGA_IMPLICIT + CALL bc_w3d_tile (ng, tile, & + & LBi, UBi, LBj, UBj, 0, N(ng), & + & Wi) + CALL bc_w3d_tile (ng, tile, & + & LBi, UBi, LBj, UBj, 0, N(ng), & + & tl_Wi) +# endif # ifdef DISTRIBUTE CALL mp_exchange3d (ng, tile, model, 1, & & LBi, UBi, LBj, UBj, 0, N(ng), & @@ -282,6 +437,18 @@ SUBROUTINE tl_omega_tile (ng, tile, model, & & NghostPoints, & & EWperiodic(ng), NSperiodic(ng), & & tl_W) +# ifdef OMEGA_IMPLICIT + CALL mp_exchange3d (ng, tile, model, 1, & + & LBi, UBi, LBj, UBj, 0, N(ng), & + & NghostPoints, & + & EWperiodic(ng), NSperiodic(ng), & + & Wi) + CALL mp_exchange3d (ng, tile, model, 1, & + & LBi, UBi, LBj, UBj, 0, N(ng), & + & NghostPoints, & + & EWperiodic(ng), NSperiodic(ng), & + & tl_Wi) +# endif # endif ! RETURN diff --git a/ROMS/Tangent/tl_set_data.F b/ROMS/Tangent/tl_set_data.F index 318dccc29..34a596883 100644 --- a/ROMS/Tangent/tl_set_data.F +++ b/ROMS/Tangent/tl_set_data.F @@ -1187,7 +1187,11 @@ SUBROUTINE tl_set_data_tile (ng, tile, & ! ! Set forward free-surface. ! +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + DO k=1,4 +# else DO k=1,3 +# endif CALL set_2dfld_tile (ng, tile, iTLM, idFsur, & & LBi, UBi, LBj, UBj, & & OCEAN(ng)%zetaG, & @@ -1206,7 +1210,11 @@ SUBROUTINE tl_set_data_tile (ng, tile, & ! ! Set forward 2D momentum. ! +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + DO k=1,4 +# else DO k=1,3 +# endif CALL set_2dfld_tile (ng, tile, iTLM, idUbar, & & LBi, UBi, LBj, UBj, & & OCEAN(ng)%ubarG, & diff --git a/ROMS/Tangent/tl_set_zeta.F b/ROMS/Tangent/tl_set_zeta.F index 0dfa815b7..0b49128fa 100644 --- a/ROMS/Tangent/tl_set_zeta.F +++ b/ROMS/Tangent/tl_set_zeta.F @@ -1,7 +1,8 @@ #include "cppdefs.h" MODULE tl_set_zeta_mod -#if defined TANGENT && defined SOLVE3D +#if defined TANGENT && defined SOLVE3D && \ + !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) ! !git $Id$ !================================================== Hernan G. Arango === @@ -84,7 +85,7 @@ SUBROUTINE tl_set_zeta_tile (ng, tile, & # else real(r8), intent(in) :: tl_Zt_avg1(LBi:UBi,LBj:UBj) - real(r8), intent(out) :: tl_zeta(LBi:UBi,LBj:UBj,3) + real(r8), intent(out) :: tl_zeta(LBi:UBi,LBj:UBj,:) # endif ! ! Local variable declarations. @@ -141,7 +142,7 @@ SUBROUTINE tl_set_zeta_tile (ng, tile, & & tl_zeta(:,:,1), & & tl_zeta(:,:,2)) # endif - +! RETURN END SUBROUTINE tl_set_zeta_tile #endif diff --git a/ROMS/Tangent/tl_step2d.F b/ROMS/Tangent/tl_step2d.F index 17accb3ca..ac86f68c6 100644 --- a/ROMS/Tangent/tl_step2d.F +++ b/ROMS/Tangent/tl_step2d.F @@ -8,16 +8,27 @@ ! See License_ROMS.md ! !======================================================================= ! ! -! This subroutine performs a fast (predictor or corrector) time-step ! -! for the free-surface and 2D momentum tangent linear equations. ! +! This module timesteps the perturbation Tangent Linear Model (TLM) ! +! vertically-integrated primitive (2D shallow-water) equations for ! +! the free-surface and 2D momentum. In 3D applications, the ROMS ! +! numerical kernel is split between baroclinic and barotropic ! +! dynamics. The barotropic engine uses a smaller timestep in this ! +! routine to resolve fast gravity wave processes. ! # ifdef SOLVE3D +! ! ! It also calculates the time filtering variables over all fast-time ! -! steps to damp high frequency signals in 3D applications. ! +! steps to damp high frequency signals in 3D applications. ! # endif ! ! !======================================================================= ! -# include "tl_step2d_LF_AM3.h" +# if defined STEP2D_FB_AB3_AM4 +# include "tl_step2d_FB.h" +# elif defined STEP2D_FB_LF_AM3 +# include "tl_step2d_FB_LF_AM3.h" +# else +# include "tl_step2d_LF_AM3.h" +# endif #else MODULE tl_step2d_mod END MODULE tl_step2d_mod diff --git a/ROMS/Tangent/tl_step2d_FB.h b/ROMS/Tangent/tl_step2d_FB.h index 23147ae89..1164a2254 100644 --- a/ROMS/Tangent/tl_step2d_FB.h +++ b/ROMS/Tangent/tl_step2d_FB.h @@ -155,7 +155,7 @@ & FORCES(ng) % Pair, & # endif #else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET & COUPLING(ng) % rhoA, & & COUPLING(ng) % tl_rhoA, & & COUPLING(ng) % rhoS, & @@ -250,7 +250,7 @@ & Pair, & # endif #else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET & rhoA, tl_rhoA, & & rhoS, tl_rhoS, & # endif @@ -352,7 +352,7 @@ real(r8), intent(in ) :: Pair(LBi:,LBj:) # endif # else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET real(r8), intent(in ) :: rhoA(LBi:,LBj:) real(r8), intent(in ) :: rhoS(LBi:,LBj:) real(r8), intent(in ) :: tl_rhoA(LBi:,LBj:) @@ -471,7 +471,7 @@ real(r8), intent(in ) :: Pair(LBi:UBi,LBj:UBj) # endif # else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET real(r8), intent(in ) :: rhoA(LBi:UBi,LBj:UBj) real(r8), intent(in ) :: rhoS(LBi:UBi,LBj:UBj) real(r8), intent(in ) :: tl_rhoA(LBi:UBi,LBj:UBj) @@ -576,7 +576,7 @@ real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: grad #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta2 -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzetaSA #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rubar @@ -620,7 +620,7 @@ real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_grad #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzeta2 -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzetaSA #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzeta @@ -664,7 +664,7 @@ grad=IniVal # endif rzeta2=IniVal -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D rzetaSA=IniVal # endif rzeta=IniVal @@ -989,7 +989,7 @@ & bkw1*tl_zeta(i,j,kbak)+ & & bkw2*tl_zeta(i,j,kold) -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j) tl_rzeta(i,j)=(1.0_r8+rhoS(i,j))*tl_zwrk(i,j)+ & & tl_rhoS(i,j)*zwrk(i,j) @@ -1146,7 +1146,7 @@ !----------------------------------------------------------------------- ! cff1=0.5_r8*g -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D cff2=0.333333333333_r8 #endif #if defined ATM_PRESS && !defined SOLVE3D @@ -1160,7 +1160,7 @@ !^ & h(i ,j))* & !^ & (rzeta(i-1,j)- & !^ & rzeta(i ,j))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i-1,j)- & !^ & h(i ,j))* & !^ & (rzetaSA(i-1,j)+ & @@ -1182,7 +1182,7 @@ & h(i ,j))* & & (tl_rzeta(i-1,j)- & & tl_rzeta(i ,j))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D & (tl_h(i-1,j)- & & tl_h(i ,j))* & & (rzetaSA(i-1,j)+ & @@ -1246,7 +1246,7 @@ !^ & h(i,j ))* & !^ & (rzeta(i,j-1)- & !^ & rzeta(i,j ))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i,j-1)- & !^ & h(i,j ))* & !^ & (rzetaSA(i,j-1)+ & @@ -1268,7 +1268,7 @@ & h(i,j ))* & & (tl_rzeta(i,j-1)- & & tl_rzeta(i,j ))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D & (tl_h(i,j-1)- & & tl_h(i,j ))* & & (rzetaSA(i,j-1)+ & @@ -2089,7 +2089,7 @@ !^ zwrk(i,j)=zeta_new(i,j)-zeta(i,j,kstp) !^ tl_zwrk(i,j)=tl_zeta_new(i,j)-tl_zeta(i,j,kstp) -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j) !^ tl_rzeta(i,j)=(1.0_r8+rhoS(i,j))*tl_zwrk(i,j)+ & @@ -2121,7 +2121,7 @@ END DO ! cff1=0.5*g -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D cff2=0.333333333333_r8 # endif DO j=Jstr,Jend @@ -2133,7 +2133,7 @@ !^ & h(i ,j))* & !^ & (rzeta(i-1,j)- & !^ & rzeta(i ,j))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i-1,j)- & !^ & h(i ,j))* & !^ & (rzetaSA(i-1,j)+ & @@ -2156,7 +2156,7 @@ & h(i ,j))* & & (tl_rzeta(i-1,j)- & & tl_rzeta(i ,j))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D & (tl_h(i-1,j)- & & tl_h(i ,j))* & & (rzetaSA(i-1,j)+ & @@ -2193,7 +2193,7 @@ !^ & h(i,j ))* & !^ & (rzeta(i,j-1)- & !^ & rzeta(i,j ))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i,j-1)- & !^ & h(i,j ))* & !^ & (rzetaSA(i,j-1)+ & @@ -2216,7 +2216,7 @@ & h(i,j ))* & & (tl_rzeta(i,j-1)- & & tl_rzeta(i,j ))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D & (tl_h(i,j-1)- & & tl_h(i,j ))* & & (rzetaSA(i,j-1)+ & diff --git a/ROMS/Tangent/tl_step2d_FB_LF_AM3.h b/ROMS/Tangent/tl_step2d_FB_LF_AM3.h index 2d9ba788c..e8b02a9e8 100644 --- a/ROMS/Tangent/tl_step2d_FB_LF_AM3.h +++ b/ROMS/Tangent/tl_step2d_FB_LF_AM3.h @@ -143,7 +143,7 @@ & FORCES(ng) % Pair, & # endif #else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET & COUPLING(ng) % rhoA, & & COUPLING(ng) % tl_rhoA, & & COUPLING(ng) % rhoS, & @@ -231,7 +231,7 @@ & Pair, & # endif #else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET & rhoA, tl_rhoA, & & rhoS, tl_rhoS, & # endif @@ -324,7 +324,7 @@ real(r8), intent(in ) :: Pair(LBi:,LBj:) # endif # else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET real(r8), intent(in ) :: rhoA(LBi:,LBj:) real(r8), intent(in ) :: rhoS(LBi:,LBj:) real(r8), intent(in ) :: tl_rhoA(LBi:,LBj:) @@ -432,7 +432,7 @@ real(r8), intent(in ) :: Pair(LBi:UBi,LBj:UBj) # endif # else -# ifdef VAR_RHO_2D +# ifdef VAR_RHO_2D_NOT_YET real(r8), intent(in ) :: rhoA(LBi:UBi,LBj:UBj) real(r8), intent(in ) :: rhoS(LBi:UBi,LBj:UBj) real(r8), intent(in ) :: tl_rhoA(LBi:UBi,LBj:UBj) @@ -528,7 +528,7 @@ real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rvbar real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzeta2 -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: rzetaSA #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: zeta_new @@ -566,7 +566,7 @@ real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_grad #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzeta2 -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzetaSA #endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_rzeta @@ -925,7 +925,7 @@ tl_zwrk(i,j)=cff1*tl_zeta_new(i,j)+ & & cff2*tl_zeta(i,j,kstp)+ & & cff3*tl_zeta(i,j,kbak) -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j) tl_rzeta(i,j)=(1.0_r8+rhoS(i,j))*tl_zwrk(i,j)+ & & tl_rhoS(i,j)*zwrk(i,j) @@ -987,7 +987,7 @@ & cff1*tl_zeta_new(i,j)+ & & cff2*tl_zeta(i,j,kstp)+ & & cff3*tl_zeta(i,j,kbak) -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j) tl_rzeta(i,j)=(1.0_r8+rhoS(i,j))*tl_zwrk(i,j)+ & & tl_rhoS(i,j)*zwrk(i,j) @@ -1127,7 +1127,7 @@ !^ & h(i ,j))* & !^ & (rzeta(i-1,j)- & !^ & rzeta(i ,j))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i-1,j)- & !^ & h(i ,j))* & !^ & (rzetaSA(i-1,j)+ & @@ -1149,7 +1149,7 @@ & h(i ,j))* & & (tl_rzeta(i-1,j)- & & tl_rzeta(i ,j))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D & (tl_h(i-1,j)- & & tl_h(i ,j))* & & (rzetaSA(i-1,j)+ & @@ -1213,7 +1213,7 @@ !^ & h(i,j ))* & !^ & (rzeta(i,j-1)- & !^ & rzeta(i,j ))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i,j-1)- & !^ & h(i,j ))* & !^ & (rzetaSA(i,j-1)+ & @@ -1235,7 +1235,7 @@ & h(i,j ))* & & (tl_rzeta(i,j-1)- & & tl_rzeta(i,j ))+ & -#if defined VAR_RHO_2D && defined SOLVE3D +#if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D & (tl_h(i,j-1)- & & tl_h(i,j ))* & & (rzetaSA(i,j-1)+ & @@ -2066,7 +2066,7 @@ !^ zwrk(i,j)=cff2*(zeta_new(i,j)-zeta(i,j,kstp)) !^ tl_zwrk(i,j)=cff2*(tl_zeta_new(i,j)-tl_zeta(i,j,kstp)) -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ rzeta(i,j)=(1.0_r8+rhoS(i,j))*zwrk(i,j) !^ tl_rzeta(i,j)=(1.0_r8+rhoS(i,j))*tl_zwrk(i,j)+ & @@ -2114,7 +2114,7 @@ !^ & h(i ,j))* & !^ & (rzeta(i-1,j)- & !^ & rzeta(i ,j))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i-1,j)- & !^ & h(i ,j))* & !^ & (rzetaSA(i-1,j)+ & @@ -2137,7 +2137,7 @@ & h(i ,j))* & & (tl_rzeta(i-1,j)- & & tl_rzeta(i ,j))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D & (tl_h(i-1,j)- & & tl_h(i ,j))* & & (rzetaSA(i-1,j)+ & @@ -2174,7 +2174,7 @@ !^ & h(i,j ))* & !^ & (rzeta(i,j-1)- & !^ & rzeta(i,j ))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D !^ & (h(i,j-1)- & !^ & h(i,j ))* & !^ & (rzetaSA(i,j-1)+ & @@ -2197,7 +2197,7 @@ & h(i,j ))* & & (tl_rzeta(i,j-1)- & & tl_rzeta(i,j ))+ & -# if defined VAR_RHO_2D && defined SOLVE3D +# if defined VAR_RHO_2D_NOT_YET && defined SOLVE3D & (tl_h(i,j-1)- & & tl_h(i,j ))* & & (rzetaSA(i,j-1)+ & diff --git a/ROMS/Tangent/tl_step3d_t.F b/ROMS/Tangent/tl_step3d_t.F index 66677b96d..60e195a32 100644 --- a/ROMS/Tangent/tl_step3d_t.F +++ b/ROMS/Tangent/tl_step3d_t.F @@ -102,6 +102,10 @@ SUBROUTINE tl_step3d_t (ng, tile) & MIXING(ng) % tl_Akt, & & OCEAN(ng) % W, & & OCEAN(ng) % tl_W, & +# ifdef OMEGA_IMPLICIT + & OCEAN(ng) % Wi, & + & OCEAN(ng) % tl_Wi, & +# endif # if defined FLOATS_NOT_YET && defined FLOAT_VWALK & MIXING(ng) % dAktdz, & # endif @@ -136,6 +140,9 @@ SUBROUTINE tl_step3d_t_tile (ng, tile, & & z_r, tl_z_r, & & Akt, tl_Akt, & & W, tl_W, & +# ifdef OMEGA_IMPLICIT + & Wi, tl_Wi, & +# endif # if defined FLOATS_NOT_YET && defined FLOAT_VWALK & dAktdz, & # endif @@ -194,7 +201,9 @@ SUBROUTINE tl_step3d_t_tile (ng, tile, & real(r8), intent(in) :: t(LBi:,LBj:,:,:,:) # endif real(r8), intent(in) :: W(LBi:,LBj:,0:) - +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: Wi(LBi:,LBj:,0:) +# endif real(r8), intent(in) :: tl_Hz(LBi:,LBj:,:) real(r8), intent(in) :: tl_Huon(LBi:,LBj:,:) real(r8), intent(in) :: tl_Hvom(LBi:,LBj:,:) @@ -205,6 +214,9 @@ SUBROUTINE tl_step3d_t_tile (ng, tile, & real(r8), intent(in) :: tl_Akt(LBi:,LBj:,0:,:) # endif real(r8), intent(in) :: tl_W(LBi:,LBj:,0:) +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: tl_Wi(LBi:,LBj:,0:) +# endif # ifdef DIAGNOSTICS_TS !! real(r8), intent(inout) :: DiaTwrk(LBi:,LBj:,:,:,:) # endif @@ -243,13 +255,18 @@ SUBROUTINE tl_step3d_t_tile (ng, tile, & real(r8), intent(in) :: Akt(LBi:UBi,LBj:UBj,0:N(ng),NAT) real(r8), intent(in) :: t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng)) real(r8), intent(in) :: W(LBi:UBi,LBj:UBj,0:N(ng)) - +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: Wi(LBi:UBi,LBj:UBj,0:N(ng)) +# endif real(r8), intent(in) :: tl_Hz(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(in) :: tl_Huon(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(in) :: tl_Hvom(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(in) :: tl_z_r(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(in) :: tl_Akt(LBi:UBi,LBj:UBj,0:N(ng),NAT) real(r8), intent(in) :: tl_W(LBi:UBi,LBj:UBj,0:N(ng)) +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: tl_Wi(LBi:UBi,LBj:UBj,0:N(ng)) +# endif # ifdef DIAGNOSTICS_TS !! real(r8), intent(inout) :: DiaTwrk(LBi:UBi,LBj:UBj,N(ng),NT(ng), & !! & NDT) @@ -282,11 +299,19 @@ SUBROUTINE tl_step3d_t_tile (ng, tile, & real(r8), dimension(IminS:ImaxS,0:N(ng)) :: BC real(r8), dimension(IminS:ImaxS,0:N(ng)) :: DC real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FC +# ifdef OMEGA_IMPLICIT + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FCmin + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FCmax +# endif real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_CF real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_BC real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_DC real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_FC +# ifdef OMEGA_IMPLICIT + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_FCmin + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_FCmax +# endif real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: FE real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: FX @@ -975,14 +1000,8 @@ SUBROUTINE tl_step3d_t_tile (ng, tile, & END DO END DO DO i=Istr,Iend -# ifdef SED_MORPH - FC(i,0)=W(i,j,0)*t(i,j,1,3,itrc) - tl_FC(i,0)=tl_W(i,j,0)*t(i,j,1,3,itrc)+ & - & W(i,j,0)*tl_t(i,j,1,3,itrc) -# else FC(i,0)=0.0_r8 tl_FC(i,0)=0.0_r8 -# endif FC(i,N(ng))=0.0_r8 tl_FC(i,N(ng))=0.0_r8 END DO @@ -1007,14 +1026,8 @@ SUBROUTINE tl_step3d_t_tile (ng, tile, & END DO END DO DO i=Istr,Iend -# ifdef SED_MORPH - FC(i,0)=W(i,j,0)*t(i,j,1,3,itrc) - tl_FC(i,0)=tl_W(i,j,0)*t(i,j,1,3,itrc)+ & - & W(i,j,0)*tl_t(i,j,1,3,itrc) -# else FC(i,0)=0.0_r8 tl_FC(i,0)=0.0_r8 -# endif FC(i,N(ng))=0.0_r8 tl_FC(i,N(ng))=0.0_r8 END DO @@ -1063,21 +1076,8 @@ SUBROUTINE tl_step3d_t_tile (ng, tile, & END DO END DO DO i=Istr,Iend -# ifdef SED_MORPH - FC(i,0)=W(i,j,0)*2.0_r8* & - & (cff2*t(i,j,1,3,itrc)- & - & cff3*t(i,j,2,3,itrc)) - tl_FC(i,0)=2.0_r8* & - & (tl_W(i,j,0)* & - & (cff2*t(i,j,1,3,itrc)- & - & cff3*t(i,j,2,3,itrc))+ & - & W(i,j,0)* & - & (cff2*tl_t(i,j,1,3,itrc)- & - & cff3*tl_t(i,j,2,3,itrc))) -# else FC(i,0)=0.0_r8 tl_FC(i,0)=0.0_r8 -# endif FC(i,1)=W(i,j,1)* & & (cff1*t(i,j,1,3,itrc)+ & & cff2*t(i,j,2,3,itrc)- & @@ -1209,6 +1209,153 @@ SUBROUTINE tl_step3d_t_tile (ng, tile, & END IF END DO END IF + +# ifdef OMEGA_IMPLICIT +! +!----------------------------------------------------------------------- +! Add adaptive, Courant-number based implicit vertical advection term. +!----------------------------------------------------------------------- +! +! Compute off-diagonal coefficients FC [dt*Wi*pm*pn] for the implicit +! vertical advection term located at horizontal RHO-points and vertical +! W-points. Also, set FC at the top and bottom levels. +! +! It needs to be before the Diffusion. +! + DO j=Jstr,Jend + DO itrc=1,NT(ng) + IF (.not.Vadvection(itrc,ng)%MPDATA) THEN + cff=dt(ng) + DO k=1,N(ng)-1 + DO i=Istr,Iend + cff1=cff*pm(i,j)*pn(i,j) + FCmax(i,k)=MAX(Wi(i,j,k),0.0_r8)*cff1 + FCmin(i,k)=MIN(Wi(i,j,k),0.0_r8)*cff1 + tl_FCmax(i,k)=(0.5_r8+SIGN(0.5_r8, Wi(i,j,k)))* & + & tl_Wi(i,j,k)*cff1 + tl_FCmin(i,k)=(0.5_r8+SIGN(0.5_r8,-Wi(i,j,k)))* & + & tl_Wi(i,j,k)*cff1 + END DO + END DO + DO i=Istr,Iend + FCmax(i,0)=0.0_r8 + FCmin(i,0)=0.0_r8 + FCmax(i,N(ng))=0.0_r8 + FCmin(i,N(ng))=0.0_r8 + + tl_FCmax(i,0)=0.0_r8 + tl_FCmin(i,0)=0.0_r8 + tl_FCmax(i,N(ng))=0.0_r8 + tl_FCmin(i,N(ng))=0.0_r8 + END DO +! +! Compute diagonal matrix coefficients BC and load right-hand-side +! terms for the tracer equation into DC. +! + DO k=1,N(ng) + DO i=Istr,Iend + BC(i,k)=Hz(i,j,k)+FCmax(i,k)-FCmin(i,k-1) + tl_BC(i,k)=tl_Hz(i,j,k)+tl_FCmax(i,k)-tl_FCmin(i,k-1) +# ifdef SPLINES_VDIFF + DC(i,k)=t(i,j,k,nnew,itrc)*Hz(i,j,k) + tl_DC(i,k)=tl_t(i,j,k,nnew,itrc)*Hz(i,j,k)+ & + & t(i,j,k,nnew,itrc)*tl_Hz(i,j,k) +# else + DC(i,k)=t(i,j,k,nnew,itrc) + tl_DC(i,k)=tl_t(i,j,k,nnew,itrc) +# endif + END DO + END DO +! +! Solve the tridiagonal system. +! + DO i=Istr,Iend + cff=1.0_r8/BC(i,1) + tl_cff=-cff*cff*tl_BC(i,1) + CF(i,1)=cff*FCmin(i,1) + tl_CF(i,1)=tl_cff*FCmin(i,1)+cff*tl_FCmin(i,1) + DC(i,1)=cff*DC(i,1) + tl_DC(i,1)=tl_cff*DC(i,1)+cff*tl_DC(i,1) + END DO + DO k=2,N(ng)-1 + DO i=Istr,Iend + cff=1.0_r8/(BC(i,k)+FCmax(i,k-1)*CF(i,k-1)) + tl_cff=-cff*cff*(tl_BC(i,k)+ & + & tl_FCmax(i,k-1)*CF(i,k-1)+ & + & FCmax(i,k-1)*tl_CF(i,k-1)) + CF(i,k)=cff*FCmin(i,k) + tl_CF(i,k)=tl_cff*FCmin(i,k)+cff*tl_FCmin(i,k) + DC(i,k)=cff*(DC(i,k)+FCmax(i,k-1)*DC(i,k-1)) + tl_DC(i,k)=tl_cff*(DC(i,k)+FCmax(i,k-1)*DC(i,k-1))+ & + & cff*(DC(i,k)+ & + & tl_FCmax(i,k-1)*DC(i,k-1)+ & + & FCmax(i,k-1)*tl_DC(i,k-1)) + END DO + END DO +! +! Compute new solution by back substitution. +! + DO i=Istr,Iend +# ifdef DIAGNOSTICS_TS +!! cff1=t(i,j,N(ng),nnew,itrc)*oHz(i,j,N(ng)) +# endif + cff=1.0_r8/(BC(i,N(ng))+FCmax(i,N(ng)-1)*CF(i,N(ng)-1)) + tl_cff=-cff*cff*(tl_BC(i,N(ng))+ & + & tl_FCmax(i,N(ng)-1)*CF(i,N(ng)-1)+ & + & FCmax(i,N(ng)-1)*tl_CF(i,N(ng)-1)) + DC(i,N(ng))=cff*(DC(i,N(ng))+ & + & FCmax(i,N(ng)-1)*DC(i,N(ng)-1)) + tl_DC(i,N(ng))=tl_cff*(DC(i,N(ng))+ & + & FCmax(i,N(ng)-1)*DC(i,N(ng)-1))+ & + & cff*(tl_DC(i,N(ng))+ & + & tl_FCmax(i,N(ng)-1)*DC(i,N(ng)-1)+ & + & FCmax(i,N(ng)-1)*tl_DC(i,N(ng)-1)) +# ifdef SPLINES_VDIFF +!^ t(i,j,N(ng),nnew,itrc)=DC(i,N(ng)) +!^ + tl_t(i,j,N(ng),nnew,itrc)=tl_DC(i,N(ng)) +# else +!^ t(i,j,N(ng),nnew,itrc)=DC(i,N(ng))*Hz(i,j,N(ng)) +!^ + tl_t(i,j,N(ng),nnew,itrc)=tl_DC(i,N(ng))*Hz(i,j,N(ng))+ & + & DC(i,N(ng))*tl_Hz(i,j,N(ng)) +# endif +# ifdef DIAGNOSTICS_TS +!! DiaTwrk(i,j,N(ng),itrc,iTvadv)=DiaTwrk(i,j,N(ng),itrc, & +!! & iTvadv)+ & +!! & DC(i,N(ng))-cff1 +# endif + END DO +! + DO k=N(ng)-1,1,-1 + DO i=Istr,Iend +# ifdef DIAGNOSTICS_TS +!! cff1=t(i,j,k,nnew,itrc)*oHz(i,j,k) +# endif + DC(i,k)=DC(i,k)-CF(i,k)*DC(i,k+1) + tl_DC(i,k)=tl_DC(i,k)- & + & tl_CF(i,k)*DC(i,k+1)- & + & CF(i,k)*tl_DC(i,k+1) +# ifdef SPLINES_VDIFF +!^ t(i,j,k,nnew,itrc)=DC(i,k) +!^ + tl_t(i,j,k,nnew,itrc)=tl_DC(i,k) +# else +!^ t(i,j,k,nnew,itrc)=DC(i,k)*Hz(i,j,k) +!^ + tl_t(i,j,k,nnew,itrc)=tl_DC(i,k)*Hz(i,j,k)+ & + & DC(i,k)*tl_Hz(i,j,k) +# endif +# ifdef DIAGNOSTICS_TS +!! DiaTwrk(i,j,k,itrc,iTvadv)=DiaTwrk(i,j,k,itrc,iTvadv)+ & +!! & DC(i,k)-cff1 +# endif + END DO + END DO + END IF + END DO + END DO +# endif ! !----------------------------------------------------------------------- ! Time-step vertical diffusion term. diff --git a/ROMS/Tangent/tl_step3d_uv.F b/ROMS/Tangent/tl_step3d_uv.F index d96dc1c4c..d38caa261 100644 --- a/ROMS/Tangent/tl_step3d_uv.F +++ b/ROMS/Tangent/tl_step3d_uv.F @@ -75,6 +75,9 @@ SUBROUTINE tl_step3d_uv (ng, tile) & LBi, UBi, LBj, UBj, & & IminS, ImaxS, JminS, JmaxS, & & nrhs(ng), nstp(ng), nnew(ng), & +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + & knew(ng), & +# endif # ifdef MASKING & GRID(ng) % umask, & & GRID(ng) % vmask, & @@ -85,6 +88,10 @@ SUBROUTINE tl_step3d_uv (ng, tile) # endif & GRID(ng) % om_v, & & GRID(ng) % on_u, & +# ifdef OMEGA_IMPLICIT + & GRID(ng) % om_u, & + & GRID(ng) % on_v, & +# endif & GRID(ng) % pm, & & GRID(ng) % pn, & & GRID(ng) % Hz, & @@ -130,6 +137,10 @@ SUBROUTINE tl_step3d_uv (ng, tile) & OCEAN(ng) % tl_u_stokes, & & OCEAN(ng) % v_stokes, & & OCEAN(ng) % tl_v_stokes, & +# endif +# ifdef OMEGA_IMPLICIT + & OCEAN(ng) % Wi, & + & OCEAN(ng) % tl_Wi, & # endif & GRID(ng) % Huon, & & GRID(ng) % tl_Huon, & @@ -147,13 +158,20 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & & LBi, UBi, LBj, UBj, & & IminS, ImaxS, JminS, JmaxS, & & nrhs, nstp, nnew, & +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + & knew, & +# endif # ifdef MASKING & umask, vmask, & # endif # ifdef WET_DRY_NOT_YET & umask_wet, vmask_wet, & # endif - & om_v, on_u, pm, pn, & + & om_v, on_u, & +# ifdef OMEGA_IMPLICIT + & om_u, on_v, & +# endif + & pm, pn, & & Hz, tl_Hz, & & z_r, tl_z_r, & & z_w, tl_z_w, & @@ -177,6 +195,9 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & & vbar_stokes, tl_vbar_stokes, & & u_stokes, tl_u_stokes, & & v_stokes, tl_v_stokes, & +# endif +# ifdef OMEGA_IMPLICIT + & Wi, tl_Wi, & # endif & Huon, tl_Huon, & & Hvom, tl_Hvom) @@ -188,6 +209,9 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & integer, intent(in) :: LBi, UBi, LBj, UBj integer, intent(in) :: IminS, ImaxS, JminS, JmaxS integer, intent(in) :: nrhs, nstp, nnew +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + integer, intent(in) :: knew +# endif ! # ifdef ASSUMED_SHAPE # ifdef MASKING @@ -200,6 +224,10 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & # endif real(r8), intent(in) :: om_v(LBi:,LBj:) real(r8), intent(in) :: on_u(LBi:,LBj:) +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: om_u(LBi:,LBj:) + real(r8), intent(in) :: on_v(LBi:,LBj:) +# endif real(r8), intent(in) :: pm(LBi:,LBj:) real(r8), intent(in) :: pn(LBi:,LBj:) real(r8), intent(in) :: Hz(LBi:,LBj:,:) @@ -213,10 +241,13 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & real(r8), intent(in) :: u(LBi:,LBj:,:,:) real(r8), intent(in) :: v(LBi:,LBj:,:,:) # ifdef WEC_NOT_YET + real(r8), intent(in) :: u_stokes(LBi:,LBj:,:) + real(r8), intent(in) :: v_stokes(LBi:,LBj:,:) real(r8), intent(in) :: ubar_stokes(LBi:,LBj:) real(r8), intent(in) :: vbar_stokes(LBi:,LBj:) - real(r8), intent(in) :: tl_ubar_stokes(LBi:,LBj:) - real(r8), intent(in) :: tl_vbar_stokes(LBi:,LBj:) +# endif +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: Wi(LBi:,LBj:,0:) # endif real(r8), intent(in) :: tl_Hz(LBi:,LBj:,:) real(r8), intent(in) :: tl_z_r(LBi:,LBj:,:) @@ -228,7 +259,9 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & real(r8), intent(in) :: tl_DV_avg2(LBi:,LBj:) real(r8), intent(in) :: tl_ru(LBi:,LBj:,0:,:) real(r8), intent(in) :: tl_rv(LBi:,LBj:,0:,:) - +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: tl_Wi(LBi:,LBj:,0:) +# endif # ifdef DIAGNOSTICS_UV !! real(r8), intent(inout) :: DiaU2wrk(LBi:,LBj:,:) !! real(r8), intent(inout) :: DiaV2wrk(LBi:,LBj:,:) @@ -244,10 +277,10 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:) real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:) # ifdef WEC_NOT_YET - real(r8), intent(inout) :: u_stokes(LBi:,LBj:,:) - real(r8), intent(inout) :: v_stokes(LBi:,LBj:,:) real(r8), intent(inout) :: tl_u_stokes(LBi:,LBj:,:) real(r8), intent(inout) :: tl_v_stokes(LBi:,LBj:,:) + real(r8), intent(inout) :: tl_ubar_stokes(LBi:,LBj:) + real(r8), intent(inout) :: tl_vbar_stokes(LBi:,LBj:) # endif real(r8), intent(out) :: tl_ubar(LBi:,LBj:,:) real(r8), intent(out) :: tl_vbar(LBi:,LBj:,:) @@ -266,6 +299,10 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & # endif real(r8), intent(in) :: om_v(LBi:UBi,LBj:UBj) real(r8), intent(in) :: on_u(LBi:UBi,LBj:UBj) +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: om_u(LBi:UBi,LBj:UBj) + real(r8), intent(in) :: on_v(LBi:UBi,LBj:UBj) +# endif real(r8), intent(in) :: pm(LBi:UBi,LBj:UBj) real(r8), intent(in) :: pn(LBi:UBi,LBj:UBj) real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng)) @@ -279,12 +316,14 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & real(r8), intent(in) :: u(LBi:UBi,LBj:UBj,N(ng),2) real(r8), intent(in) :: v(LBi:UBi,LBj:UBj,N(ng),2) # ifdef WEC_NOT_YET + real(r8), intent(in) :: u_stokes(LBi:UBi,LBj:UBj,N(ng)) + real(r8), intent(in) :: v_stokes(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(in) :: ubar_stokes(LBi:UBi,LBj:UBj) real(r8), intent(in) :: vbar_stokes(LBi:UBi,LBj:UBj) - real(r8), intent(in) :: tl_ubar_stokes(LBi:UBi,LBj:UBj) - real(r8), intent(in) :: tl_vbar_stokes(LBi:UBi,LBj:UBj) # endif - +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: Wi(LBi:UBi,LBj:UBj,0:N(ng)) +# endif real(r8), intent(in) :: tl_Hz(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(in) :: tl_z_r(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(in) :: tl_z_w(LBi:UBi,LBj:UBj,0:N(ng)) @@ -295,6 +334,9 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & real(r8), intent(in) :: tl_DV_avg2(LBi:UBi,LBj:UBj) real(r8), intent(in) :: tl_ru(LBi:UBi,LBj:UBj,0:N(ng),2) real(r8), intent(in) :: tl_rv(LBi:UBi,LBj:UBj,0:N(ng),2) +# ifdef OMEGA_IMPLICIT + real(r8), intent(in) :: tl_Wi(LBi:UBi,LBj:UBj,0:N(ng)) +# endif # ifdef DIAGNOSTICS_UV !! real(r8), intent(inout) :: DiaU2wrk(LBi:UBi,LBj:UBj,NDM2d) !! real(r8), intent(inout) :: DiaV2wrk(LBi:UBi,LBj:UBj,NDM2d) @@ -310,13 +352,13 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2) real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2) # ifdef WEC_NOT_YET - real(r8), intent(inout) :: u_stokes(LBi:UBi,LBj:UBj,N(ng)) - real(r8), intent(inout) :: v_stokes(LBi:UBi,LBj:UBj,N(ng)) + real(r8), intent(inout) :: tl_u_stokes(LBi:UBi,LBj:UBj,N(ng)) + real(r8), intent(inout) :: tl_v_stokes(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(inout) :: tl_u_stokes(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(inout) :: tl_v_stokes(LBi:UBi,LBj:UBj,N(ng)) # endif - real(r8), intent(out) :: tl_ubar(LBi:UBi,LBj:UBj,3) - real(r8), intent(out) :: tl_vbar(LBi:UBi,LBj:UBj,3) + real(r8), intent(out) :: tl_ubar(LBi:UBi,LBj:UBj,:) + real(r8), intent(out) :: tl_vbar(LBi:UBi,LBj:UBj,:) real(r8), intent(out) :: tl_Huon(LBi:UBi,LBj:UBj,N(ng)) real(r8), intent(out) :: tl_Hvom(LBi:UBi,LBj:UBj,N(ng)) # endif @@ -340,6 +382,11 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & real(r8), dimension(IminS:ImaxS,0:N(ng)) :: DC real(r8), dimension(IminS:ImaxS,0:N(ng)) :: DC1 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FC +# ifdef OMEGA_IMPLICIT + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FCmin + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: FCmax + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: WK +# endif # ifdef WEC_NOT_YET real(r8), dimension(IminS:ImaxS,0:N(ng)) :: CFs real(r8), dimension(IminS:ImaxS,0:N(ng)) :: DCs @@ -355,6 +402,11 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_CF real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_DC real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_FC +# ifdef OMEGA_IMPLICIT + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_FCmin + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_FCmax + real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_WK +# endif # ifdef WEC_NOT_YET real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_CFs real(r8), dimension(IminS:ImaxS,0:N(ng)) :: tl_DCs @@ -671,6 +723,136 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & END DO END DO # endif +# ifdef OMEGA_IMPLICIT +! +! Adaptive, Courant-number based implicit vertical advection +! contribution for u-momentum. +! + DO i=IstrU,Iend + WK(i,0)=0.5_r8*(Wi(i-1,j,0)+ & + & Wi(i ,j,0)) + tl_WK(i,0)=0.5_r8*(tl_Wi(i-1,j,0)+ & + & tl_Wi(i ,j,0)) + DO k=1,N(ng) + WK(i,k)=0.5_r8*(Wi(i-1,j,k)+ & + & Wi(i ,j,k)) + tl_WK(i,k)=0.5_r8*(tl_Wi(i-1,j,k)+ & + & tl_Wi(i ,j,k)) + Hzk(i,k)=0.5_r8*(Hz(i-1,j,k)+ & + & Hz(i ,j,k)) + tl_Hzk(i,k)=0.5_r8*(tl_Hz(i-1,j,k)+ & + & tl_Hz(i ,j,k)) + END DO + END DO +! +! Compute off-diagonal coefficients [dt*Wi*pm*pn] for the +! implicit vertical viscosity term at horizontal U-points and +! vertical W-points. +! + cff=dt(ng) + DO k=1,N(ng)-1 + DO i=IstrU,Iend + cff1=cff/(on_u(i,j)*om_u(i,j)) + FCmax(i,k)=MAX(WK(i,k),0.0_r8)*cff1 + FCmin(i,k)=MIN(WK(i,k),0.0_r8)*cff1 + tl_FCmax(i,k)=(0.5_r8+SIGN(0.5_r8, WK(i,k)))* & + & tl_WK(i,k)*cff1 + tl_FCmin(i,k)=(0.5_r8+SIGN(0.5_r8,-WK(i,k)))* & + & tl_WK(i,k)*cff1 + END DO + END DO + DO i=IstrU,Iend + FCmax(i,0)=0.0_r8 + FCmin(i,0)=0.0_r8 + FCmax(i,N(ng))=0.0_r8 + FCmin(i,N(ng))=0.0_r8 + + tl_FCmax(i,0)=0.0_r8 + tl_FCmin(i,0)=0.0_r8 + tl_FCmax(i,N(ng))=0.0_r8 + tl_FCmin(i,N(ng))=0.0_r8 + END DO +! +! Solve the tridiagonal system. +! + DO k=1,N(ng) + DO i=IstrU,Iend + BC(i,k)=Hzk(i,k)+FCmax(i,k)-FCmin(i,k-1) + tl_BC(i,k)=tl_Hzk(i,k)+tl_FCmax(i,k)-tl_FCmin(i,k-1) + DC(i,k)=u(i,j,k,nnew)*Hzk(i,k) + tl_DC(i,k)=tl_u(i,j,k,nnew)*Hzk(i,k)+ & + & u(i,j,k,nnew)*tl_Hzk(i,k) + END DO + END DO + DO i=IstrU,Iend + cff=1.0_r8/BC(i,1) + tl_cff=-cff*cff*tl_BC(i,1) + CF(i,1)=cff*FCmin(i,1) + tl_CF(i,1)=tl_cff*FCmin(i,1)+cff*tl_FCmin(i,1) + DC(i,1)=cff*DC(i,1) + tl_DC(i,1)=tl_cff*DC(i,1)+cff*tl_DC(i,1) + END DO + DO k=2,N(ng)-1 + DO i=IstrU,Iend + cff=1.0_r8/(BC(i,k)+FCmax(i,k-1)*CF(i,k-1)) + tl_cff=-cff*cff*(tl_BC(i,k)+ & + & tl_FCmax(i,k-1)*CF(i,k-1)+ & + & FCmax(i,k-1)*tl_CF(i,k-1)) + CF(i,k)=cff*FCmin(i,k) + tl_CF(i,k)=tl_cff*FCmin(i,k)+cff*tl_FCmin(i,k) + DC(i,k)=cff*(DC(i,k)+FCmax(i,k-1)*DC(i,k-1)) + tl_DC(i,k)=tl_cff*(DC(i,k)+FCmax(i,k-1)*DC(i,k-1))+ & + & cff*(DC(i,k)+ & + & tl_FCmax(i,k-1)*DC(i,k-1)+ & + & FCmax(i,k-1)*tl_DC(i,k-1)) + END DO + END DO +! +! Compute new solution by back substitution. +! + DO i=IstrU,Iend +# ifdef DIAGNOSTICS_UV +!! cff1=u(i,j,N(ng),nnew) +# endif + cff=1.0_r8/(BC(i,N(ng))+FCmax(i,N(ng)-1)*CF(i,N(ng)-1)) + tl_cff=-cff*cff*(tl_BC(i,N(ng))+ & + & tl_FCmax(i,N(ng)-1)*CF(i,N(ng)-1)+ & + & FCmax(i,N(ng)-1)*tl_CF(i,N(ng)-1)) + DC(i,N(ng))=cff*(DC(i,N(ng))+ & + & FCmax(i,N(ng)-1)*DC(i,N(ng)-1)) + tl_DC(i,N(ng))=tl_cff*(DC(i,N(ng))+ & + & FCmax(i,N(ng)-1)*DC(i,N(ng)-1))+ & + & cff*(tl_DC(i,N(ng))+ & + & tl_FCmax(i,N(ng)-1)*DC(i,N(ng)-1)+ & + & FCmax(i,N(ng)-1)*tl_DC(i,N(ng)-1)) +!^ u(i,j,N(ng),nnew)=DC(i,N(ng)) +!^ + tl_u(i,j,N(ng),nnew)=tl_DC(i,N(ng)) +# ifdef DIAGNOSTICS_UV +!! DiaRU(i,j,N(ng),nrhs,M3vadv)=DiaRU(i,j,N(ng),nrhs,M3vadv)+ & +!! & u(i,j,N(ng),nnew)-cff1 +# endif + END DO +! + DO k=N(ng)-1,1,-1 + DO i=IstrU,Iend +# ifdef DIAGNOSTICS_UV +!! cff1=u(i,j,k,nnew) +# endif + DC(i,k)=DC(i,k)-CF(i,k)*DC(i,k+1) + tl_DC(i,k)=tl_DC(i,k)- & + & tl_CF(i,k)*DC(i,k+1)- & + & CF(i,k)*tl_DC(i,k+1) +!^ u(i,j,k,nnew)=DC(i,k) +!^ + tl_u(i,j,k,nnew)=tl_DC(i,k) +# ifdef DIAGNOSTICS_UV +!! DiaRU(i,j,k,nrhs,M3vadv)=DiaRU(i,j,k,nrhs,M3vadv)+ & +!! & u(i,j,k,nnew)-cff1 +# endif + END DO + END DO +# endif ! ! Replace INTERIOR POINTS incorrect vertical mean with more accurate ! barotropic component, ubar=DU_avg1/(D*on_u). Recall that, D=CF(:,0). @@ -1149,6 +1331,136 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & END DO END DO # endif +# ifdef OMEGA_IMPLICIT +! +! Adaptive, Courant-number based implicit vertical advection +! contribution for v-momentum. +! + DO i=Istr,Iend + WK(i,0)=0.5_r8*(Wi(i,j-1,0)+ & + & Wi(i,j ,0)) + tl_WK(i,0)=0.5_r8*(tl_Wi(i,j-1,0)+ & + & tl_Wi(i,j ,0)) + DO k=1,N(ng) + WK(i,k)=0.5_r8*(Wi(i,j-1,k)+ & + & Wi(i,j ,k)) + tl_WK(i,k)=0.5_r8*(tl_Wi(i,j-1,k)+ & + & tl_Wi(i,j ,k)) + Hzk(i,k)=0.5_r8*(Hz(i,j-1,k)+ & + & Hz(i,j ,k)) + tl_Hzk(i,k)=0.5_r8*(tl_Hz(i,j-1,k)+ & + & tl_Hz(i,j ,k)) + END DO + END DO +! +! Compute off-diagonal coefficients [dt*Wi*pm*pn] for the +! implicit vertical viscosity term at horizontal V-points and +! vertical W-points. +! + cff=dt(ng) + DO k=1,N(ng)-1 + DO i=Istr,Iend + cff1=cff/(on_v(i,j)*om_v(i,j)) + FCmax(i,k)=MAX(WK(i,k),0.0_r8)*cff1 + FCmin(i,k)=MIN(WK(i,k),0.0_r8)*cff1 + tl_FCmax(i,k)=(0.5_r8+SIGN(0.5_r8, WK(i,k)))* & + & tl_WK(i,k)*cff1 + tl_FCmin(i,k)=(0.5_r8+SIGN(0.5_r8,-WK(i,k)))* & + & tl_WK(i,k)*cff1 + END DO + END DO + DO i=Istr,Iend + FCmax(i,0)=0.0_r8 + FCmin(i,0)=0.0_r8 + FCmax(i,N(ng))=0.0_r8 + FCmin(i,N(ng))=0.0_r8 + + tl_FCmax(i,0)=0.0_r8 + tl_FCmin(i,0)=0.0_r8 + tl_FCmax(i,N(ng))=0.0_r8 + tl_FCmin(i,N(ng))=0.0_r8 + END DO +! +! Solve the tridiagonal system. +! + DO k=1,N(ng) + DO i=Istr,Iend + BC(i,k)=Hzk(i,k)+FCmax(i,k)-FCmin(i,k-1) + tl_BC(i,k)=tl_Hzk(i,k)+tl_FCmax(i,k)-tl_FCmin(i,k-1) + DC(i,k)=v(i,j,k,nnew)*Hzk(i,k) + tl_DC(i,k)=tl_v(i,j,k,nnew)*Hzk(i,k)+ & + & v(i,j,k,nnew)*tl_Hzk(i,k) + END DO + END DO + DO i=Istr,Iend + cff=1.0_r8/BC(i,1) + tl_cff=-cff*cff*tl_BC(i,1) + CF(i,1)=cff*FCmin(i,1) + tl_CF(i,1)=tl_cff*FCmin(i,1)+cff*tl_FCmin(i,1) + DC(i,1)=cff*DC(i,1) + tl_DC(i,1)=tl_cff*DC(i,1)+cff*tl_DC(i,1) + END DO + DO k=2,N(ng)-1 + DO i=Istr,Iend + cff=1.0_r8/(BC(i,k)+FCmax(i,k-1)*CF(i,k-1)) + tl_cff=-cff*cff*(tl_BC(i,k)+ & + & tl_FCmax(i,k-1)*CF(i,k-1)+ & + & FCmax(i,k-1)*tl_CF(i,k-1)) + CF(i,k)=cff*FCmin(i,k) + tl_CF(i,k)=tl_cff*FCmin(i,k)+cff*tl_FCmin(i,k) + DC(i,k)=cff*(DC(i,k)+FCmax(i,k-1)*DC(i,k-1)) + tl_DC(i,k)=tl_cff*(DC(i,k)+FCmax(i,k-1)*DC(i,k-1))+ & + & cff*(DC(i,k)+ & + & tl_FCmax(i,k-1)*DC(i,k-1)+ & + & FCmax(i,k-1)*tl_DC(i,k-1)) + END DO + END DO +! +! Compute new solution by back substitution. +! + DO i=Istr,Iend +# ifdef DIAGNOSTICS_UV +!! cff1=v(i,j,N(ng),nnew) +# endif + cff=1.0_r8/(BC(i,N(ng))+FCmax(i,N(ng)-1)*CF(i,N(ng)-1)) + tl_cff=-cff*cff*(tl_BC(i,N(ng))+ & + & tl_FCmax(i,N(ng)-1)*CF(i,N(ng)-1)+ & + & FCmax(i,N(ng)-1)*tl_CF(i,N(ng)-1)) + DC(i,N(ng))=cff*(DC(i,N(ng))+ & + & FCmax(i,N(ng)-1)*DC(i,N(ng)-1)) + tl_DC(i,N(ng))=tl_cff*(DC(i,N(ng))+ & + & FCmax(i,N(ng)-1)*DC(i,N(ng)-1))+ & + & cff*(tl_DC(i,N(ng))+ & + & tl_FCmax(i,N(ng)-1)*DC(i,N(ng)-1)+ & + & FCmax(i,N(ng)-1)*tl_DC(i,N(ng)-1)) +!^ v(i,j,N(ng),nnew)=DC(i,N(ng)) +!^ + tl_v(i,j,N(ng),nnew)=tl_DC(i,N(ng)) +# ifdef DIAGNOSTICS_UV +!! DiaRV(i,j,N(ng),nrhs,M3vadv)=DiaRV(i,j,N(ng),nrhs,M3vadv)+ & +!! & v(i,j,N(ng),nnew)-cff1 +# endif + END DO +! + DO k=N(ng)-1,1,-1 + DO i=Istr,Iend +# ifdef DIAGNOSTICS_UV +!! cff1=v(i,j,k,nnew) +# endif + DC(i,k)=DC(i,k)-CF(i,k)*DC(i,k+1) + tl_DC(i,k)=tl_DC(i,k)- & + & tl_CF(i,k)*DC(i,k+1)- & + & CF(i,k)*tl_DC(i,k+1) +!^ v(i,j,k,nnew)=DC(i,k) +!^ + tl_v(i,j,k,nnew)=tl_DC(i,k) +# ifdef DIAGNOSTICS_UV +!! DiaRV(i,j,k,nrhs,M3vadv)=DiaRV(i,j,k,nrhs,M3vadv)+ & +!! & v(i,j,k,nnew)-cff1 +# endif + END DO + END DO +# endif ! ! Replace INTERIOR POINTS incorrect vertical mean with more accurate ! barotropic component, vbar=DV_avg1/(D*om_v). Recall that, D=CF(:,0). @@ -1456,13 +1768,30 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & tl_CFs(i,0)=tl_DC(i,0)*(CFs1(i)-cff2)+ & & DC(i,0)*(tl_CFs(i,0)-tl_cff2) # endif +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +!^ ubar(i,j,knew)=DC(i,0)*DU_avg1(i,j) +!^ + tl_ubar(i,j,knew)=tl_DC(i,0)*DU_avg1(i,j)+ & + & DC(i,0)*tl_DU_avg1(i,j) +# ifdef WET_DRY_NOT_YET +!^ ubar(i,j,knew)=ubar(i,j,knew)*umask_wet(i,j) +!^ +!! tl_ubar(i,j,knew)=tl_ubar(i,j,knew)*umask_wet(i,j) +# endif +# else !^ ubar(i,j,1)=DC(i,0)*DU_avg1(i,j) !^ tl_ubar(i,j,1)=tl_DC(i,0)*DU_avg1(i,j)+ & & DC(i,0)*tl_DU_avg1(i,j) +# ifdef WET_DRY_NOT_YET +!^ ubar(i,j,1)=ubar(i,j,1)*umask_wet(i,j) +!^ +!! tl_ubar(i,j,1)=tl_ubar(i,j,1)*umask_wet(i,j) +# endif !^ ubar(i,j,2)=ubar(i,j,1) !^ tl_ubar(i,j,2)=tl_ubar(i,j,1) +# endif # ifdef DIAGNOSTICS_UV !! DiaU2wrk(i,j,M2rate)=ubar(i,j,1)-DiaU2int(i,j,M2rate)*DC(i,0) !! DiaU2int(i,j,M2rate)=ubar(i,j,1)*DC1(i,0) @@ -1773,13 +2102,30 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & tl_CFs(i,0)=tl_DC(i,0)*(CFs1(i)-cff2)+ & & DC(i,0)*(tl_CFs(i,0)-tl_cff2) # endif +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +!^ vbar(i,j,knew)=DC(i,0)*DV_avg1(i,j) +!^ + tl_vbar(i,j,knew)=tl_DC(i,0)*DV_avg1(i,j)+ & + & DC(i,0)*tl_DV_avg1(i,j) +# ifdef WET_DRY_NOT_YET +!^ vbar(i,j,knew)=vbar(i,j,knew)*vmask_wet(i,j) +!^ +!! tl_vbar(i,j,knew)=tl_vbar(i,j,knew)*vmask_wet(i,j) +# endif +# else !^ vbar(i,j,1)=DC(i,0)*DV_avg1(i,j) !^ tl_vbar(i,j,1)=tl_DC(i,0)*DV_avg1(i,j)+ & & DC(i,0)*tl_DV_avg1(i,j) +# ifdef WET_DRY_NOT_YET +!^ vbar(i,j,1)=vbar(i,j,1)*vmask_wet(i,j) +!^ +!! tl_vbar(i,j,1)=tl_vbar(i,j,1)*vmask_wet(i,j) +# endif !^ vbar(i,j,2)=vbar(i,j,1) !^ tl_vbar(i,j,2)=tl_vbar(i,j,1) +# endif # ifdef DIAGNOSTICS_UV !! DiaV2wrk(i,j,M2rate)=vbar(i,j,1)- & !! & DiaV2int(i,j,M2rate)*DC(i,0) @@ -1917,7 +2263,7 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & & tl_CF(i,0) # ifdef MASKING !^ v(i,j,k,nnew)=v(i,j,k,nnew)* -!^ & vmask(i,j) +!^ & vmask(i,j) !^ tl_v(i,j,k,nnew)=tl_v(i,j,k,nnew)* & & vmask(i,j) @@ -2073,6 +2419,22 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & & LBi, UBi, LBj, UBj, 1, N(ng), & & tl_Hvom) ! +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +!^ CALL exchange_u2d_tile (ng, tile, & +!^ & LBi, UBi, LBj, UBj, & +!^ & ubar(:,:,knew)) +!^ + CALL exchange_u2d_tile (ng, tile, & + & LBi, UBi, LBj, UBj, & + & tl_ubar(:,:,knew)) +!^ CALL exchange_v2d_tile (ng, tile, & +!^ & LBi, UBi, LBj, UBj, & +!^ & vbar(:,:,knew)) +!^ + CALL exchange_v2d_tile (ng, tile, & + & LBi, UBi, LBj, UBj, & + & tl_vbar(:,:,knew)) +# else DO k=1,2 !^ CALL exchange_u2d_tile (ng, tile, & !^ & LBi, UBi, LBj, UBj, & @@ -2089,6 +2451,7 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & & LBi, UBi, LBj, UBj, & & tl_vbar(:,:,k)) END DO +# endif END IF # ifdef DISTRIBUTE @@ -2111,6 +2474,19 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & & EWperiodic(ng), NSperiodic(ng), & & Huon, Hvom) ! +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +!^ CALL mp_exchange2d (ng, tile, iNLM, 2, & +!^ & LBi, UBi, LBj, UBj, & +!^ & NghostPoints, & +!^ & EWperiodic(ng), NSperiodic(ng), & +!^ & ubar(:,:,knew), vbar(:,:,knew)) +!^ + CALL mp_exchange2d (ng, tile, iTLM, 2, & + & LBi, UBi, LBj, UBj, & + & NghostPoints, & + & EWperiodic(ng), NSperiodic(ng), & + & tl_ubar(:,:,knew), tl_vbar(:,:,knew)) +# else !^ CALL mp_exchange2d (ng, tile, iNLM, 4, & !^ & LBi, UBi, LBj, UBj, & !^ & NghostPoints, & @@ -2124,6 +2500,7 @@ SUBROUTINE tl_step3d_uv_tile (ng, tile, & & EWperiodic(ng), NSperiodic(ng), & & tl_ubar(:,:,1), tl_vbar(:,:,1), & & tl_ubar(:,:,2), tl_vbar(:,:,2)) +# endif # endif # ifdef UV_DESTAGGERED ! diff --git a/ROMS/Tangent/tl_zetabc.F b/ROMS/Tangent/tl_zetabc.F index 1f3a74577..a3ba625a0 100644 --- a/ROMS/Tangent/tl_zetabc.F +++ b/ROMS/Tangent/tl_zetabc.F @@ -9,27 +9,41 @@ MODULE tl_zetabc_mod ! See License_ROMS.md ! !======================================================================= ! ! -! This subroutine sets tangent linear lateral boundary conditions for ! -! free-surface. It updates the specified "kout" time index. ! +! This routine sets tangent linear lateral boundary conditions for ! +! free-surface. ! +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +! +! Notice that "zetabc_local" is used for either the Forward-Backward ! +! AB3-AM4 or Forward-Backward LF-AM3 barotropic kernels where the ! +! boundary conditions are loaded into private array "zeta_new". ! +# endif ! ! ! BASIC STATE variables fields needed: zeta ! ! ! !======================================================================= +! + USE mod_param + USE mod_boundary + USE mod_grid + USE mod_ncparam + USE mod_ocean + USE mod_scalars + USE mod_stepping ! implicit none ! PRIVATE - PUBLIC :: tl_zetabc, tl_zetabc_tile + PUBLIC :: tl_zetabc +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + PUBLIC :: tl_zetabc_local +# endif + PUBLIC :: tl_zetabc_tile ! CONTAINS ! !*********************************************************************** SUBROUTINE tl_zetabc (ng, tile, kout) !*********************************************************************** -! - USE mod_param - USE mod_ocean - USE mod_stepping ! ! Imported variable declarations. ! @@ -56,12 +70,6 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & & krhs, kstp, kout, & & zeta, tl_zeta) !*********************************************************************** -! - USE mod_param - USE mod_boundary - USE mod_grid - USE mod_ncparam - USE mod_scalars ! ! Imported variable declarations. ! @@ -71,13 +79,13 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & integer, intent(in) :: krhs, kstp, kout ! # ifdef ASSUMED_SHAPE - real(r8), intent(in) :: zeta(LBi:,LBj:,:) + real(r8), intent(in ) :: zeta(LBi:,LBj:,:) real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:) # else - real(r8), intent(in) :: zeta(LBi:UBi,LBj:UBj,3) + real(r8), intent(in ) :: zeta(LBi:UBi,LBj:UBj,:) - real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,3) + real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:) # endif ! ! Local variable declarations. @@ -98,6 +106,10 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & ! Set time-indices !----------------------------------------------------------------------- ! +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 + know=kstp + dt2d=dtfast(ng) +# else IF (FIRST_2D_STEP) THEN know=krhs dt2d=dtfast(ng) @@ -108,6 +120,7 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & know=kstp dt2d=dtfast(ng) END IF +# endif ! !----------------------------------------------------------------------- ! Lateral boundary conditions at the western edge. @@ -116,15 +129,19 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & IF (DOMAIN(ng)%Western_Edge(tile)) THEN ! ! Western edge, implicit upstream radiation condition. +! (Not implemented since the TLM requires nonlinear celerity at every +! timestep. Using gradient instead). ! IF (tl_LBC(iwest,isFsur,ng)%radiation) THEN IF (iic(ng).ne.0) THEN +# if defined CELERITY_READ && defined FORWARD_READ DO j=Jstr,Jend+1 !^ grad(Istr-1,j)=zeta(Istr-1,j ,know)- & !^ & zeta(Istr-1,j-1,know) !^ tl_grad(Istr-1,j)=0.0_r8 END DO +# endif DO j=Jstr,Jend IF (LBC_apply(ng)%west(j)) THEN # if defined CELERITY_READ && defined FORWARD_READ @@ -143,7 +160,6 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & Ce=0.0_r8 # endif cff=BOUNDARY(ng)%zeta_west_C2(j) -# endif !^ zeta(Istr-1,j,kout)=(cff*zeta(Istr-1,j,know)+ & !^ & Cx *zeta(Istr ,j,kout)- & !^ & MAX(Ce,0.0_r8)*grad(Istr-1,j )- & @@ -166,6 +182,11 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & tl_zeta(Istr-1,j,kout)=tl_zeta(Istr-1,j,kout)- & & tau*tl_zeta(Istr-1,j,know) END IF +# else +!^ zeta(Istr-1,j,kout)=zeta(Istr,j,kout) ! gradient +!^ + tl_zeta(Istr-1,j,kout)=tl_zeta(Istr,j,kout) +# endif # ifdef MASKING !^ zeta(Istr-1,j,kout)=zeta(Istr-1,j,kout)* & !^ & GRID(ng)%rmask(Istr-1,j) @@ -309,15 +330,19 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & IF (DOMAIN(ng)%Eastern_Edge(tile)) THEN ! ! Eastern edge, implicit upstream radiation condition. +! (Not implemented since the TLM requires nonlinear celerity at every +! timestep. Using gradient instead). ! IF (tl_LBC(ieast,isFsur,ng)%radiation) THEN IF (iic(ng).ne.0) THEN +# if defined CELERITY_READ && defined FORWARD_READ DO j=Jstr,Jend+1 !^ grad(Iend+1,j)=zeta(Iend+1,j ,know)- & !^ & zeta(Iend+1,j-1,know) !^ tl_grad(Iend+1,j)=0.0_r8 END DO +# endif DO j=Jstr,Jend IF (LBC_apply(ng)%east(j)) THEN # if defined CELERITY_READ && defined FORWARD_READ @@ -336,7 +361,7 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & Ce=0.0_r8 # endif cff=BOUNDARY(ng)%zeta_east_C2(j) -# endif + !^ zeta(Iend+1,j,kout)=(cff*zeta(Iend+1,j,know)+ & !^ & Cx *zeta(Iend ,j,kout)- & !^ & MAX(Ce,0.0_r8)*grad(Iend+1,j )- & @@ -359,6 +384,11 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & tl_zeta(Iend+1,j,kout)=tl_zeta(Iend+1,j,kout)- & & tau*tl_zeta(Iend+1,j,know) END IF +# else +!^ zeta(Iend+1,j,kout)=zeta(Iend,j,kout) ! gradient +!^ + tl_zeta(Iend+1,j,kout)=tl_zeta(Iend,j,kout) +# endif # ifdef MASKING !^ zeta(Iend+1,j,kout)=zeta(Iend+1,j,kout)* & !^ & GRID(ng)%rmask(Iend+1,j) @@ -502,15 +532,19 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & IF (DOMAIN(ng)%Southern_Edge(tile)) THEN ! ! Southern edge, implicit upstream radiation condition. +! (Not implemented since the TLM requires nonlinear celerity at every +! timestep. Using gradient instead). ! IF (tl_LBC(isouth,isFsur,ng)%radiation) THEN IF (iic(ng).ne.0) THEN +# if defined CELERITY_READ && defined FORWARD_READ DO i=Istr,Iend+1 !^ grad(i,Jstr)=zeta(i ,Jstr,know)- & !^ & zeta(i-1,Jstr,know) !^ tl_grad(i,Jstr)=0.0_r8 END DO +# endif DO i=Istr,Iend IF (LBC_apply(ng)%south(i)) THEN # if defined CELERITY_READ && defined FORWARD_READ @@ -529,7 +563,7 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & # endif Ce=BOUNDARY(ng)%zeta_south_Ce(i) cff=BOUNDARY(ng)%zeta_south_C2(i) -# endif + !^ zeta(i,Jstr-1,kout)=(cff*zeta(i,Jstr-1,know)+ & !^ & Ce *zeta(i,Jstr ,kout)- & !^ & MAX(Cx,0.0_r8)*grad(i ,Jstr)- & @@ -552,6 +586,11 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & tl_zeta(i,Jstr-1,kout)=tl_zeta(i,Jstr-1,kout)- & & tau*tl_zeta(i,Jstr-1,know) END IF +# else +!^ zeta(i,Jstr-1,kout)=zeta(i,Jstr,kout) ! gradient +!^ + tl_zeta(i,Jstr-1,kout)=tl_zeta(i,Jstr,kout) +# endif # ifdef MASKING !^ zeta(i,Jstr-1,kout)=zeta(i,Jstr-1,kout)* & !^ & GRID(ng)%rmask(i,Jstr-1) @@ -695,15 +734,19 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & IF (DOMAIN(ng)%Northern_Edge(tile)) THEN ! ! Northern edge, implicit upstream radiation condition. +! (Not implemented since the TLM requires nonlinear celerity at every +! timestep. Using gradient instead). ! IF (tl_LBC(inorth,isFsur,ng)%radiation) THEN IF (iic(ng).ne.0) THEN +# if defined CELERITY_READ && defined FORWARD_READ DO i=Istr,Iend+1 !^ grad(i,Jend+1)=zeta(i ,Jend+1,know)- & !^ & zeta(i-1,Jend+1,know) !^ tl_grad(i,Jend+1)=0.0_r8 END DO +# endif DO i=Istr,Iend IF (LBC_apply(ng)%north(i)) THEN # if defined CELERITY_READ && defined FORWARD_READ @@ -722,7 +765,7 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & # endif Ce=BOUNDARY(ng)%zeta_north_Ce(i) cff=BOUNDARY(ng)%zeta_north_C2(i) -# endif + !^ zeta(i,Jend+1,kout)=(cff*zeta(i,Jend+1,know)+ & !^ & Ce *zeta(i,Jend ,kout)- & !^ & MAX(Cx,0.0_r8)*grad(i ,Jend+1)- & @@ -745,6 +788,11 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & tl_zeta(i,Jend+1,kout)=tl_zeta(i,Jend+1,kout)- & & tau*tl_zeta(i,Jend+1,know) END IF +# else +!^ zeta(i,Jend+1,kout)=zeta(i,Jend,kout) ! gradient +!^ + tl_zeta(i,Jend+1,kout)=tl_zeta(i,Jend,kout) +# endif # ifdef MASKING !^ zeta(i,Jend+1,kout)=zeta(i,Jend+1,kout)* & !^ & GRID(ng)%rmask(i,Jend+1) @@ -965,7 +1013,7 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & END DO END IF END IF - +! IF (.not.NSperiodic(ng)) THEN IF (DOMAIN(ng)%Southern_Edge(tile)) THEN DO i=Istr,Iend @@ -992,7 +1040,7 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & END DO END IF END IF - +! IF (.not.(EWperiodic(ng).or.NSperiodic(ng))) THEN IF (DOMAIN(ng)%SouthWest_Corner(tile)) THEN IF (LBC_apply(ng)%south(Istr-1).and. & @@ -1040,8 +1088,1033 @@ SUBROUTINE tl_zetabc_tile (ng, tile, & END IF END IF # endif - +! RETURN END SUBROUTINE tl_zetabc_tile + +# if defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3 +! +!*********************************************************************** + SUBROUTINE tl_zetabc_local (ng, tile, & + & LBi, UBi, LBj, UBj, & + & IminS, ImaxS, JminS, JmaxS, & + & kstp, & + & zeta, tl_zeta, & + & zeta_new, tl_zeta_new) +!*********************************************************************** +! +! Imported variable declarations. +! + integer, intent(in) :: ng, tile + integer, intent(in) :: LBi, UBi, LBj, UBj + integer, intent(in) :: IminS, ImaxS, JminS, JmaxS + integer, intent(in) :: kstp +! +# ifdef ASSUMED_SHAPE + real(r8), intent(in ) :: zeta(LBi:,LBj:,:) + real(r8), intent(in ) :: tl_zeta(LBi:,LBj:,:) + real(r8), intent(in ) :: zeta_new(IminS:,JminS:) + + real(r8), intent(inout) :: tl_zeta_new(IminS:,JminS:) +# else + real(r8), intent(in ) :: zeta(LBi:UBi,LBj:UBj,:) + real(r8), intent(in ) :: tl_zeta(LBi:UBi,LBj:UBj,:) + real(r8), intent(in ) :: zeta_new(IminS:ImaxS,JminS:JmaxS) + + real(r8), intent(inout) :: tl_zeta_new(IminS:ImaxS,JminS:JmaxS) +# endif +! +! Local variable declarations. +! + integer :: i, j, know + + real(r8) :: Ce, Cx + real(r8) :: cff, cff1, cff2, dt2d, tau + + real(r8) :: tl_Ce, tl_Cx + real(r8) :: tl_cff1, tl_cff2 + + real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: tl_grad + +# include "set_bounds.h" +! +!----------------------------------------------------------------------- +! Set time-indices +!----------------------------------------------------------------------- +! + know=kstp + dt2d=dtfast(ng) +! +!----------------------------------------------------------------------- +! Lateral boundary conditions at the western edge. +!----------------------------------------------------------------------- +! + IF (DOMAIN(ng)%Western_Edge(tile)) THEN +! +! Western edge, implicit upstream radiation condition. +! (Not implemented since the TLM requires nonlinear celerity at every +! timestep. Using gradient instead). +! + IF (tl_LBC(iwest,isFsur,ng)%radiation) THEN + IF (iic(ng).ne.0) THEN +# if defined CELERITY_READ && defined FORWARD_READ + DO j=JstrV-1,Jend+1 +!^ grad(Istr-1,j)=zeta(Istr-1,j ,know)- & +!^ & zeta(Istr-1,j-1,know) +!^ + tl_grad(Istr-1,j)=0.0_r8 + END DO +# endif + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN +# if defined CELERITY_READ && defined FORWARD_READ + IF (tl_LBC(iwest,isFsur,ng)%nudging) THEN + IF (BOUNDARY(ng)%zeta_west_Cx(j).eq.0.0_r8) THEN + tau=FSobc_in(ng,iwest) + ELSE + tau=FSobc_out(ng,iwest) + END IF + tau=tau*dt2d + END IF + Cx=BOUNDARY(ng)%zeta_west_Cx(j) +# ifdef RADIATION_2D + Ce=BOUNDARY(ng)%zeta_west_Ce(j) +# else + Ce=0.0_r8 +# endif + cff=BOUNDARY(ng)%zeta_west_C2(j) + +!^ zeta_new(Istr-1,j)=(cff*zeta(Istr-1,j,know)+ & +!^ & Cx *zeta_new(Istr,j)- & +!^ & MAX(Ce,0.0_r8)*grad(Istr-1,j )- & +!^ & MIN(Ce,0.0_r8)*grad(Istr-1,j+1))/ & +!^ & (cff+Cx) +!^ + tl_zeta_new(Istr-1,j)=(cff*tl_zeta(Istr-1,j,know)+ & + & Cx *tl_zeta_new(Istr,j)- & + & MAX(Ce,0.0_r8)* & + & tl_grad(Istr-1,j )- & + & MIN(Ce,0.0_r8)* & + & tl_grad(Istr-1,j+1))/ & + & (cff+Cx) + + IF (tl_LBC(iwest,isFsur,ng)%nudging) THEN +!^ zeta_new(Istr-1,j)=zeta_new(Istr-1,j)+ & +!^ & tau*(BOUNDARY(ng)%zeta_west(j)- & +!^ & zeta(Istr-1,j,know)) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)- & + & tau*tl_zeta(Istr-1,j,know) + END IF +# else +!^ zeta_new(Istr-1,j)=zeta_new(Istr,j) ! gradient +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr,j) +# endif +# ifdef MASKING +!^ zeta_new(Istr-1,j)=zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif + END IF + END DO + END IF +! +! Western edge, explicit Chapman boundary condition. +! + ELSE IF (tl_LBC(iwest,isFsur,ng)%Chapman_explicit) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN + cff=dt2d*GRID(ng)%pm(Istr,j) + cff1=SQRT(g*(GRID(ng)%h(Istr,j)+ & + & zeta(Istr,j,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(Istr,j)+ & + & tl_zeta(Istr,j,know))/cff1 + Cx=cff*cff1 + tl_Cx=cff*tl_cff1 +!^ zeta_new(Istr-1,j)=(1.0_r8-Cx)*zeta(Istr-1,j,know)+ & +!^ & Cx*zeta(Istr,j,know) +!^ + tl_zeta_new(Istr-1,j)=(1.0_r8-Cx)*tl_zeta(Istr-1,j,know)+ & + & tl_Cx*(zeta(Istr-1,j,know)+ & + & zeta(Istr ,j,know))+ & + & Cx*tl_zeta(Istr,j,know) +# ifdef MASKING +!^ zeta_new(Istr-1,j)=zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif + END IF + END DO +! +! Western edge, implicit Chapman boundary condition. +! + ELSE IF (tl_LBC(iwest,isFsur,ng)%Chapman_implicit) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN + cff=dt2d*GRID(ng)%pm(Istr,j) + cff1=SQRT(g*(GRID(ng)%h(Istr,j)+ & + & zeta(Istr,j,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(Istr,j)+ & + & tl_zeta(Istr,j,know))/cff1 + Cx=cff*cff1 + tl_Cx=cff*tl_cff1 + cff2=1.0_r8/(1.0_r8+Cx) + tl_cff2=-cff2*cff2*tl_Cx +!^ zeta_new(Istr-1,j)=cff2*(zeta(Istr-1,j,know)+ & +!^ & Cx*zeta_new(Istr,j)) +!^ + tl_zeta_new(Istr-1,j)=tl_cff2*(zeta(Istr-1,j,know)+ & + & Cx*zeta_new(Istr,j))+ & + & cff2*(tl_zeta(Istr-1,j,know)+ & + & tl_Cx*zeta_new(Istr,j)+ & + & Cx*tl_zeta_new(Istr,j)) +# ifdef MASKING +!^ zeta_new(Istr-1,j)=zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif + END IF + END DO +! +! Western edge, clamped boundary condition. +! + ELSE IF (tl_LBC(iwest,isFsur,ng)%clamped) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN +!^ zeta_new(Istr-1,j)=BOUNDARY(ng)%zeta_west(j) +!^ +# ifdef ADJUST_BOUNDARY + IF (Lobc(iwest,isFsur,ng)) THEN + tl_zeta_new(Istr-1,j)=BOUNDARY(ng)%tl_zeta_west(j) + ELSE + tl_zeta_new(Istr-1,j)=0.0_r8 + END IF +# else + tl_zeta_new(Istr-1,j)=0.0_r8 +# endif +# ifdef MASKING +!^ zeta_new(Istr-1,j)=zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif + END IF + END DO +! +! Western edge, gradient boundary condition. +! + ELSE IF (tl_LBC(iwest,isFsur,ng)%gradient) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN +!^ zeta_new(Istr-1,j)=zeta_new(Istr,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr,j) +# ifdef MASKING +!^ zeta_new(Istr-1,j)=zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif + END IF + END DO +! +! Western edge, closed boundary condition. +! + ELSE IF (tl_LBC(iwest,isFsur,ng)%closed) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN +!^ zeta_new(Istr-1,j)=zeta_new(Istr,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr,j) +# ifdef MASKING +!^ zeta_new(Istr-1,j)=zeta_new(Istr-1,j)* & +!^ & GRID(ng)%rmask(Istr-1,j) +!^ + tl_zeta_new(Istr-1,j)=tl_zeta_new(Istr-1,j)* & + & GRID(ng)%rmask(Istr-1,j) +# endif + END IF + END DO + END IF + END IF +! +!----------------------------------------------------------------------- +! Lateral boundary conditions at the eastern edge. +!----------------------------------------------------------------------- +! + IF (DOMAIN(ng)%Eastern_Edge(tile)) THEN +! +! Eastern edge, implicit upstream radiation condition. +! (Not implemented since the TLM requires nonlinear celerity at every +! timestep. Using gradient instead). +! + IF (tl_LBC(ieast,isFsur,ng)%radiation) THEN + IF (iic(ng).ne.0) THEN +# if defined CELERITY_READ && defined FORWARD_READ + DO j=JstrV-1,Jend+1 +!^ grad(Iend+1,j)=zeta(Iend+1,j ,know)- & +!^ & zeta(Iend+1,j-1,know) +!^ + tl_grad(Iend+1,j)=0.0_r8 + END DO +# endif + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN +# if defined CELERITY_READ && defined FORWARD_READ + IF (tl_LBC(ieast,isFsur,ng)%nudging) THEN + IF (BOUNDARY(ng)%zeta_east_Cx(j).eq.0.0_r8) THEN + tau=FSobc_in(ieast) + ELSE + tau=FSobc_out(ieast) + END IF + tau=tau*dt2d + END IF + Cx=BOUNDARY(ng)%zeta_east_Cx(j) +# ifdef RADIATION_2D + Ce=BOUNDARY(ng)%zeta_east_Ce(j) +# else + Ce=0.0_r8 +# endif + cff=BOUNDARY(ng)%zeta_east_C2(j) + +!^ zeta_new(Iend+1,j)=(cff*zeta(Iend+1,j,know)+ & +!^ & Cx *zeta_new(Iend,j)- & +!^ & MAX(Ce,0.0_r8)*grad(Iend+1,j )- & +!^ & MIN(Ce,0.0_r8)*grad(Iend+1,j+1))/ & +!^ & (cff+Cx) +!^ + tl_zeta_new(Iend+1,j)=(cff*tl_zeta(Iend+1,j,know)+ & + & Cx *tl_zeta_new(Iend,j)- & + & MAX(Ce,0.0_r8)* & + & tl_grad(Iend+1,j )- & + & MIN(Ce,0.0_r8)* & + & tl_grad(Iend+1,j+1))/ & + & (cff+Cx) + + IF (tl_LBC(ieast,isFsur,ng)%nudging) THEN +!^ zeta_new(Iend+1,j)=zeta_new(Iend+1,j)+ & +!^ & tau*(BOUNDARY(ng)%zeta_east(j)- & +!^ & zeta(Iend+1,j,know)) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)- & + & tau*tl_zeta(Iend+1,j,know) + END IF +# else +!^ zeta_new(Iend+1,j)=zeta_new(Iend,j) ! gradient +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend,j) +# endif +# ifdef MASKING +!^ zeta_new(Iend+1,j)=zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif + END IF + END DO + END IF +! +! Eastern edge, explicit Chapman boundary condition. +! + ELSE IF (tl_LBC(ieast,isFsur,ng)%Chapman_explicit) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN + cff=dt2d*GRID(ng)%pm(Iend,j) + cff1=SQRT(g*(GRID(ng)%h(Iend,j)+ & + & zeta(Iend,j,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(Iend,j)+ & + & tl_zeta(Iend,j,know))/cff1 + Cx=cff*cff1 + tl_Cx=cff*tl_cff1 +!^ zeta_new(Iend+1,j)=(1.0_r8-Cx)*zeta(Iend+1,j,know)+ & +!^ & Cx*zeta(Iend,j,know) +!^ + tl_zeta_new(Iend+1,j)=(1.0_r8-Cx)*tl_zeta(Iend+1,j,know)+ & + & tl_Cx*(zeta(Iend+1,j,know)+ & + & zeta(Iend ,j,know))+ & + & Cx*tl_zeta(Iend,j,know) +# ifdef MASKING +!^ zeta_new(Iend+1,j)=zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif + END IF + END DO +! +! Eastern edge, implicit Chapman boundary condition. +! + ELSE IF (tl_LBC(ieast,isFsur,ng)%Chapman_implicit) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN + cff=dt2d*GRID(ng)%pm(Iend,j) + cff1=SQRT(g*(GRID(ng)%h(Iend,j)+ & + & zeta(Iend,j,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(Iend,j)+ & + & tl_zeta(Iend,j,know))/cff1 + Cx=cff*cff1 + tl_Cx=cff*tl_cff1 + cff2=1.0_r8/(1.0_r8+Cx) + tl_cff2=-cff2*cff2*tl_Cx +!^ zeta_new(Iend+1,j)=cff2*(zeta(Iend+1,j,know)+ & +!^ & Cx*zeta_new(Iend,j)) +!^ + tl_zeta_new(Iend+1,j)=tl_cff2*(zeta(Iend+1,j,know)+ & + & Cx*zeta_new(Iend,j))+ & + & cff2*(tl_zeta(Iend+1,j,know)+ & + & tl_Cx*zeta_new(Iend,j)+ & + & Cx*tl_zeta_new(Iend,j)) +# ifdef MASKING +!^ zeta_new(Iend+1,j)=zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif + END IF + END DO +! +! Eastern edge, clamped boundary condition. +! + ELSE IF (tl_LBC(ieast,isFsur,ng)%clamped) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN +!^ zeta_new(Iend+1,j)=BOUNDARY(ng)%zeta_east(j) +!^ +# ifdef ADJUST_BOUNDARY + IF (Lobc(ieast,isFsur,ng)) THEN + tl_zeta_new(Iend+1,j)=BOUNDARY(ng)%tl_zeta_east(j) + ELSE + tl_zeta_new(Iend+1,j)=0.0_r8 + END IF +# else + tl_zeta_new(Iend+1,j)=0.0_r8 +# endif +# ifdef MASKING +!^ zeta_new(Iend+1,j)=zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif + END IF + END DO +! +! Eastern edge, gradient boundary condition. +! + ELSE IF (tl_LBC(ieast,isFsur,ng)%gradient) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN +!^ zeta_new(Iend+1,j)=zeta_new(Iend,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend,j) +# ifdef MASKING +!^ zeta_new(Iend+1,j)=zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif + END IF + END DO +! +! Eastern edge, closed boundary condition. +! + ELSE IF (tl_LBC(ieast,isFsur,ng)%closed) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN +!^ zeta_new(Iend+1,j)=zeta_new(Iend,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend,j) +# ifdef MASKING +!^ zeta_new(Iend+1,j)=zeta_new(Iend+1,j)* & +!^ & GRID(ng)%rmask(Iend+1,j) +!^ + tl_zeta_new(Iend+1,j)=tl_zeta_new(Iend+1,j)* & + & GRID(ng)%rmask(Iend+1,j) +# endif + END IF + END DO + END IF + END IF +! +!----------------------------------------------------------------------- +! Lateral boundary conditions at the southern edge. +!----------------------------------------------------------------------- +! + IF (DOMAIN(ng)%Southern_Edge(tile)) THEN +! +! Southern edge, implicit upstream radiation condition. +! (Not implemented since the TLM requires nonlinear celerity at every +! timestep. Using gradient instead). +! + IF (tl_LBC(isouth,isFsur,ng)%radiation) THEN + IF (iic(ng).ne.0) THEN +# if defined CELERITY_READ && defined FORWARD_READ + DO i=IstrU-1,Iend+1 +!^ grad(i,Jstr)=zeta(i ,Jstr,know)- & +!^ & zeta(i-1,Jstr,know) +!^ + tl_grad(i,Jstr)=0.0_r8 + END DO +# endif + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN +# if defined CELERITY_READ && defined FORWARD_READ + IF (tl_LBC(isouth,isFsur,ng)%nudging) THEN + IF (BOUNDARY(ng)%zeta_south_Ce(i).eq.0.0_r8) THEN + tau=FSobc_in(ng,isouth) + ELSE + tau=FSobc_out(ng,isouth) + END IF + tau=tau*dt2d + END IF +# ifdef RADIATION_2D + Cx=BOUNDARY(ng)%zeta_south_Cx(i) +# else + Cx=0.0_r8 +# endif + Ce=BOUNDARY(ng)%zeta_south_Ce(i) + cff=BOUNDARY(ng)%zeta_south_C2(i) + +!^ zeta_new(i,Jstr-1)=(cff*zeta(i,Jstr-1,know)+ & +!^ & Ce *zeta_new(i,Jstr)- & +!^ & MAX(Cx,0.0_r8)*grad(i ,Jstr)- & +!^ & MIN(Cx,0.0_r8)*grad(i+1,Jstr))/ & +!^ & (cff+Ce) +!^ + tl_zeta_new(i,Jstr-1)=(cff*tl_zeta(i,Jstr-1,know)+ & + & Ce *tl_zeta_new(i,Jstr)- & + & MAX(Cx,0.0_r8)* & + & tl_grad(i ,Jstr-1)- & + & MIN(Cx,0.0_r8)* & + & tl_grad(i+1,Jstr-1))/ & + & (cff+Ce) + + IF (tl_LBC(isouth,isFsur,ng)%nudging) THEN +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr-1)+ & +!^ & tau*(BOUNDARY(ng)%zeta_south(i)- & +!^ & zeta(i,Jstr-1,know)) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)- & + & tau*tl_zeta(i,Jstr-1,know) + END IF +# else +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr) ! gradient +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr) +# endif +# ifdef MASKING +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif + END IF + END DO + END IF +! +! Southern edge, explicit Chapman boundary condition. +! + ELSE IF (tl_LBC(isouth,isFsur,ng)%Chapman_explicit) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN + cff=dt2d*GRID(ng)%pn(i,Jstr) + cff1=SQRT(g*(GRID(ng)%h(i,Jstr)+ & + & zeta(i,Jstr,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(i,Jstr)+ & + & tl_zeta(i,Jstr,know))/cff1 + Ce=cff*cff1 + tl_Ce=cff*tl_cff1 +!^ zeta_new(i,Jstr-1)=(1.0_r8-Ce)*zeta(i,Jstr-1,know)+ & +!^ & Ce*zeta(i,Jstr,know) +!^ + tl_zeta_new(i,Jstr-1)=(1.0_r8-Ce)*tl_zeta(i,Jstr-1,know)+ & + & tl_Ce*(zeta(i,Jstr-1,know)+ & + & zeta(i,Jstr ,know))+ & + & Ce*tl_zeta(i,Jstr,know) +# ifdef MASKING +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif + END IF + END DO +! +! Southern edge, implicit Chapman boundary condition. +! + ELSE IF (tl_LBC(isouth,isFsur,ng)%Chapman_implicit) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN + cff=dt2d*GRID(ng)%pn(i,Jstr) + cff1=SQRT(g*(GRID(ng)%h(i,Jstr)+ & + & zeta(i,Jstr,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(i,Jstr)+ & + & tl_zeta(i,Jstr,know))/cff1 + Ce=cff*cff1 + tl_Ce=cff*tl_cff1 + cff2=1.0_r8/(1.0_r8+Ce) + tl_cff2=-cff2*cff2*tl_Ce +!^ zeta_new(i,Jstr-1)=cff2*(zeta(i,Jstr-1,know)+ & +!^ & Ce*zeta_new(i,Jstr)) +!^ + tl_zeta_new(i,Jstr-1)=tl_cff2*(zeta(i,Jstr-1,know)+ & + & Ce*zeta_new(i,Jstr))+ & + & cff2*(tl_zeta(i,Jstr-1,know)+ & + & tl_Ce*zeta_new(i,Jstr)+ & + & Ce*tl_zeta_new(i,Jstr)) +# ifdef MASKING +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif + END IF + END DO +! +! Southern edge, clamped boundary condition. +! + ELSE IF (tl_LBC(isouth,isFsur,ng)%clamped) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN +!^ zeta_new(i,Jstr-1)=BOUNDARY(ng)%zeta_south(i) +!^ +# ifdef ADJUST_BOUNDARY + IF (Lobc(isouth,isFsur,ng)) THEN + tl_zeta_new(i,Jstr-1)=BOUNDARY(ng)%tl_zeta_south(i) + ELSE + tl_zeta_new(i,Jstr-1)=0.0_r8 + END IF +# else + tl_zeta_new(i,Jstr-1)=0.0_r8 +# endif +# ifdef MASKING +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif + END IF + END DO +! +! Southern edge, gradient boundary condition. +! + ELSE IF (tl_LBC(isouth,isFsur,ng)%gradient) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr) +# ifdef MASKING +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif + END IF + END DO +! +! Southern edge, closed boundary condition. +! + ELSE IF (tl_LBC(isouth,isFsur,ng)%closed) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr) +# ifdef MASKING +!^ zeta_new(i,Jstr-1)=zeta_new(i,Jstr-1)* & +!^ & GRID(ng)%rmask(i,Jstr-1) +!^ + tl_zeta_new(i,Jstr-1)=tl_zeta_new(i,Jstr-1)* & + & GRID(ng)%rmask(i,Jstr-1) +# endif + END IF + END DO + END IF + END IF +! +!----------------------------------------------------------------------- +! Lateral boundary conditions at the northern edge. +!----------------------------------------------------------------------- +! + IF (DOMAIN(ng)%Northern_Edge(tile)) THEN +! +! Northern edge, implicit upstream radiation condition. +! (Not implemented since the TLM requires nonlinear celerity at every +! timestep. Using gradient instead). +! + IF (tl_LBC(inorth,isFsur,ng)%radiation) THEN + IF (iic(ng).ne.0) THEN +# if defined CELERITY_READ && defined FORWARD_READ + DO i=IstrU-1,Iend+1 +!^ grad(i,Jend+1)=zeta(i ,Jend+1,know)- & +!^ & zeta(i-1,Jend+1,know) +!^ + tl_grad(i,Jend+1)=0.0_r8 + END DO +# endif + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN +# if defined CELERITY_READ && defined FORWARD_READ + IF (tl_LBC(inorth,isFsur,ng)%nudging) THEN + IF (BOUNDARY(ng)%zeta_north_Ce(i).eq.0.0_r8) THEN + tau=FSobc_in(ng,inorth) + ELSE + tau=FSobc_out(ng,inorth) + END IF + tau=tau*dt2d + END IF +# ifdef RADIATION_2D + Cx=BOUNDARY(ng)%zeta_north_Cx(i) +# else + Cx=0.0_r8 +# endif + Ce=BOUNDARY(ng)%zeta_north_Ce(i) + cff=BOUNDARY(ng)%zeta_north_C2(i) + +!^ zeta_new(i,Jend+1)=(cff*zeta(i,Jend+1,know)+ & +!^ & Ce *zeta_new(i,Jend)- & +!^ & MAX(Cx,0.0_r8)*grad(i ,Jend+1)- & +!^ & MIN(Cx,0.0_r8)*grad(i+1,Jend+1))/ & +!^ & (cff+Ce) +!^ + tl_zeta_new(i,Jend+1)=(cff*tl_zeta(i,Jend+1,know)+ & + & Ce *tl_zeta_new(i,Jend)- & + & MAX(Cx,0.0_r8)* & + & tl_grad(i ,Jend+1)- & + & MIN(Cx,0.0_r8)* & + & tl_grad(i+1,Jend+1))/ & + & (cff+Ce) + + IF (tl_LBC(inorth,isFsur,ng)%nudging) THEN +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend+1)+ & +!^ & tau*(BOUNDARY(ng)%zeta_north(i)- & +!^ & zeta(i,Jend+1,know)) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)- & + & tau*tl_zeta(i,Jend+1,know) + END IF +# else +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend) ! gradient +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend) +# endif +# ifdef MASKING +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif + END IF + END DO + END IF +! +! Northern edge, explicit Chapman boundary condition. +! + ELSE IF (tl_LBC(inorth,isFsur,ng)%Chapman_explicit) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN + cff=dt2d*GRID(ng)%pn(i,Jend) + cff1=SQRT(g*(GRID(ng)%h(i,Jend)+ & + & zeta(i,Jend,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(i,Jend)+ & + & tl_zeta(i,Jend,know))/cff1 + Ce=cff*cff1 + tl_Ce=cff*tl_cff1 +!^ zeta_new(i,Jend+1)=(1.0_r8-Ce)*zeta(i,Jend+1,know)+ & +!^ & Ce*zeta(i,Jend,know) +!^ + tl_zeta_new(i,Jend+1)=(1.0_r8-Ce)*tl_zeta(i,Jend+1,know)+ & + & tl_Ce*(zeta(i,Jend+1,know)+ & + & zeta(i,Jend ,know))+ & + & Ce*tl_zeta(i,Jend,know) +# ifdef MASKING +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif + END IF + END DO +! +! Northern edge, implicit Chapman boundary condition. +! + ELSE IF (tl_LBC(inorth,isFsur,ng)%Chapman_implicit) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN + cff=dt2d*GRID(ng)%pn(i,Jend) + cff1=SQRT(g*(GRID(ng)%h(i,Jend)+ & + & zeta(i,Jend,know))) + tl_cff1=0.5_r8*g*(GRID(ng)%tl_h(i,Jend)+ & + & tl_zeta(i,Jend,know))/cff1 + Ce=cff*cff1 + tl_Ce=cff*tl_cff1 + cff2=1.0_r8/(1.0_r8+Ce) + tl_cff2=-cff2*cff2*tl_Ce +!^ zeta_new(i,Jend+1)=cff2*(zeta(i,Jend+1,know)+ & +!^ & Ce*zeta_new(i,Jend)) +!^ + tl_zeta_new(i,Jend+1)=tl_cff2*(zeta(i,Jend+1,know)+ & + & Ce*zeta_new(i,Jend))+ & + & cff2*(tl_zeta(i,Jend+1,know)+ & + & tl_Ce*zeta_new(i,Jend)+ & + & Ce*tl_zeta_new(i,Jend)) +# ifdef MASKING +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif + END IF + END DO +! +! Northern edge, clamped boundary condition. +! + ELSE IF (tl_LBC(inorth,isFsur,ng)%clamped) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN +!^ zeta_new(i,Jend+1)=BOUNDARY(ng)%zeta_north(i) +!^ +# ifdef ADJUST_BOUNDARY + IF (Lobc(inorth,isFsur,ng)) THEN + tl_zeta_new(i,Jend+1)=BOUNDARY(ng)%tl_zeta_north(i) + ELSE + tl_zeta_new(i,Jend+1)=0.0_r8 + END IF +# else + tl_zeta_new(i,Jend+1)=0.0_r8 +# endif +# ifdef MASKING +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif + END IF + END DO +! +! Northern edge, gradient boundary condition. +! + ELSE IF (tl_LBC(inorth,isFsur,ng)%gradient) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend) +# ifdef MASKING +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif + END IF + END DO +! +! Northern edge, closed boundary condition. +! + ELSE IF (tl_LBC(inorth,isFsur,ng)%closed) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend) +# ifdef MASKING +!^ zeta_new(i,Jend+1)=zeta_new(i,Jend+1)* & +!^ & GRID(ng)%rmask(i,Jend+1) +!^ + tl_zeta_new(i,Jend+1)=tl_zeta_new(i,Jend+1)* & + & GRID(ng)%rmask(i,Jend+1) +# endif + END IF + END DO + END IF + END IF +! +!----------------------------------------------------------------------- +! Boundary corners. +!----------------------------------------------------------------------- +! + IF (.not.(EWperiodic(ng).or.NSperiodic(ng))) THEN + IF (DOMAIN(ng)%SouthWest_Corner(tile)) THEN + IF (LBC_apply(ng)%south(Istr-1).and. & + & LBC_apply(ng)%west (Jstr-1)) THEN +!^ zeta_new(Istr-1,Jstr-1)=0.5_r8*(zeta_new(Istr ,Jstr-1)+ & +!^ & zeta_new(Istr-1,Jstr )) +!^ + tl_zeta_new(Istr-1,Jstr-1)=0.5_r8* & + & (tl_zeta_new(Istr ,Jstr-1)+ & + & tl_zeta_new(Istr-1,Jstr )) + END IF + END IF + IF (DOMAIN(ng)%SouthEast_Corner(tile)) THEN + IF (LBC_apply(ng)%south(Iend+1).and. & + & LBC_apply(ng)%east (Jstr-1)) THEN +!^ zeta_new(Iend+1,Jstr-1)=0.5_r8*(zeta_new(Iend ,Jstr-1)+ & +!^ & zeta_new(Iend+1,Jstr )) +!^ + tl_zeta_new(Iend+1,Jstr-1)=0.5_r8* & + & (tl_zeta_new(Iend ,Jstr-1)+ & + & tl_zeta_new(Iend+1,Jstr )) + END IF + END IF + IF (DOMAIN(ng)%NorthWest_Corner(tile)) THEN + IF (LBC_apply(ng)%north(Istr-1).and. & + & LBC_apply(ng)%west (Jend+1)) THEN +!^ zeta_new(Istr-1,Jend+1)=0.5_r8*(zeta_new(Istr-1,Jend )+ & +!^ & zeta_new(Istr ,Jend+1)) +!^ + tl_zeta_new(Istr-1,Jend+1)=0.5_r8* & + & (tl_zeta_new(Istr-1,Jend )+ & + & tl_zeta_new(Istr ,Jend+1)) + END IF + END IF + IF (DOMAIN(ng)%NorthEast_Corner(tile)) THEN + IF (LBC_apply(ng)%north(Iend+1).and. & + & LBC_apply(ng)%east (Jend+1)) THEN +!^ zeta_new(Iend+1,Jend+1)=0.5_r8*(zeta_new(Iend+1,Jend )+ & +!^ & zeta_new(Iend ,Jend+1)) +!^ + tl_zeta_new(Iend+1,Jend+1)=0.5_r8* & + & (tl_zeta_new(Iend+1,Jend )+ & + & tl_zeta_new(Iend ,Jend+1)) + END IF + END IF + END IF + +# if defined WET_DRY +! +!----------------------------------------------------------------------- +! Ensure that water level on boundary cells is above bed elevation. +!----------------------------------------------------------------------- +! + cff=Dcrit(ng)-eps + IF (.not.EWperiodic(ng)) THEN + IF (DOMAIN(ng)%Western_Edge(tile)) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%west(j)) THEN + IF (zeta_new(Istr-1,j).le. & + & (Dcrit(ng)-GRID(ng)%h(Istr-1,j))) THEN +!^ zeta_new(Istr-1,j)=cff-GRID(ng)%h(Istr-1,j) +!^ + tl_zeta_new(Istr-1,j)=-GRID(ng)%tl_h(Istr-1,j) + END IF + END IF + END DO + END IF + IF (DOMAIN(ng)%Eastern_Edge(tile)) THEN + DO j=JstrV-1,Jend + IF (LBC_apply(ng)%east(j)) THEN + IF (zeta_new(Iend+1,j).le. & + & (Dcrit(ng)-GRID(ng)%h(Iend+1,j))) THEN +!^ zeta_new(Iend+1,j)=cff-GRID(ng)%h(Iend+1,j) +!^ + tl_zeta_new(Iend+1,j)=-GRID(ng)%tl_h(Iend+1,j) + END IF + END IF + END DO + END IF + END IF +! + IF (.not.NSperiodic(ng)) THEN + IF (DOMAIN(ng)%Southern_Edge(tile)) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%south(i)) THEN + IF (zeta_new(i,Jstr-1).le. & + & (Dcrit(ng)-GRID(ng)%h(i,Jstr-1))) THEN +!^ zeta_new(i,Jstr-1)=cff-GRID(ng)%h(i,Jstr-1) +!^ + tl_zeta_new(i,Jstr-1)=-GRID(ng)%tl_h(i,Jstr-1) + END IF + END IF + END DO + END IF + IF (DOMAIN(ng)%Northern_Edge(tile)) THEN + DO i=IstrU-1,Iend + IF (LBC_apply(ng)%north(i)) THEN + IF (zeta_new(i,Jend+1).le. & + & (Dcrit(ng)-GRID(ng)%h(i,Jend+1))) THEN +!^ zeta_new(i,Jend+1)=cff-GRID(ng)%h(i,Jend+1) +!^ + tl_zeta_new(i,Jend+1)=-GRID(ng)%tl_h(i,Jend+1) + END IF + END IF + END DO + END IF + END IF +! + IF (.not.(EWperiodic(ng).or.NSperiodic(ng))) THEN + IF (DOMAIN(ng)%SouthWest_Corner(tile)) THEN + IF (LBC_apply(ng)%south(Istr-1).and. & + & LBC_apply(ng)%west (Jstr-1)) THEN + IF (zeta_new(Istr-1,Jstr-1).le. & + & (Dcrit(ng)-GRID(ng)%h(Istr-1,Jstr-1))) THEN +!^ zeta_new(Istr-1,Jstr-1)=cff-GRID(ng)%h(Istr-1,Jstr-1) +!^ + tl_zeta_new(Istr-1,Jstr-1)=-GRID(ng)%tl_h(Istr-1,Jstr-1) + END IF + END IF + END IF + IF (DOMAIN(ng)%SouthEast_Corner(tile)) THEN + IF (LBC_apply(ng)%south(Iend+1).and. & + & LBC_apply(ng)%east (Jstr-1)) THEN + IF (zeta_new(Iend+1,Jstr-1).le. & + & (Dcrit(ng)-GRID(ng)%h(Iend+1,Jstr-1))) THEN +!^ zeta_new(Iend+1,Jstr-1)=cff-GRID(ng)%h(Iend+1,Jstr-1) +!^ + tl_zeta_new(Iend+1,Jstr-1)=-GRID(ng)%tl_h(Iend+1,Jstr-1) + END IF + END IF + END IF + IF (DOMAIN(ng)%NorthWest_Corner(tile)) THEN + IF (LBC_apply(ng)%north(Istr-1).and. & + & LBC_apply(ng)%west (Jend+1)) THEN + IF (zeta_new(Istr-1,Jend+1).le. & + & (Dcrit(ng)-GRID(ng)%h(Istr-1,Jend+1))) THEN +!^ zeta_new(Istr-1,Jend+1)=cff-GRID(ng)%h(Istr-1,Jend+1) +!^ + tl_zeta_new(Istr-1,Jend+1)=-GRID(ng)%tl_h(Istr-1,Jend+1) + END IF + END IF + END IF + IF (DOMAIN(ng)%NorthEast_Corner(tile)) THEN + IF (LBC_apply(ng)%north(Iend+1).and. & + & LBC_apply(ng)%east (Jend+1)) THEN + IF (zeta_new(Iend+1,Jend+1).le. & + & (Dcrit(ng)-GRID(ng)%h(Iend+1,Jend+1))) THEN +!^ zeta_new(Iend+1,Jend+1)=cff-GRID(ng)%h(Iend+1,Jend+1) +!^ + tl_zeta_new(Iend+1,Jend+1)=-GRID(ng)%tl_h(Iend+1,Jend+1) + END IF + END IF + END IF + END IF +# endif +! + RETURN + END SUBROUTINE tl_zetabc_local +# endif #endif END MODULE tl_zetabc_mod diff --git a/ROMS/Utility/get_state.F b/ROMS/Utility/get_state.F index 0ec0e7aef..5b9f6faae 100644 --- a/ROMS/Utility/get_state.F +++ b/ROMS/Utility/get_state.F @@ -693,6 +693,8 @@ SUBROUTINE get_state_nf90 (ng, model, msg, S, IniRec, Tindex, & END IF END IF END IF + +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) ! ! Read in nonlinear RHS of free-surface. ! @@ -706,15 +708,15 @@ SUBROUTINE get_state_nf90 (ng, model, msg, S, IniRec, Tindex, & & InpRec, gtype, Vsize, & & LBi, UBi, LBj, UBj, 1, 2, & & Fscl, Fmin, Fmax, & -# ifdef MASKING +# ifdef MASKING & GRID(ng) % rmask, & -# endif -# ifdef CHECKSUM +# endif +# ifdef CHECKSUM & OCEAN(ng) % rzeta, & & checksum = Fhash) -# else +# else & OCEAN(ng) % rzeta) -# endif +# endif IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN IF (Master) THEN WRITE (stdout,60) string, TRIM(Vname(1,idRzet)), & @@ -725,12 +727,12 @@ SUBROUTINE get_state_nf90 (ng, model, msg, S, IniRec, Tindex, & RETURN ELSE IF (Master) THEN -# ifdef CHECKSUM +# ifdef CHECKSUM WRITE (stdout,70) TRIM(Vname(2,idRzet)), Fmin, Fmax, & & Fhash -# else +# else WRITE (stdout,70) TRIM(Vname(2,idRzet)), Fmin, Fmax -# endif +# endif END IF END IF @@ -746,6 +748,7 @@ SUBROUTINE get_state_nf90 (ng, model, msg, S, IniRec, Tindex, & END IF END IF END IF +# endif ! ! Read in nonlinear 2D U-momentum component (m/s). ! @@ -820,6 +823,8 @@ SUBROUTINE get_state_nf90 (ng, model, msg, S, IniRec, Tindex, & END IF END IF END IF + +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) ! ! Read in nonlinear RHS of 2D U-momentum component. ! @@ -833,15 +838,15 @@ SUBROUTINE get_state_nf90 (ng, model, msg, S, IniRec, Tindex, & & InpRec, gtype, Vsize, & & LBi, UBi, LBj, UBj, 1, 2, & & Fscl, Fmin, Fmax, & -# ifdef MASKING +# ifdef MASKING & GRID(ng) % umask, & -# endif -# ifdef CHECKSUM +# endif +# ifdef CHECKSUM & OCEAN(ng) % rubar, & & checksum = Fhash) -# else +# else & OCEAN(ng) % rubar) -# endif +# endif IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN IF (Master) THEN WRITE (stdout,60) string, TRIM(Vname(1,idRu2d)), & @@ -852,12 +857,12 @@ SUBROUTINE get_state_nf90 (ng, model, msg, S, IniRec, Tindex, & RETURN ELSE IF (Master) THEN -# ifdef CHECKSUM +# ifdef CHECKSUM WRITE (stdout,70) TRIM(Vname(2,idRu2d)), Fmin, Fmax, & & Fhash -# else +# else WRITE (stdout,70) TRIM(Vname(2,idRu2d)), Fmin, Fmax -# endif +# endif END IF END IF @@ -873,6 +878,7 @@ SUBROUTINE get_state_nf90 (ng, model, msg, S, IniRec, Tindex, & END IF END IF END IF +# endif ! ! Read in nonlinear 2D V-momentum component (m/s). ! @@ -947,6 +953,8 @@ SUBROUTINE get_state_nf90 (ng, model, msg, S, IniRec, Tindex, & END IF END IF END IF + +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) ! ! Read in nonlinear RHS 2D V-momentum component. ! @@ -960,15 +968,15 @@ SUBROUTINE get_state_nf90 (ng, model, msg, S, IniRec, Tindex, & & InpRec, gtype, Vsize, & & LBi, UBi, LBj, UBj, 1, 2, & & Fscl, Fmin, Fmax, & -# ifdef MASKING +# ifdef MASKING & GRID(ng) % vmask, & -# endif -# ifdef CHECKSUM +# endif +# ifdef CHECKSUM & OCEAN(ng) % rvbar, & & checksum = Fhash) -# else +# else & OCEAN(ng) % rvbar) -# endif +# endif IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN IF (Master) THEN WRITE (stdout,60) string, TRIM(Vname(1,idRv2d)), & @@ -979,12 +987,12 @@ SUBROUTINE get_state_nf90 (ng, model, msg, S, IniRec, Tindex, & RETURN ELSE IF (Master) THEN -# ifdef CHECKSUM +# ifdef CHECKSUM WRITE (stdout,70) TRIM(Vname(2,idRv2d)), Fmin, Fmax, & & Fhash -# else +# else WRITE (stdout,70) TRIM(Vname(2,idRv2d)), Fmin, Fmax -# endif +# endif END IF END IF @@ -1000,6 +1008,7 @@ SUBROUTINE get_state_nf90 (ng, model, msg, S, IniRec, Tindex, & END IF END IF END IF +# endif # ifdef SOLVE3D ! @@ -8482,6 +8491,8 @@ SUBROUTINE get_state_pio (ng, model, msg, S, IniRec, Tindex, & END IF END IF END IF + +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) ! ! Read in nonlinear RHS of free-surface. ! @@ -8504,15 +8515,15 @@ SUBROUTINE get_state_pio (ng, model, msg, S, IniRec, Tindex, & & InpRec, ioDesc, Vsize, & & LBi, UBi, LBj, UBj, 1, 2, & & Fscl, Fmin, Fmax, & -# ifdef MASKING +# ifdef MASKING & GRID(ng) % rmask, & -# endif -# ifdef CHECKSUM +# endif +# ifdef CHECKSUM & OCEAN(ng) % rzeta, & & checksum = Fhash) -# else +# else & OCEAN(ng) % rzeta) -# endif +# endif IF (FoundError(status, PIO_noerr, __LINE__, MyFile)) THEN IF (Master) THEN WRITE (stdout,60) string, TRIM(Vname(1,idRzet)), & @@ -8523,12 +8534,12 @@ SUBROUTINE get_state_pio (ng, model, msg, S, IniRec, Tindex, & RETURN ELSE IF (Master) THEN -# ifdef CHECKSUM +# ifdef CHECKSUM WRITE (stdout,70) TRIM(Vname(2,idRzet)), Fmin, Fmax, & & Fhash -# else +# else WRITE (stdout,70) TRIM(Vname(2,idRzet)), Fmin, Fmax -# endif +# endif END IF END IF @@ -8544,6 +8555,7 @@ SUBROUTINE get_state_pio (ng, model, msg, S, IniRec, Tindex, & END IF END IF END IF +# endif ! ! Read in nonlinear 2D U-momentum component (m/s). ! @@ -8631,6 +8643,8 @@ SUBROUTINE get_state_pio (ng, model, msg, S, IniRec, Tindex, & END IF END IF END IF + +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) ! ! Read in nonlinear RHS of 2D U-momentum component. ! @@ -8653,15 +8667,15 @@ SUBROUTINE get_state_pio (ng, model, msg, S, IniRec, Tindex, & & InpRec, ioDesc, Vsize, & & LBi, UBi, LBj, UBj, 1, 2, & & Fscl, Fmin, Fmax, & -# ifdef MASKING +# ifdef MASKING & GRID(ng) % umask, & -# endif -# ifdef CHECKSUM +# endif +# ifdef CHECKSUM & OCEAN(ng) % rubar, & & checksum = Fhash) -# else +# else & OCEAN(ng) % rubar) -# endif +# endif IF (FoundError(status, PIO_noerr, __LINE__, MyFile)) THEN IF (Master) THEN WRITE (stdout,60) string, TRIM(Vname(1,idRu2d)), & @@ -8672,12 +8686,12 @@ SUBROUTINE get_state_pio (ng, model, msg, S, IniRec, Tindex, & RETURN ELSE IF (Master) THEN -# ifdef CHECKSUM +# ifdef CHECKSUM WRITE (stdout,70) TRIM(Vname(2,idRu2d)), Fmin, Fmax, & & Fhash -# else +# else WRITE (stdout,70) TRIM(Vname(2,idRu2d)), Fmin, Fmax -# endif +# endif END IF END IF @@ -8693,6 +8707,7 @@ SUBROUTINE get_state_pio (ng, model, msg, S, IniRec, Tindex, & END IF END IF END IF +# endif ! ! Read in nonlinear 2D V-momentum component (m/s). ! @@ -8781,6 +8796,8 @@ SUBROUTINE get_state_pio (ng, model, msg, S, IniRec, Tindex, & END IF END IF END IF + +# if !(defined STEP2D_FB_AB3_AM4 || defined STEP2D_FB_LF_AM3) ! ! Read in nonlinear RHS 2D V-momentum component. ! @@ -8803,15 +8820,15 @@ SUBROUTINE get_state_pio (ng, model, msg, S, IniRec, Tindex, & & InpRec, ioDesc, Vsize, & & LBi, UBi, LBj, UBj, 1, 2, & & Fscl, Fmin, Fmax, & -# ifdef MASKING +# ifdef MASKING & GRID(ng) % vmask, & -# endif -# ifdef CHECKSUM +# endif +# ifdef CHECKSUM & OCEAN(ng) % rvbar, & & checksum = Fhash) -# else +# else & OCEAN(ng) % rvbar) -# endif +# endif IF (FoundError(status, PIO_noerr, __LINE__, MyFile)) THEN IF (Master) THEN WRITE (stdout,60) string, TRIM(Vname(1,idRv2d)), & @@ -8822,12 +8839,12 @@ SUBROUTINE get_state_pio (ng, model, msg, S, IniRec, Tindex, & RETURN ELSE IF (Master) THEN -# ifdef CHECKSUM +# ifdef CHECKSUM WRITE (stdout,70) TRIM(Vname(2,idRv2d)), Fmin, Fmax, & & Fhash -# else +# else WRITE (stdout,70) TRIM(Vname(2,idRv2d)), Fmin, Fmax -# endif +# endif END IF END IF @@ -8843,6 +8860,7 @@ SUBROUTINE get_state_pio (ng, model, msg, S, IniRec, Tindex, & END IF END IF END IF +# endif # ifdef SOLVE3D ! diff --git a/ROMS/Utility/set_weights.F b/ROMS/Utility/set_weights.F index 70dbeb182..9c57d3525 100644 --- a/ROMS/Utility/set_weights.F +++ b/ROMS/Utility/set_weights.F @@ -74,7 +74,8 @@ SUBROUTINE set_weights (ng) ! iteratively adjust "scale" to place the centroid exactly at ! "ndtfast". ! - gamma=Fgamma*MAX(0.0_dp, 1.0_dp-10.0_dp/REAL(ndtfast(ng),dp)) +!! gamma=Fgamma*MAX(0.0_dp, 1.0_dp-10.0_dp/REAL(ndtfast(ng),dp)) + gamma=0.284_dp*(1.0_dp-2.8_dp/(REAL(ndtfast(ng),dp))) DO iter=1,16 nfast(ng)=0 DO i=1,2*ndtfast(ng)