i4dvar.F

Go to the documentation of this file.

#include "cppdefs.h"
      MODULE i4dvar_mod
 
#ifdef I4DVAR
!
!git $Id$
!================================================== Hernan G. Arango ===
!  Copyright (c) 2002-2025 The ROMS Group            Andrew M. Moore   !
!    Licensed under a MIT/X style license                              !
!    See License_ROMS.md                                               !
!=======================================================================
!                                                                      !
!  This module splits the I4D-Var data assimilation algorithm into     !
!  its logical components routines.                                    !
!                                                                      !
!    background_initialize:                                            !
!                                                                      !
!      Initializes the nonlinear model kernel. It is separated from    !
!      the 'background' phase to allow ESM coupling.                   !
!                                                                      !
!    background:                                                       !
!                                                                      !
!      Timesteps the nonlinear model to compute the basic state Xb(t)  !
!      used to linearize the tangent linear and adjoint models. It     !
!      interpolates the nonlinear model trajectory to the observations !
!      locations.                                                      !
!                                                                      !
!    increment:                                                        !
!                                                                      !
!      Minimizes of the 4D-Var cost function over Ninner inner loops   !
!      iterations to compute the data assimilation increment, dXa.     !
!                                                                      !
!    analysis:                                                         !
!                                                                      !
!      Computes the nonlinear model new initial conditions by adding   !
!      the 4D-Var data assimilation increment to the background        !
!      initial state, Xa = Xb(t=0) + dXa. Then, writes it into NLM     !
!      initial conditions NetCDF INI(ng)%name (record Lini).           !
!                                                                      !
!    posterior_analysis_initialize:                                    !
!                                                                      !
!      Initializes the nonlinear model with the 4D-Var analysis, Xa.   !
!      It is separated from 'posterior_analysis' phase to allow ESM    !
!      coupling.                                                       !
!                                                                      !
!    posterior_analysis:                                               !
!                                                                      !
!      Timesteps the nonlinear model to compute the posterior analysis !
!      state. It interpolates solution at observation locations        !
!                                                                      !
!    prior_error:                                                      !
!                                                                      !
!       Processes the prior background error covariance and its        !
!       normalization coefficients.                                    !
!                                                                      !
!                                                                      !
!  References:                                                         !
!                                                                      !
!    Moore, A.M., H.G. Arango, G. Broquet, B.S. Powell, A.T. Weaver,   !
!      and J. Zavala-Garay, 2011: The Regional Ocean Modeling System   !
!      (ROMS)  4-dimensional variational data assimilations systems,   !
!      Part I - System overview and formulation, Prog. Oceanogr., 91,  !
!      34-49, doi:10.1016/j.pocean.2011.05.004.                        !
!                                                                      !
!    Moore, A.M., H.G. Arango, G. Broquet, C. Edward, M. Veneziani,    !
!      B. Powell, D. Foley, J.D. Doyle, D. Costa, and P. Robinson,     !
!      2011: The Regional Ocean Modeling System (ROMS) 4-dimensional   !
!      variational data assimilations systems, Part II - Performance   !
!      and application to the California Current System, Prog.         !
!      Oceanogr., 91, 50-73, doi:10.1016/j.pocean.2011.05.003.         !
!                                                                      !
!=======================================================================
!
      USE mod_kinds
      USE mod_param
      USE mod_parallel
      USE mod_fourdvar
      USE mod_iounits
      USE mod_ncparam
      USE mod_netcdf
# if defined PIO_LIB && defined DISTRIBUTE
      USE mod_pio_netcdf
# endif
      USE mod_scalars
      USE mod_stepping
!
# ifdef ADJUST_BOUNDARY
      USE mod_boundary,       ONLY : initialize_boundary
# endif
# if defined ADJUST_STFLUX || defined ADJUST_WSTRESS
      USE mod_forces,         ONLY : initialize_forces
# endif
      USE mod_mixing,         ONLY : initialize_mixing
      USE mod_ocean,          ONLY : initialize_ocean
!
# ifdef BALANCE_OPERATOR
      USE ad_balance_mod,     ONLY : ad_balance
# endif
      USE ad_convolution_mod, ONLY : ad_convolution
      USE ad_variability_mod, ONLY : ad_variability
      USE ad_wrt_his_mod,     ONLY : ad_wrt_his
# ifdef STD_MODEL
      USE background_std_mod, ONLY : background_std
# endif
      USE back_cost_mod,      ONLY : back_cost
      USE cgradient_mod,      ONLY : cgradient
# ifdef SPLIT_4DVAR
      USE cgradient_mod,      ONLY : cg_read_cgradient
# endif
      USE close_io_mod,       ONLY : close_file
      USE cost_grad_mod,      ONLY : cost_grad
      USE def_hessian_mod,    ONLY : def_hessian
# ifdef SPLIT_4DVAR
      USE def_ini_mod,        ONLY : def_ini
# endif
      USE def_mod_mod,        ONLY : def_mod
      USE def_norm_mod,       ONLY : def_norm
# ifdef STD_MODEL
      USE def_std_mod,        ONLY : def_std
# endif
      USE get_state_mod,      ONLY : get_state
      USE ini_adjust_mod,     ONLY : ini_adjust
      USE normalization_mod,  ONLY : normalization
# if defined MASKING && defined SPLIT_4DVAR
      USE set_masks_mod,      ONLY : set_masks
# endif
      USE strings_mod,        ONLY : founderror
      USE sum_grad_mod,       ONLY : sum_grad
# ifdef BALANCE_OPERATOR
      USE tl_balance_mod,     ONLY : tl_balance
# endif
      USE tl_convolution_mod, ONLY : tl_convolution
# ifdef SPLIT_4DVAR
      USE tl_def_his_mod,     ONLY : tl_def_his
      USE tl_def_ini_mod,     ONLY : tl_def_ini
# endif
      USE tl_variability_mod, ONLY : tl_variability
      USE tl_wrt_ini_mod,     ONLY : tl_wrt_ini
# ifdef EVOLVED_LCZ
      USE wrt_evolved_mod,    ONLY : wrt_evolved
# endif
# if defined ADJUST_BOUNDARY || defined ADJUST_STFLUX || \
     defined adjust_wstress
      USE wrt_ini_mod,        ONLY : wrt_frc
# endif
      USE wrt_ini_mod,        ONLY : wrt_ini
# ifdef STD_MODEL
      USE wrt_std_mod,        ONLY : wrt_std
# endif
# if defined BALANCE_OPERATOR && defined ZETA_ELLIPTIC
      USE zeta_balance_mod,   ONLY : balance_ref, biconj
# endif
!
      implicit none
!
      PUBLIC  :: background_initialize
      PUBLIC  :: background
      PUBLIC  :: increment
      PUBLIC  :: analysis
      PUBLIC  :: posterior_analysis_initialize
      PUBLIC  :: posterior_analysis
      PUBLIC  :: prior_error
!
!  Set module internal parameters.
!
      logical :: lgetnrm        ! process covariance normalization
      logical :: lgetstd        ! process covariance standard deviation
# ifdef SPLIT_4DVAR
      logical :: ldone          ! 4D-Var cycle finish switch
# endif
!
      integer :: ltlm1 = 1      ! trial x-space TLM IC record in ITL
      integer :: ltlm2 = 2      ! previous v-space TLM IC record in ITL
      integer :: ltlm3 = 3      ! trial v-space TLM IC record in ITL
      integer :: ladj1 = 1      ! initial cost gradient
      integer :: ladj2 = 2      ! new cost gradient (not normalized)
      integer :: lini  = 1      ! NLM initial conditions record in INI
      integer :: lbck  = 2      ! background record in INI
      integer :: rec1  = 1
      integer :: rec2  = 2
      integer :: rec3  = 3
      integer :: rec4  = 4
# ifdef SPLIT_4DVAR
      integer :: rec5  = 5
# endif
!
      CONTAINS
!
      SUBROUTINE background_initialize (my_outer)
!
!=======================================================================
!                                                                      !
!  This routine initializes ROMS nonlinear model trajectory Xb_n-1(0)  !
!  for each (n-1) outer loops. It is separated from the 'background'   !
!  4D-Var phase in ESM coupling applications that use generic methods  !
!  for 'initialize', 'run', and 'finalize'.                            !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     my_outer        Outer-loop counter (integer)                     !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations
!
      integer, intent(in) :: my_outer
!
!  Local variable declarations.
!
      integer :: lstr, ng, tile
# ifdef STD_MODEL
      integer :: lstd
# endif
      integer :: fcount, inprec, tindex
# ifdef PROFILE
      integer :: thread
# endif
!
      character (len=*), parameter :: myfile =                          &
     &  __FILE__//", background_initialize"
!
      sourcefile=myfile
!
!-----------------------------------------------------------------------
!  Initialize nonlinear model kernel.
!-----------------------------------------------------------------------
 
# ifdef PROFILE
!
!  Start profile clock.
!
      DO ng=1,ngrids
        DO thread=thread_range
          CALL wclock_on (ng, inlm, 86, __line__, myfile)
        END DO
      END DO
# endif
!
!  Clear nonlinear mixing arrays.
!
      DO ng=1,ngrids
        DO tile=first_tile(ng),last_tile(ng),+1
          CALL initialize_mixing (ng, tile, inlm)
        END DO
      END DO
 
# ifdef SPLIT_4DVAR
!
!-----------------------------------------------------------------------
!  If split 4D-Var algorithm, set several variables that computed or
!  assigned in other 4D-Var phase executable.
!-----------------------------------------------------------------------
!
!  If outer>1, set ERstr=Nrun to compute the open boundary conditions
!  (OBC_time) and surface forcing (SF_time) adjustment times, if needed.
!
      IF (my_outer.gt.1) THEN
        nrun=1+(my_outer-1)*(ninner+1)
        erstr=nrun
      END IF
 
#  if defined ADJUST_BOUNDARY || defined ADJUST_STFLUX || \
      defined adjust_wstress
!
!  If outer>1, reset reset surface forcing and lateral boundary output
!  time indices to LADJ2 since they are changed in the inner loops.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          lfout(ng)=ladj2
#   ifdef ADJUST_BOUNDARY
          lbout(ng)=ladj2
#   endif
        END DO
      END IF
#  endif
!
!  If outer>1, open Nonlinear model initial conditions NetCDF file
!  (INI struc) and inquire about its variable IDs. Reset the value of
!  INI(ng)%Rindex, which is needed in "initial" to the 4D-Var analysis
!  record.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          ldefini(ng)=.false.
          CALL def_ini (ng)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          ini(ng)%Rindex=lini
        END DO
      END IF
!
!  If outer>1, open 4D-Var NetCDF file (DAV struc) and inquire about its
!  variables.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          ldefmod(ng)=.false.
          CALL def_mod (ng)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          havenlmod(ng)=.false.                   ! do not read NLmodVal
        END DO
      END IF
!
!  If outer>1, read in the global observation screening and quality
!  control scale ObsScaleGlobal ("obs_scale") that it is written in the
!  first outer loop. Such data is in memory in the unsplit algorithm.
!  Recall that in I4D-Var, observation variables are read and load into
!  the arrays elements 1:Nobs(ng) for each survey time.  That is, only
!  the values needed are read.
!
!  HGA: What to do in 4D-Var with nested grids?
!
      IF (my_outer.gt.1) THEN
        ng=1
        SELECT CASE (dav(ng)%IOtype)
          CASE (io_nf90)
            CALL netcdf_get_fvar (ng, itlm, dav(ng)%name,               &
     &                            vname(1,idobss), obsscaleglobal,      &
     &                            ncid = dav(ng)%ncid)
 
#  if defined PIO_LIB && defined DISTRIBUTE
          CASE (io_pio)
            CALL pio_netcdf_get_fvar (ng, itlm, dav(ng)%name,           &
     &                                vname(1,idobss), obsscaleglobal,  &
     &                                piofile = dav(ng)%pioFile)
#  endif
        END SELECT
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END IF
!
!  If outer>1, read in initial (outer=1) nonlinear cost function values
!  from DAV file and load it into "CostNorm", its values are used for
!  reporting normalized values.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          SELECT CASE (dav(ng)%IOtype)
            CASE (io_nf90)
              CALL netcdf_get_fvar (ng, inlm, dav(ng)%name,             &
     &                              'NLcost_function',                  &
     &                              fourdvar(ng)%CostNorm(0:),          &
     &                              ncid = dav(ng)%ncid,                &
     &                              start = (/1,1/),                    &
     &                              total = (/nobsvar(ng)+1,1/))
 
#  if defined PIO_LIB && defined DISTRIBUTE
            CASE (io_pio)
              CALL pio_netcdf_get_fvar (ng, inlm, dav(ng)%name,         &
     &                                  'NLcost_function',              &
     &                                  fourdvar(ng)%CostNorm(0:),      &
     &                                  piofile = dav(ng)%pioFile,      &
     &                                  start = (/1,1/),                &
     &                                  total = (/nobsvar(ng)+1,1/))
#  endif
          END SELECT
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
      END IF
 
#  if defined ADJUST_STFLUX   || defined ADJUST_WSTRESS || \
      defined adjust_boundary
!
!  If outer>1, read in surface forcing and or lateral boundary
!  increments (X-space) from ITL file Rec5.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          ldefitl(ng)=.false.
          CALL tl_def_ini (ng)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
          inprec=rec5
          CALL get_state (ng, itlm, 1, itl(ng), inprec, ltlm1)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
      END IF
#  endif
 
#  ifdef FORWARD_FLUXES
!
!  If outer>1, set structure to process nonlinear surface fluxes from
!  the initial (outer=1) NLM quicksave trajectory. Notice that 2 is
!  substracted since the counter starts at 'outer0'.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          WRITE (qck(ng)%name,10) trim(qck(ng)%head), my_outer-2
          lstr=len_trim(qck(ng)%name)
          qck(ng)%base=qck(ng)%name(1:lstr-3)
        END DO
!
        CALL edit_multifile ('QCK2BLK')
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END IF
#  endif
# endif
!
!-----------------------------------------------------------------------
!  Initialize nonlinear model.
!-----------------------------------------------------------------------
!
!  Activate switch to write out initial misfit between model and
!  observations.
!
      DO ng=1,ngrids
        IF (my_outer.eq.1) THEN
          wrtmisfit(ng)=.true.
        ELSE
          wrtmisfit(ng)=.false.
        END IF
      END DO
!
!  Set nonlinear output history file name. Create a basic state file
!  for each outher loop.
!
      DO ng=1,ngrids
        idefhis(ng)=-1
        ldefhis(ng)=.true.
        lwrthis(ng)=.true.
        lreadfwd(ng)=.false.
        WRITE (his(ng)%name,10) trim(fwd(ng)%head), my_outer-1
        lstr=len_trim(his(ng)%name)
        his(ng)%base=his(ng)%name(1:lstr-3)
      END DO
!
!  Set the nonlinear model to output the quicksave history file as a
!  function of the outer loop. It may be used as the basic state
!  trajectory for the surface fluxes (wind stress, shortwave, heat
!  flux, and E-P) because they can be saved frequently to resolve
!  the daily cycle while avoiding large files.
!
      DO ng=1,ngrids
        ldefqck(ng)=.true.
        lwrtqck(ng)=.true.
# ifdef FORWARD_FLUXES
        lreadblk(ng)=.false.
# endif
        WRITE (qck(ng)%name,10) trim(qck(ng)%head), my_outer-1
        lstr=len_trim(qck(ng)%name)
        qck(ng)%base=qck(ng)%name(1:lstr-3)
      END DO
!
!  Initialize nonlinear model. If outer=1, the model is initialized
!  with the background or reference state. Otherwise, the model is
!  initialized with the estimated initial conditions from previous
!  iteration, X(0) = X(0) + deltaX(0).
!
      DO ng=1,ngrids
        wrtnlmod(ng)=.true.
        wrttlmod(ng)=.false.
        rst(ng)%Rindex=0
        fcount=rst(ng)%load
        rst(ng)%Nrec(fcount)=0
      END DO
!
      CALL initial
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!  If first pass, save nonlinear initial conditions (currently in time
!  index 1, background) into next record (Lbck) of INI(ng)%name NetCDF
!  file. The record "Lbck" becomes the background state record and the
!  record "Lini" becomes current nonlinear initial conditions.  Both
!  records are used in the algorithm below.
!
      IF (my_outer.eq.1) THEN
        tindex=1
        DO ng=1,ngrids
          ini(ng)%Rindex=1
          fcount=ini(ng)%load
          ini(ng)%Nrec(fcount)=1
# ifdef DISTRIBUTE
          CALL wrt_ini (ng, myrank, tindex)
# else
          CALL wrt_ini (ng, -1, tindex)
# endif
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
      END IF
 
# ifdef STD_MODEL
!
!  Estimate initial conditions standard deviation fields for the
!  background error covariance using the method of Mogensen et al.
!  (2012), which assumes that the background errors are proportional
!  to the vertical derivatives of the state. The error have simmilar
!  shape as the prior profile but iwth a displacement over the water
!  column.
!
      IF (my_outer.eq.1) THEN
        lstd=1                          ! time index in error arrays
        DO ng=1,ngrids
          DO tile=first_tile(ng),last_tile(ng),+1
            CALL background_std (ng, tile, tindex, lstd)
          END DO
        END DO
!
!  Write out estimated background standard deviation fields.
!
        DO ng=1,ngrids
          IF (lwrtstd(ng)) THEN
            std(5,ng)%Rindex=0
            fcount=std(5,ng)%load
            std(5,ng)%Nrec(fcount)=1
#  ifdef DISTRIBUTE
            CALL wrt_std (ng, myrank, lstd)
#  else
            CALL wrt_std (ng, -1, lstd)
#  endif
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END IF
        END DO
      END IF
# endif
 
# if defined BALANCE_OPERATOR && defined ZETA_ELLIPTIC
!
!  Compute the reference zeta and biconjugate gradient arrays
!  required for the balance of free surface.
!
      IF (balance(isfsur)) THEN
        DO ng=1,ngrids
          DO tile=first_tile(ng),last_tile(ng),+1
            CALL balance_ref (ng, tile, lini)
            CALL biconj (ng, tile, inlm, lini)
          END DO
          wrtzetaref(ng)=.true.
        END DO
      END IF
# endif
!
!  If first pass, define output 4DVAR NetCDF file containing all
!  processed data at observation locations.
!
      IF (my_outer.eq.1) THEN
        DO ng=1,ngrids
          ldefmod(ng)=.true.
          CALL def_mod (ng)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
      END IF
!
 10   FORMAT (a,'_outer',i0,'.nc')
!
      RETURN
      END SUBROUTINE background_initialize
!
      SUBROUTINE background (my_outer, RunInterval)
!
!=======================================================================
!                                                                      !
!  This routine computes the backgound state trajectory, Xb_n-1(t),    !
!  used to linearize the tangent linear and adjoint models in the      !
!  inner loops. It interpolates the background at the observations     !
!  locations, and computes the accept/reject quality control flag,     !
!  ObsScale.                                                           !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     my_outer        Outer-loop counter (integer)                     !
!     RunInterval     NLM kernel time stepping window (seconds)        !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations
!
      integer, intent(in)  :: my_outer
!
      real(dp), intent(in) :: runinterval
!
!  Local variable declarations.
!
      logical :: donestepping
!
      integer :: i, lstr, ng
# ifdef PROFILE
      integer :: thread
# endif
# if defined MODEL_COUPLING && !defined MCT_LIB
      integer :: nstrstep, nendstep, extra
!
      real(dp) :: endtime, nexttime
# endif
!
      character (len=*), parameter :: myfile =                          &
     &  __FILE__//", background"
!
      sourcefile=myfile
 
# if !(defined MODEL_COUPLING && defined ESMF_LIB)
!
!-----------------------------------------------------------------------
!  Set nonlinear model initial conditions.
!-----------------------------------------------------------------------
!
      CALL background_initialize (my_outer)
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
# endif
!
!-----------------------------------------------------------------------
!  Run nonlinear model. Save nonlinear tracjectory needed by the
!  adjoint and tangent linear models. Interpolate nonlinear model
!  to observation locations (compute and save H x). It processes
!  and writes the observations accept/reject flag (ObsScale) once
!  to allow background quality control, if any.
# if defined MODEL_COUPLING && !defined MCT_LIB
!  Since the ROMS kernel has a delayed output and line diagnostics by
!  one timestep, subtact an extra value to the report of starting and
!  ending timestep for clarity. Usually, the model coupling interval
!  is of the same size as ROMS timestep.
# endif
!-----------------------------------------------------------------------
 
# ifdef PROFILE
!
!  Start profile clock.
!
      DO ng=1,ngrids
        DO thread=thread_range
          CALL wclock_on (ng, inlm, 86, __line__, myfile)
        END DO
      END DO
# endif
!
!  Initialize various parameters and switches.
!
      myruninterval=runinterval
!
      DO ng=1,ngrids
# ifdef AVERAGES
        idefavg(ng)=-1
        ldefavg(ng)=.true.
        lwrtavg(ng)=.true.
        WRITE (avg(ng)%name,10) trim(avg(ng)%head), my_outer
        lstr=len_trim(avg(ng)%name)
        avg(ng)%base=avg(ng)%name(1:lstr-3)
# endif
# ifdef DIAGNOSTICS
        idefdia(ng)=-1
        ldefdia(ng)=.true.
        lwrtdia(ng)=.true.
        WRITE (dia(ng)%name,10) trim(dia(ng)%head), my_outer
        lstr=len_trim(dia(ng)%name)
        dia(ng)%base=dia(ng)%name(1:lstr-3)
# endif
        wrtobsscale(ng)=.true.
# if defined MODEL_COUPLING && !defined MCT_LIB
!
        nexttime=time(ng)+runinterval
        endtime=initime(ng)+(ntimes(ng)-1)*dt(ng)
        IF ((nexttime.eq.endtime).and.(ng.eq.1)) THEN
          extra=0                                   ! last time interval
        ELSE
          extra=1
        END IF
        step_counter(ng)=0
        nstrstep=iic(ng)
        nendstep=nstrstep+int((myruninterval)/dt(ng))-extra
        IF (master) WRITE (stdout,20) 'NL', ng, my_outer, 0,            &
     &                                nstrstep, nendstep
# else
        IF (master) WRITE (stdout,20) 'NL', ng, my_outer, 0,            &
     &                                ntstart(ng), ntend(ng)
# endif
      END DO
!
# ifdef SOLVE3D
      CALL main3d (runinterval)
# else
      CALL main2d (runinterval)
# endif
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!-----------------------------------------------------------------------
!  If completed stepping, write out into NetCDF files.
# if defined MODEL_COUPLING && !defined MCT_LIB
!  In coupled applications, RunInterval is much less than ntimes*dt,
!  so we need to wait until the last coupling interval is finished.
!  Otherwise, the control switches will be turned off prematurely.
# endif
!-----------------------------------------------------------------------
!
# if defined MODEL_COUPLING && !defined MCT_LIB
      IF (nendstep.eq.ntend(1)) THEN
        donestepping=.true.
      ELSE
        donestepping=.false.
      END IF
# else
      donestepping=.true.
# endif
!
      IF (donestepping) THEN
 
# if defined ADJUST_BOUNDARY || defined ADJUST_STFLUX || \
     defined adjust_wstress
!
!  Write out initial and background surface forcing into initial
!  INI(ng)%name NetCDF file for latter use.
!
        DO ng=1,ngrids
#  ifdef DISTRIBUTE
          CALL wrt_frc (ng, myrank, lfout(ng), lini)
#  else
          CALL wrt_frc (ng, -1, lfout(ng), lini)
#  endif
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
          IF (my_outer.eq.1) THEN
#  ifdef DISTRIBUTE
            CALL wrt_frc (ng, myrank, lfout(ng), lbck)
#  else
            CALL wrt_frc (ng, -1, lfout(ng), lbck)
#  endif
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END IF
        END DO
# endif
!
!  Write out nonlinear model misfit cost function into DAV(ng)%name
!  NetCDF file.
!
        sourcefile=myfile
        DO ng=1,ngrids
          SELECT CASE (dav(ng)%IOtype)
            CASE (io_nf90)
              CALL netcdf_put_fvar (ng, inlm, dav(ng)%name,             &
     &                              'NLcost_function',                  &
     &                              fourdvar(ng)%NLobsCost(0:),         &
     &                              (/1,my_outer/),                     &
     &                              (/nobsvar(ng)+1,1/),                &
     &                              ncid = dav(ng)%ncid)
 
# if defined PIO_LIB && defined DISTRIBUTE
            CASE (io_pio)
              CALL pio_netcdf_put_fvar (ng, inlm, dav(ng)%name,         &
     &                                  'NLcost_function',              &
     &                                  fourdvar(ng)%NLobsCost(0:),     &
     &                                  (/1,my_outer/),                 &
     &                                  (/nobsvar(ng)+1,1/),            &
     &                                  piofile = dav(ng)%pioFile)
# endif
          END SELECT
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
      END IF
 
# ifdef PROFILE
!
!  Stop profile clock
!
      DO ng=1,ngrids
        DO thread=thread_range
          CALL wclock_off (ng, inlm, 86, __line__, myfile)
        END DO
      END DO
# endif
!
 10   FORMAT (a,'_outer',i0,'.nc')
 20   FORMAT (/,1x,a,1x,'ROMS: started time-stepping:',                 &
     &        ' (Grid: ',i0,', Outer: ',i2.2,', Inner: ',i3.3,          &
              ', TimeSteps: ',i0,' - ',i0,')',/)
!
      RETURN
      END SUBROUTINE background
!
      SUBROUTINE increment (my_outer, RunInterval)
!
!=======================================================================
!                                                                      !
!  This routine computes the 4D-Var data assimilation state increment, !
!  dXa, by iterating the inner loops and minimizing the cost function. !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     my_outer        Outer-loop counter (integer)                     !
!     RunInterval     TLM/ADM kernels time stepping window (seconds)   !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations
!
      logical :: lweak = .false.
!
      integer, intent(in) :: my_outer
!
      real(dp), intent(in) :: runinterval
!
!  Local variable declarations.
!
      integer :: i, ifile, lstr, my_inner, ng, tile
      integer :: fcount, inprec, lcon, lsav
# ifdef PROFILE
      integer :: thread
# endif
!
      real(r8) :: rate
# ifdef SPLIT_4DVAR
      real(dp) :: stime
# endif
!
      character (len=10) :: suffix
 
      character (len=*), parameter :: myfile =                          &
     &  __FILE__//", increment"
!
      sourcefile=myfile
!
!=======================================================================
!  Compute 4D-Var increment.
!=======================================================================
 
# ifdef PROFILE
!
!  Start profile clock.
!
      DO ng=1,ngrids
        DO thread=thread_range
          CALL wclock_on (ng, itlm, 87, __line__, myfile)
        END DO
      END DO
# endif
 
# ifdef SPLIT_4DVAR
!
!-----------------------------------------------------------------------
!  If split 4D-Var algorithm, set several variables that are computed
!  or assigned in other 4D-Var phase executable.
!-----------------------------------------------------------------------
!
!  Reset Nrun counter to a value greater than one.
!
      IF (my_outer.gt.1) THEN
        nrun=1+(my_outer-1)*(ninner+1)
      END IF
!
!  Open 4D-Var NetCDF file (DAV struc) and inquire about its variables.
!  Activate "haveNLmod" to read its values in calls to "obs_read". Its
!  values were written in the "background" phase.
!
      DO ng=1,ngrids
        ldefmod(ng)=.false.
        CALL def_mod (ng)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        havenlmod(ng)=.true.
      END DO
!
!  In the split 4D-Var algorithm, we need to read the global observation
!  screening and quality control scale ObsScaleGlobal ("obs_scale") that
!  it is written in the "background" phase. Such data is in memory in
!  the unsplit algorithm.  Recall that in I4D-Var, observation variables
!  are read and load into the arrays elements 1:Nobs(ng) for each survey
!  time.  That is, only the values needed are read.
!
!  HGA: What to do in 4D-Var with nested grids?
!
      ng=1
      SELECT CASE (dav(ng)%IOtype)
        CASE (io_nf90)
          CALL netcdf_get_fvar (ng, itlm, dav(ng)%name,                 &
     &                          vname(1,idobss), obsscaleglobal,        &
     &                          ncid = dav(ng)%ncid)
 
#  if defined PIO_LIB && defined DISTRIBUTE
        CASE (io_pio)
          CALL pio_netcdf_get_fvar (ng, itlm, dav(ng)%name,             &
     &                              vname(1,idobss), obsscaleglobal,    &
     &                              piofile = dav(ng)%pioFile)
#  endif
      END SELECT
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!  Read in first value of NLM cost function computed at outer=1, and
!  load it into "CostNorm" that is used in the reporting of normalized
!  values.
!
      sourcefile=myfile
      DO ng=1,ngrids
        SELECT CASE (dav(ng)%IOtype)
          CASE (io_nf90)
            CALL netcdf_get_fvar (ng, inlm, dav(ng)%name,               &
     &                            'NLcost_function',                    &
     &                            fourdvar(ng)%CostNorm(0:),            &
     &                            ncid = dav(ng)%ncid,                  &
     &                            start = (/1,1/),                      &
     &                            total = (/nobsvar(ng)+1,1/))
 
#  if defined PIO_LIB && defined DISTRIBUTE
          CASE (io_pio)
            CALL pio_netcdf_get_fvar (ng, inlm, dav(ng)%name,           &
     &                                'NLcost_function',                &
     &                                fourdvar(ng)%CostNorm(0:),        &
     &                                piofile = dav(ng)%pioFile,        &
     &                                start = (/1,1/),                  &
     &                                total = (/nobsvar(ng)+1,1/))
#  endif
        END SELECT
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  Read in current outer loop NLM cost function.
!
      DO ng=1,ngrids
        SELECT CASE (dav(ng)%IOtype)
          CASE (io_nf90)
            CALL netcdf_get_fvar (ng, inlm, dav(ng)%name,               &
     &                            'NLcost_function',                    &
     &                            fourdvar(ng)%NLobsCost(0:),           &
     &                            ncid = dav(ng)%ncid,                  &
     &                            start = (/1,my_outer/),               &
     &                            total = (/nobsvar(ng)+1,1/))
 
#  if defined PIO_LIB && defined DISTRIBUTE
          CASE (io_pio)
            CALL pio_netcdf_get_fvar (ng, inlm, dav(ng)%name,           &
     &                                'NLcost_function',                &
     &                                fourdvar(ng)%NLobsCost(0:),       &
     &                                piofile = dav(ng)%pioFile,        &
     &                                start = (/1,my_outer/),           &
     &                                total = (/nobsvar(ng)+1,1/))
#  endif
         END SELECT
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  If outer>1, read in previous background and TLM cost function to
!  compute FOURDVAR(ng)%CostFun(0).  Its value is in memory in the
!  unsplit driver.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          SELECT CASE (dav(ng)%IOtype)
            CASE (io_nf90)
              CALL netcdf_get_fvar (ng, inlm, dav(ng)%name,             &
     &                              'TLcost_function',                  &
     &                              fourdvar(ng)%CostFunOld(0:),        &
     &                              ncid = dav(ng)%ncid,                &
     &                              start = (/nrun-1/),                 &
     &                              total = (/1/))
              IF (founderror(exit_flag, noerror, __line__,              &
     &                       myfile)) RETURN
!
              CALL netcdf_get_fvar (ng, inlm, dav(ng)%name,             &
     &                              'back_function',                    &
     &                              fourdvar(ng)%BackCost(0:),          &
     &                              ncid = dav(ng)%ncid,                &
     &                              start = (/nrun-1/),                 &
     &                              total = (/1/))
              IF (founderror(exit_flag, noerror, __line__,              &
     &                       myfile)) RETURN
 
#  if defined PIO_LIB && defined DISTRIBUTE
            CASE (io_pio)
              CALL pio_netcdf_get_fvar (ng, inlm, dav(ng)%name,         &
     &                                  'TLcost_function',              &
     &                                  fourdvar(ng)%CostFunOld(0:),    &
     &                                  piofile = dav(ng)%pioFile,      &
     &                                  start = (/nrun-1/),             &
     &                                  total = (/1/))
              IF (founderror(exit_flag, noerror, __line__,              &
     &                       myfile)) RETURN
!
              CALL pio_netcdf_get_fvar (ng, inlm, dav(ng)%name,         &
     &                                  'back_function',                &
     &                                  fourdvar(ng)%BackCost(0:),      &
     &                                  piofile = dav(ng)%pioFile,      &
     &                                  start = (/nrun-1/),             &
     &                                  total = (/1/))
              IF (founderror(exit_flag, noerror, __line__,              &
     &                       myfile)) RETURN
#  endif
          END SELECT
!
          fourdvar(ng)%CostFun(0)=fourdvar(ng)%CostFunOld(0)+           &
     &                            fourdvar(ng)%BackCost(0)
        END DO
      END IF
!
!  If outer>1, read several conjugate gradient variables from 4D-VAR
!  NetCDF (DAV struc) file.  In the unsplit case, such values are
!  available in memory.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          CALL cg_read_cgradient (ng, itlm, my_outer)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
      END IF
!
!  If outer>1, open tangent linear initial conditions NetCDF file
!  (ITL struc) and inquire about its variables IDs.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          ldefitl(ng)=.false.
          CALL tl_def_ini (ng)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
      END IF
!
!  If outer>1, open tangent linear history NetCDF file (TLM struc) and
!  inquire about its variables IDs.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          ldeftlm(ng)=.false.
          CALL tl_def_his (ng, ldeftlm(ng))
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
      END IF
!
!  Set nonlinear output history file to be used as the basis state
!  trajectory. The 4D-Var increment phase is computed by a different
!  executable and needs to know some of the HIS structure information.
!
      DO ng=1,ngrids
        WRITE (his(ng)%name,10) trim(fwd(ng)%head), my_outer-1
        lstr=len_trim(his(ng)%name)
        his(ng)%base=his(ng)%name(1:lstr-3)
        IF (his(ng)%Nfiles.gt.1) THEN
          DO ifile=1,his(ng)%Nfiles
            WRITE (suffix,"('_',i4.4,'.nc')") ifile
            his(ng)%files(ifile)=trim(his(ng)%base)//trim(suffix)
          END DO
          his(ng)%name=trim(his(ng)%files(1))
        ELSE
          his(ng)%files(1)=trim(his(ng)%name)
        END IF
      END DO
!
!  Set the nonlinear model quicksave-history file as the basic state for
!  the surface fluxes computed in "bulk_flux", which may be available at
!  more frequent intervals while avoiding large files. Since the 4D-Var
!  increment phase is calculated by a different executable and needs to
!  know some of the QCK structure information.
!
      DO ng=1,ngrids
        WRITE (qck(ng)%name,10) trim(qck(ng)%head), my_outer-1
        lstr=len_trim(qck(ng)%name)
        qck(ng)%base=qck(ng)%name(1:lstr-3)
        IF (qck(ng)%Nfiles.gt.1) THEN
          DO ifile=1,qck(ng)%Nfiles
            WRITE (suffix,"('_',i4.4,'.nc')") ifile
            qck(ng)%files(ifile)=trim(qck(ng)%base)//trim(suffix)
          END DO
          qck(ng)%name=trim(qck(ng)%files(1))
        ELSE
          qck(ng)%files(1)=trim(qck(ng)%name)
        END IF
      END DO
!
!  Read in 4D-Var starting time (sec) from nonlinear trajectory.
!  Initialize "tday" which are needed to write the correct time in
!  the ITL NetCDF file.  It is alse need for boundary and surface
!  forcing adjustments, if any.
!
      inprec=1
      DO ng=1,ngrids
        SELECT CASE (his(ng)%IOtype)
          CASE (io_nf90)
            CALL netcdf_get_fvar (ng, itlm, his(ng)%name,               &
     &                            vname(1,idtime), stime,               &
     &                            start = (/inprec/),                   &
     &                            total = (/1/))
 
#  if defined PIO_LIB && defined DISTRIBUTE
          CASE (io_pio)
            CALL pio_netcdf_get_fvar (ng, itlm, his(ng)%name,           &
     &                                vname(1,idtime), stime,           &
     &                                start = (/inprec/),               &
     &                                total = (/1/))
#  endif
        END SELECT
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        initime(ng)=stime
 
#  ifdef ADJUST_BOUNDARY
!
!  Set time (sec) for the open boundary adjustment.
!
        obc_time(1,ng)=stime
        DO i=2,nbrec(ng)
          obc_time(i,ng)=obc_time(i-1,ng)+nobc(ng)*dt(ng)
        END DO
#  endif
 
#  if defined ADJUST_STFLUX || defined ADJUST_WSTRESS
!
!  Set time (sec) for the surface forcing adjustment.
!
        sf_time(1,ng)=stime
        DO i=2,nfrec(ng)
          sf_time(i,ng)=sf_time(i-1,ng)+nsff(ng)*dt(ng)
        END DO
#  endif
      END DO
# endif
!
!-----------------------------------------------------------------------
!  Initialize.
!-----------------------------------------------------------------------
!
!  Set various switches.
!
      DO ng=1,ngrids
        lwrtcost(ng)=.true.
# ifdef AVERAGES
        ldefavg(ng)=.false.
        lwrtavg(ng)=.false.
# endif
# ifdef DIAGNOSTICS
        ldefdia(ng)=.false.
        lwrtdia(ng)=.false.
# endif
        wrtnlmod(ng)=.false.
        wrtobsscale(ng)=.false.
        wrttlmod(ng)=.true.
      END DO
!
!  Set structure for the nonlinear forward trajectory to be processed
!  by the tangent linear and adjoint models. Also, set switches to
!  process the FWD structure in routine "check_multifile". Notice that
!  it is possible to split solution into multiple NetCDF files to reduce
!  their size.
!
      CALL edit_multifile ('HIS2FWD')
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      DO ng=1,ngrids
        lreadfwd(ng)=.true.
      END DO
 
# ifdef FORWARD_FLUXES
!
!  Set the BLK structure to contain the nonlinear model surface fluxes
!  needed by the tangent linear and adjoint models. Also, set switches
!  to process that structure in routine "check_multifile". Notice that
!  it is possible to split the solution into multiple NetCDF files to
!  reduce their size.
!
!  The switch LreadFRC is deactivated because all the atmospheric
!  forcing, including shortwave radiation, is read from the NLM
!  surface fluxes or is assigned during ESM coupling.  Such fluxes
!  are available from the QCK structure. There is no need for reading
!  and processing from the FRC structure input forcing-files.
!
      CALL edit_multifile ('QCK2BLK')
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      DO ng=1,ngrids
        lreadblk(ng)=.true.
        lreadfrc(ng)=.false.
        lreadqck(ng)=.false.
      END DO
# endif
!
!  Clear the nonlinear state arrays to make sure that the RHS terms
!  rzeta, rubar, rvbar, ru, and rv are zero. Otherwise, those arrays
!  will have the last computed values when running the nonlinear model
!  if not processing the forward trajectory RHS terms. It needs to be
!  done to get identical solutions with the split schemes.
!
      DO ng=1,ngrids
        DO tile=first_tile(ng),last_tile(ng),+1
          CALL initialize_ocean (ng, tile, inlm)
        END DO
      END DO
!
!  The minimization algorithm requires to save all the gradient
!  solutions for each inner loop iteration.  They are used for
!  orthogonalization in the conjugate gradient algorithm.  Thus,
!  we need to reset adjoint file record indices.
!
      DO ng=1,ngrids
        adm(ng)%Rindex=0
        fcount=adm(ng)%load
        adm(ng)%Nrec(fcount)=0
      END DO
!
!  An adjoint NetCDF is created for each outer loop.
!
      DO ng=1,ngrids
        idefadj(ng)=-1
        ldefadj(ng)=.true.
        WRITE (adm(ng)%name,10) trim(adm(ng)%head), my_outer
        lstr=len_trim(adm(ng)%name)
        adm(ng)%base=adm(ng)%name(1:lstr-3)
      END DO
!
!  Define output Hessian NetCDF file containing the eigenvectors
!  approximation to the Hessian matrix computed from the Lanczos
!  algorithm. Notice that the file name is a function of the
!  outer loop. That is, a file is created for each outer loop.
!
      DO ng=1,ngrids
        ldefhss(ng)=.true.
        WRITE (hss(ng)%name,10) trim(hss(ng)%head), my_outer
        lstr=len_trim(hss(ng)%name)
        hss(ng)%base=hss(ng)%name(1:lstr-3)
        CALL def_hessian (ng)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  Notice that inner loop iteration start from zero. This is needed to
!  compute the minimization initial increment deltaX(0), its associated
!  gradient G(0), and descent direction d(0) used in the conjugate
!  gradient algorithm.
!
      inner_loop : DO my_inner=0,ninner
        inner=my_inner
!
!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
!  Time-step tangent linear model: compute cost function.
!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
!
!  If first pass inner=0, initialize tangent linear state (increments,
!  deltaX) from rest. Otherwise, use trial initial conditions estimated
!  by the conjugate gradient algorithm in previous inner loop. The TLM
!  initial conditions are read from ITL(ng)%name, record 1.
!
        DO ng=1,ngrids
          itl(ng)%Rindex=1
          CALL tl_initial (ng)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
!
!  On first pass, initialize records 2, 3 and 4 of the ITL file to zero.
!
        IF ((my_inner.eq.0).and.(my_outer.eq.1)) THEN
          DO ng=1,ngrids
# ifdef DISTRIBUTE
            CALL tl_wrt_ini (ng, myrank, ltlm1, rec2)
# else
            CALL tl_wrt_ini (ng, -1, ltlm1, rec2)
# endif
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
# ifdef DISTRIBUTE
            CALL tl_wrt_ini (ng, myrank, ltlm1, rec3)
# else
            CALL tl_wrt_ini (ng, -1, ltlm1, rec3)
# endif
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
# ifdef DISTRIBUTE
            CALL tl_wrt_ini (ng, myrank, ltlm1, rec4)
# else
            CALL tl_wrt_ini (ng, -1, ltlm1, rec4)
# endif
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END DO
        END IF
 
# ifdef MULTIPLE_TLM
!
!  If multiple TLM history NetCDF files, activate writing and determine
!  output filename. The multiple file option is used to perturb initial
!  state and create ensembles.  The TLM final trajectory is written for
!  each inner loop on separated NetCDF files.
!
        DO ng=1,ngrids
          ideftlm(ng)=-1
          ldeftlm(ng)=.true.
          lwrttlm(ng)=.true.
          WRITE (tlm(ng)%name,20) trim(tlm(ng)%head), nrun
          lstr=len_trim(tlm(ng)%name)
          tlm(ng)%base=tlm(ng)%name(1:lstr-3)
        END DO
# endif
!
!  Run tangent linear model. Compute misfit observation cost function,
!  Jo.
!
        DO ng=1,ngrids
          IF (master) THEN
            WRITE (stdout,30) 'TL', ng, my_outer, my_inner,             &
     &                        ntstart(ng), ntend(ng)
          END IF
        END DO
!
# ifdef SOLVE3D
        CALL tl_main3d (runinterval)
# else
        CALL tl_main2d (runinterval)
# endif
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
 
# ifdef EVOLVED_LCZ
!
!  Write evolved tangent Lanczos vector into hessian netcdf file for use
!  later.
!
!  NOTE: When using this option, it is important to set LhessianEV and
!  Lprecond to FALSE in s4dvar.in, otherwise the evolved Lanczos vectors
!  with be overwritten by the Hessian eigenvectors. The fix to this
!  is to define a new NetCDF file that contains the evolved Lanczos
!  vectors.
!
        IF (my_inner.ne.0) THEN
          DO ng=1,ngrids
#  ifdef DISTRIBUTE
            CALL wrt_evolved (ng, myrank, kstp(ng), nrhs(ng))
#  else
            CALL wrt_evolved (ng, -1, kstp(ng), nrhs(ng))
#  endif
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END DO
        END IF
# endif
 
# ifdef MULTIPLE_TLM
!
!  If multiple TLM history NetCDF files, close current NetCDF file.
!
        sourcefile=myfile
        DO ng=1,ngrids
          CALL close_file (ng, itlm, tlm(ng))
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
# endif
!
!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
!  Time step adjoint model backwards: compute cost function gradient.
!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
!
!  Initialize the adjoint model always from rest.
!
        DO ng=1,ngrids
          CALL ad_initial (ng)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
!
!  Time-step adjoint model backwards. The adjoint model is forced with
!  the adjoint of the observation misfit (Jo) term.
!
        DO ng=1,ngrids
          IF (master) THEN
            WRITE (stdout,30) 'AD', ng, my_outer, my_inner,             &
     &                        ntstart(ng), ntend(ng)
          END IF
        END DO
!
# ifdef SOLVE3D
        CALL ad_main3d (runinterval)
# else
        CALL ad_main2d (runinterval)
# endif
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!  Clear adjoint arrays.
!
        DO ng=1,ngrids
          DO tile=first_tile(ng),last_tile(ng),+1
            CALL initialize_ocean (ng, tile, iadm)
# if defined ADJUST_STFLUX || defined ADJUST_WSTRESS
            CALL initialize_forces (ng, tile, iadm)
# endif
# ifdef ADJUST_BOUNDARY
            CALL initialize_boundary (ng, tile, iadm)
# endif
          END DO
        END DO
!
!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
!  Conjugate gradient algorithm.
!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
!
!  Read TLM v-space initial conditions, record 3 in ITL(ng)%name, and
!  load it into time index LTLM1. This is needed to compute background
!  cost function. Also read in new (x-space) gradient vector, GRADx(Jo),
!  from adjoint history file ADM(ng)%name.  Read in the sum of all the
!  previous outer-loop increments which are always in record 4 of
!  the ITL file.
!
        DO ng=1,ngrids
          IF (my_inner.eq.0) THEN
            inprec=rec1
            CALL get_state (ng, itlm, 8, itl(ng), inprec, ltlm1)
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          ELSE
            inprec=rec3
            CALL get_state (ng, itlm, 8, itl(ng), inprec, ltlm1)
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END IF
 
          inprec=rec4
          CALL get_state (ng, itlm, 8, itl(ng), inprec, ltlm2)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
 
          inprec=adm(ng)%Rindex
          CALL get_state (ng, iadm, 4, adm(ng), inprec, ladj2)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
 
# ifdef BALANCE_OPERATOR
          inprec=lini
          CALL get_state (ng, inlm, 2, ini(ng), inprec, lini)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          nrhs(ng)=lini
# endif
        END DO
!
!  Convert observation cost function gradient, GRADx(Jo), from model
!  space (x-space) to minimization space (v-space):
!
!     GRADv(Jo) = B^(T/2) GRADx(Jo),  operator: S G L^(T/2) W^(-1/2)
!
!  First, multiply the adjoint solution, GRADx(Jo), by the background-
!  error standard deviations, S.  Second, convolve result with the
!  adjoint diffusion operator, G L^(T/2) W^(-1/2). Then, backgound
!  cost function contribution (BackCost) and cost function gradient
!  (v-space) by adding background and observation contributions:
!
!     GRADv(J) = GRADv(Jb) + GRADv(Jo) = deltaV + GRADv(Jo)
!
        DO ng=1,ngrids
          DO tile=first_tile(ng),last_tile(ng),+1
# ifdef BALANCE_OPERATOR
            CALL ad_balance (ng, tile, lini, ladj2)
# endif
            CALL ad_variability (ng, tile, ladj2, lweak)
            CALL ad_convolution (ng, tile, ladj2, lweak, 2)
            CALL cost_grad (ng, tile, ltlm1, ltlm2, ladj2)
          END DO
        END DO
!
!  Compute current total cost function.
!
        DO ng=1,ngrids
          IF (nrun.eq.1) THEN
            DO i=0,nobsvar(ng)
              fourdvar(ng)%CostFunOld(i)=fourdvar(ng)%CostNorm(i)
              fourdvar(ng)%CostFun(i)=fourdvar(ng)%CostNorm(i)
            END DO
          ELSE
            DO i=0,nobsvar(ng)
              fourdvar(ng)%CostFunOld(i)=fourdvar(ng)%CostFun(i)
            END DO
          END IF
        END DO
!
!  Prepare for background cost function (Jb) calculation:
!
!  Read the convolved gradient from inner=0 (which is permanently
!  saved in record 1 of the adjoint file)  ALWAYS into record 1.
!
        IF (my_inner.gt.0) THEN
          DO ng=1,ngrids
            inprec=ladj1
            CALL get_state (ng, iadm, 3, adm(ng), inprec, ladj1)
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END DO
        END IF
!
!  Compute background cost function (Jb) for inner=0:
!
!  If first pass of inner loop, read in the sum of previous v-space
!  gradients from record 4 of ITL file using the TLM model variables
!  as temporary storage. Also add background cost function to Cost0.
!
        IF (my_inner.eq.0) THEN
          DO ng=1,ngrids
            inprec=rec4
            CALL get_state (ng, itlm, 2, itl(ng), inprec, ltlm2)
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
            DO tile=first_tile(ng),last_tile(ng),+1
              CALL back_cost (ng, tile, ltlm2)
            END DO
!
            fourdvar(ng)%Cost0(my_outer)=fourdvar(ng)%Cost0(my_outer)+  &
     &                                   fourdvar(ng)%BackCost(0)
          END DO
        END IF
!
!  Compute current total cost function.
!
        DO ng=1,ngrids
          IF (nrun.eq.1) THEN
            DO i=0,nobsvar(ng)
              fourdvar(ng)%CostNorm(i)=fourdvar(ng)%CostNorm(i)+        &
     &                                 fourdvar(ng)%BackCost(i)
              fourdvar(ng)%CostFunOld(i)=fourdvar(ng)%CostNorm(i)
              fourdvar(ng)%CostFun(i)=fourdvar(ng)%CostNorm(i)
            END DO
          ELSE
            DO i=0,nobsvar(ng)
              fourdvar(ng)%CostFunOld(i)=fourdvar(ng)%CostFun(i)
            END DO
          END IF
        END DO
!
!  Determine the descent direction in which the quadractic total cost
!  function decreases. Then, determine the TLM initial conditions,
!  deltaV(LTLM1), and its gradient, GRADv{J(Lnew)} at the new
!  direction.  Also, Compute TLM v-space trial initial conditions for
!  next inner loop, deltaV(LTLM2). The new gradient minimize the
!  quadratic cost function spanned by current and previous inner loop
!  iterations.  This is achieved by orthogonalizing (Gramm-Schmidt
!  algorithm) against all previous inner loop gradients.
!
        DO ng=1,ngrids
          DO tile=first_tile(ng),last_tile(ng),+1
            CALL cgradient (ng, tile, itlm, my_inner, my_outer)
          END DO
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
!
!  Report background (Jb) and observations (Jo) cost function values
!  normalized by their first minimization value. It also reports the
!  percentage change on total cost function value with respect to
!  previous iteration. Compute the optimality of the minimization to
!  check the statistical hypotheses between the background and
!  observations errors: the cost function value at the minimum, Jmin,
!  is ideally equal to half the number of observations assimilated
!  (Optimality=1=2*Jmin/Nobs), for a linear system.
!
        IF (master) THEN
          DO ng=1,ngrids
            IF (nrun.gt.1) THEN
              rate=100.0_r8*abs(fourdvar(ng)%CostFun(0)-                &
     &                          fourdvar(ng)%CostFunOld(0))/            &
     &                      fourdvar(ng)%CostFunOld(0)
            ELSE
              rate=0.0_r8
            END IF
            optimality(ng)=2.0_r8*fourdvar(ng)%CostFun(0)/              &
     &                     (fourdvar(ng)%ObsCount(0)-                   &
     &                      fourdvar(ng)%ObsReject(0))
            WRITE (stdout,40) my_outer, my_inner,                       &
     &                        fourdvar(ng)%BackCost(0)/                 &
     &                        fourdvar(ng)%CostNorm(0),                 &
     &                        fourdvar(ng)%ObsCost(0)/                  &
     &                        fourdvar(ng)%CostNorm(0),                 &
     &                        rate
            IF (my_inner.eq.0) THEN
              DO i=0,nobsvar(ng)
                IF (fourdvar(ng)%NLobsCost(i).ne.0.0_r8) THEN
                  IF (i.eq.0) THEN
                    WRITE (stdout,50) my_outer, my_inner,               &
     &                                fourdvar(ng)%NLobsCost(i)/        &
     &                                fourdvar(ng)%CostNorm(i)
                  ELSE
                    WRITE (stdout,60) my_outer, my_inner,               &
     &                                fourdvar(ng)%NLobsCost(i)/        &
     &                                fourdvar(ng)%CostNorm(i),         &
     &                                trim(obsname(i))
                  END IF
                END IF
                fourdvar(ng)%NLobsCost(i)=0.0
              END DO
            END IF
            WRITE (stdout,70) my_outer, my_inner, optimality(ng)
          END DO
        END IF
!
!  Save total v-space cost function gradient, GRADv{J(Lnew)}, into
!  ADM(ng)%name history NetCDF file. Noticed that the lastest adjoint
!  solution record is over-written in the NetCDF file for future use.
!  The switch "LwrtState2d" is activated to write out state arrays
!  instead ad_*_sol arrays (HGA).
!
        DO ng=1,ngrids
# if defined ADJUST_STFLUX || defined ADJUST_WSTRESS
          lfout(ng)=ladj2
# endif
# ifdef ADJUST_BOUNDARY
          lbout(ng)=ladj2
# endif
          kstp(ng)=ladj2
# ifdef SOLVE3D
          nstp(ng)=ladj2
# endif
          adm(ng)%Rindex=adm(ng)%Rindex-1
          lwrtstate2d(ng)=.true.
# ifdef DISTRIBUTE
          CALL ad_wrt_his (ng, myrank)
# else
          CALL ad_wrt_his (ng, -1)
# endif
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          lwrtstate2d(ng)=.false.
        END DO
!
!  Write out trial v-space TLM initial conditions, currently in time
!  index LTM2, into record 3 of ITL(ng)%name NetCDF file.
!
        DO ng=1,ngrids
# ifdef DISTRIBUTE
          CALL tl_wrt_ini (ng, myrank, ltlm2, rec3)
# else
          CALL tl_wrt_ini (ng, -1, ltlm2, rec3)
# endif
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
!
!  Read current outer loop nonlinear model initial conditions and
!  background state vectors.
!
        DO ng=1,ngrids
          inprec=lini
          CALL get_state (ng, inlm, 2, ini(ng), inprec, lini)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
 
          inprec=lbck
          CALL get_state (ng, inlm, 9, ini(ng), inprec, lbck)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
!
!  Convert increment vector, deltaV, from minimization space (v-space)
!  to model space (x-space):
!
!     deltaX = B^(1/2) deltaV
!  or
!     deltaX = W^(1/2) L^(1/2) G S
!
!  First, convolve estimated increment vector (v-space) by with the
!  tangent linear diffusion operator, W^(1/2) L^(1/2) G.  Second,
!  multiply result by the background-error standard deviation, S.
!
        lcon=ltlm2
        DO ng=1,ngrids
          DO tile=first_tile(ng),last_tile(ng),+1
            CALL tl_convolution (ng, tile, lcon, lweak, 2)
            CALL tl_variability (ng, tile, lcon, lweak)
# ifdef BALANCE_OPERATOR
            CALL tl_balance (ng, tile, lini, lcon)
# endif
          END DO
        END DO
!
!  Write out trial x-space (convolved) TLM initial conditions, currently
!  in time index Lcon, into record 1 of ITL(ng)%name NetCDF file.
!
        DO ng=1,ngrids
# ifdef DISTRIBUTE
          CALL tl_wrt_ini (ng, myrank, lcon, rec1)
# else
          CALL tl_wrt_ini (ng, -1, lcon, rec1)
# endif
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
!
!-----------------------------------------------------------------------
!  Update counters.
!-----------------------------------------------------------------------
!
        DO ng=1,ngrids
          lsav=lnew(ng)
          lnew(ng)=lold(ng)
          lold(ng)=lsav
          nrun=nrun+1
        END DO
!
      END DO inner_loop
!
!  Turn of switch to write cost functions in the DAV NetCDF file. They
!  are written in calls to "tl_wrt_ini" only inside the inner loops.
!
      DO ng=1,ngrids
        lwrtcost(ng)=.false.
      END DO
!
!  Close adjoint NetCDF file.
!
      sourcefile=myfile
      DO ng=1,ngrids
        CALL close_file (ng, iadm, adm(ng))
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  Close Hessian NetCDF file.
!
      DO ng=1,ngrids
        CALL close_file (ng, iadm, hss(ng))
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
 
# ifdef PROFILE
!
!  Stop profile clock
!
      DO ng=1,ngrids
        DO thread=thread_range
          CALL wclock_off (ng, itlm, 87, __line__, myfile)
        END DO
      END DO
# endif
!
 10   FORMAT (a,'_outer',i0,'.nc')
 20   FORMAT (a,'_member',i3.3,'.nc')
 30   FORMAT (/,1x,a,1x,'ROMS: started time-stepping:',                 &
     &        ' (Grid: ',i0,', Outer: ',i2.2,', Inner: ',i3.3,          &
              ', TimeSteps: ',i0,' - ',i0,')',/)
 40   FORMAT (/,' (',i3.3,',',i3.3,'): TLM Cost Jb, J  = ',             &
     &        1p,e17.10,0p,1x,1p,e17.10,0p,t68,1p,e11.4,' %')
 50   FORMAT (/,'>(',i3.3,',',i3.3,'): NLM Cost     J  = ',             &
     &        18x,1p,e17.10,0p)
 60   FORMAT (' (',i3.3,',',i3.3,'): NLM Cost     J  = ',               &
     &        18x,1p,e17.10,0p,t69,a)
 70   FORMAT (/,1x,'(',i3.3,',',i3.3,'): Optimality (2*J/Nobs) = ',     &
     &        1p,e17.10,/)
!
      RETURN
      END SUBROUTINE increment
!
      SUBROUTINE analysis (my_outer, RunInterval)
!
!=======================================================================
!                                                                      !
!  This routine computes 4D-Var data assimilation analysis, Xa. The    !
!  nonlinear model initial conditions are computed by adding the       !
!  4D-Var increments to the current background:  Xa = Xb + dXa.        !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     my_outer        Outer-loop counter (integer)                     !
!     RunInterval     NLM kernel time stepping window (seconds)        !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations
!
      logical :: lweak = .false.
!
      integer, intent(in) :: my_outer
!
      real(dp), intent(in) :: runinterval
!
!  Local variable declarations.
!
      integer :: ng, tile
      integer :: fcount, lcon, nrec
      integer :: inprec, outrec
# ifdef PROFILE
      integer :: thread
# endif
!
      character (len=*), parameter :: myfile =                          &
     &  __FILE__//", analysis"
!
      sourcefile=myfile
!
!=======================================================================
!  Compute new nonlinear initial conditions by adding minimization
!  increment to previous outer loop initial conditions:
!
!         Xi(outer+1) = Xi(outer) + deltaX(Lcon)
!
!=======================================================================
 
# ifdef PROFILE
!
!  Start profile clock.
!
      DO ng=1,ngrids
        DO thread=thread_range
          CALL wclock_on (ng, inlm, 88, __line__, myfile)
        END DO
      END DO
# endif
!
!  Clear nonlinear state variables.
!
      DO ng=1,ngrids
        DO tile=first_tile(ng),last_tile(ng),+1
          CALL initialize_ocean (ng, tile, inlm)
        END DO
      END DO
 
# ifdef SPLIT_4DVAR
!
!-----------------------------------------------------------------------
!  If split 4D-Var algorithm, set several variables that computed or
!  assigned in other 4D-Var phase executable.
!-----------------------------------------------------------------------
!
!  Open nonlinear model initial conditions NetCDF file (INI struc) and
!  inquire about its variable IDs.
!
      DO ng=1,ngrids
        ldefini(ng)=.false.
        CALL def_ini (ng)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  Open tangent linear model initial conditions NetCDF file (ITL struc)
!  and inquire about its variable IDs.
!
      DO ng=1,ngrids
        ldefitl(ng)=.false.
        CALL tl_def_ini (ng)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  Open 4D-Var NetCDF file (DAV struc) and inquire about its variables.
!  It is used in "tl_wrt_ini" to write out observation and background
!  cost functions.
!
      DO ng=1,ngrids
        ldefmod(ng)=.false.
        CALL def_mod (ng)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        nrec=dav(ng)%Rindex
      END DO
!
!  Set Nrun>1, set Nrun couter. The counter is only allow to increase
!  in the "increment" phase.
!
      nrun=1+(my_outer-1)*(ninner+1)
      erstr=nrun
 
#  ifdef MASKING
!
!  Set internal mask arrays to process I/O NetCDF files.
!
      DO ng=1,ngrids
       DO tile=first_tile(ng),last_tile(ng),+1
          CALL set_masks (ng, tile, inlm)
        END DO
      END DO
#  endif
# endif
!
!-----------------------------------------------------------------------
!  Compute nonlinear model initial from the 4D-Var analysis.
!-----------------------------------------------------------------------
!
!  In order to use the correct fields, the model time indices are set
!  to Lini.
!
!  The appropriate TLM correction for the NLM model resides in record 1
!  of the ITL file.
!
      DO ng=1,ngrids
        kstp(ng)=lini
# ifdef SOLVE3D
        nstp(ng)=lini
# endif
        inprec=lini
        CALL get_state (ng, inlm, 1, ini(ng), inprec, lini)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
        inprec=ltlm1
        CALL get_state (ng, itlm, 1, itl(ng), inprec, ltlm1)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
        DO tile=first_tile(ng),last_tile(ng),+1
          CALL ini_adjust (ng, tile, ltlm1, lini)
!!        CALL ini_fields (ng, tile, iNLM)
        END DO
      END DO
!
!  Write out new nonlinear model initial conditions into record Lini
!  of INI(ng)%name.
!
      DO ng=1,ngrids
        fcount=ini(ng)%load
        ini(ng)%Nrec(fcount)=1
        outrec=lini
# ifdef DISTRIBUTE
        CALL wrt_ini (ng, myrank, lini, outrec)
# else
        CALL wrt_ini (ng, -1, lini, outrec)
# endif
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  Gather the v-space increments from the final inner-loop and
!  save in record 4 of the ITL file. The current v-space increment
!  is in record 3 and the sum so far is in record 4.
!
      DO ng=1,ngrids
        inprec=rec3
        CALL get_state (ng, itlm, 8, itl(ng), inprec, ltlm1)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
        inprec=rec4
        CALL get_state (ng, itlm, 8, itl(ng), inprec, ltlm2)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
        DO tile=first_tile(ng),last_tile(ng),+1
          CALL sum_grad (ng, tile, ltlm1, ltlm2)
        END DO
      END DO
!
! Write the current sum into record 4 of the ITL file.
!
      DO ng=1,ngrids
# ifdef DISTRIBUTE
        CALL tl_wrt_ini (ng, myrank, ltlm2, rec4)
# else
        CALL tl_wrt_ini (ng, -1, ltlm2, rec4)
# endif
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
 
# if defined ADJUST_STFLUX   || defined ADJUST_WSTRESS || \
     defined adjust_boundary
!
!  Set index containing the surface forcing increments used the run
!  the nonlinear model in the outer loop and read the forcing
!  increments. For bulk fluxes, we read Rec1 because the stress
!  fluxes change by virtue of the changing initial conditions.
!  When not using bulk fluxes, we read Rec4 because the background
!  stress and flux is prescribed by input files which are not
!  overwritten so we need to correct the background using the
!  sum of the increments from all previous outer-loops.
!  If using Rec4 we need to convert from v-space to x-space
!  by applying the convolution.
!  Note that Lfinp=Lbinp so the the forcing and boundary
!  adjustments are both processsed correctly.
#  ifdef BALANCE_OPERATOR
!  Currently, We do not need the call to tl_balance below, but we
!  might later if we impose a balance constraint on the wind stress
!  corrections.
#  endif
!
!  AMM: CHECK WHAT HAPPENS WITH SECONDARY PRECONDITIONING.
!
      DO ng=1,ngrids
        lfinp(ng)=ltlm1
#  if defined BULK_FLUXES && !defined FORWARD_FLUXES
        inprec=rec1
        CALL get_state (ng, itlm, 1, itl(ng), inprec, lfinp(ng))
#  endif
#  if defined FORWARD_FLUXES || !defined BULK_FLUXES
        inprec=rec4
        CALL get_state (ng, itlm, 1, itl(ng), rec4, lfinp(ng))
        lcon=lfinp(ng)
!
        DO tile=first_tile(ng),last_tile(ng),+1
          CALL tl_convolution (ng, tile, lcon, lweak, 2)
          CALL tl_variability (ng, tile, lcon, lweak)
#   ifdef BALANCE_OPERATOR
!!        CALL tl_balance (ng, tile, Lini, Lcon)
#   endif
        END DO
#  endif
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
 
#  ifdef SPLIT_4DVAR
!
!  If split 4D-Var, write out surface forcing and lateral boundary
!  condition increments (X-space) needed for the nonlinear model into
!  Rec5.
!
      DO ng=1,ngrids
#   ifdef DISTRIBUTE
        CALL tl_wrt_ini (ng, myrank, lfinp(ng), rec5)
#   else
        CALL tl_wrt_ini (ng, -1, lfinp(ng), rec5)
#   endif
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
#  endif
# endif
!
!  Clear tangent linear state variables.
!
      DO ng=1,ngrids
        DO tile=first_tile(ng),last_tile(ng),+1
          CALL initialize_ocean (ng, tile, itlm)
        END DO
      END DO
!
!  Close current forward NetCDF file.
!
      sourcefile=myfile
      DO ng=1,ngrids
        CALL close_file (ng, inlm, fwd(ng))
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
 
# ifdef PROFILE
!
!  Stop profile clock
!
      DO ng=1,ngrids
        DO thread=thread_range
          CALL wclock_off (ng, inlm, 88, __line__, myfile)
        END DO
      END DO
# endif
!
      RETURN
      END SUBROUTINE analysis
!
      SUBROUTINE posterior_analysis_initialize
!
!=======================================================================
!                                                                      !
!  This routine initializes the nonlinear kernel with the 4D-Var new   !
!  state estimate Xa = Xb + dXa.  It is separated from the 'analysis'  !
!  4D-Var phase in ESM coupling applications that use generic methods  !
!  for 'initialize', 'run', and 'finalize'.                            !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     my_outer        Outer-loop counter (integer)                     !
!                                                                      !
!=======================================================================
!
!  Local variable declarations.
!
      integer :: i, ifile, lstr, ng, tile
      integer :: fcount, inprec
# ifdef PROFILE
      integer :: thread
# endif
!
      character (len=*), parameter :: myfile =                          &
     &  __FILE__//", posterior_analysis_initialize"
!
      sourcefile=myfile
!
!-----------------------------------------------------------------------
!  Initialize nonlinear model kernel with new 4D-Var state estimate.
!-----------------------------------------------------------------------
 
# ifdef PROFILE
!
!  Start profile clock.
!
      DO ng=1,ngrids
        DO thread=thread_range
          CALL wclock_on (ng, inlm, 88, __line__, myfile)
        END DO
      END DO
# endif
!
!  Clear nonlinear mixing arrays.
!
      DO ng=1,ngrids
        DO tile=first_tile(ng),last_tile(ng),+1
          CALL initialize_mixing (ng, tile, inlm)
        END DO
      END DO
 
# ifdef SPLIT_4DVAR
!
!-----------------------------------------------------------------------
!  If split 4D-Var algorithm, set several variables that computed or
!  assigned in other 4D-Var phase executable.
!-----------------------------------------------------------------------
!
      outer=nouter
      inner=ninner
!
!  Set Nrun>1, to read in surface forcing and open boundary conditions
!  increments in "initial", if appropriate.
!
      nrun=1+nouter*(ninner+1)
!
!  Set ERstr=Nrun, to set the open boundary condition (OBC_time) and
!  surface forcing (SF_time) adjustment times, if needed.
!
      erstr=nrun
!
!  Open Nonlinear model initial conditions NetCDF file (INI struc) and
!  inquire about its variable IDs.
!
      DO ng=1,ngrids
        ldefini(ng)=.false.
        CALL def_ini (ng)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  Open 4D-Var NetCDF file (DAV struc) and inquire about its variables.
!
      DO ng=1,ngrids
        ldefmod(ng)=.false.
        CALL def_mod (ng)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        havenlmod(ng)=.false.                     ! do not read NLmodVal
      END DO
!
!  In the split 4D-Var algorithm, we need to read the global observation
!  screening and quality control scale ObsScaleGlobal ("obs_scale") that
!  it is written in the "background" phase. Such data is in memory in
!  the unsplit algorithm.  Recall that in I4D-Var, observation variables
!  are read and load into the arrays elements 1:Nobs(ng) for each survey
!  time.  That is, only the values needed are read.
!
!  HGA: What to do in 4D-Var with nested grids?
!
      ng=1
      SELECT CASE (dav(ng)%IOtype)
        CASE (io_nf90)
          CALL netcdf_get_fvar (ng, itlm, dav(ng)%name,                 &
     &                          vname(1,idobss), obsscaleglobal,        &
     &                          ncid = dav(ng)%ncid)
 
#  if defined PIO_LIB && defined DISTRIBUTE
        CASE (io_pio)
          CALL pio_netcdf_get_fvar (ng, itlm, dav(ng)%name,             &
     &                              vname(1,idobss), obsscaleglobal,    &
     &                              piofile = dav(ng)%pioFile)
#  endif
      END SELECT
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!  Read initial nonlinear cost function values from DAV file and load it
!  into CostNorm, its values are used for reporting normalized values.
!
      DO ng=1,ngrids
        SELECT CASE (dav(ng)%IOtype)
          CASE (io_nf90)
            CALL netcdf_get_fvar (ng, inlm, dav(ng)%name,               &
     &                            'NLcost_function',                    &
     &                            fourdvar(ng)%CostNorm(0:),            &
     &                            ncid = dav(ng)%ncid,                  &
     &                            start = (/1,1/),                      &
     &                            total = (/nobsvar(ng)+1,1/))
 
#  if defined PIO_LIB && defined DISTRIBUTE
          CASE (io_pio)
            CALL pio_netcdf_get_fvar (ng, inlm, dav(ng)%name,           &
     &                                'NLcost_function',                &
     &                                fourdvar(ng)%CostNorm(0:),        &
     &                                piofile = dav(ng)%pioFile,        &
     &                                start = (/1,1/),                  &
     &                                total = (/nobsvar(ng)+1,1/))
#  endif
        END SELECT
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
 
# if defined ADJUST_STFLUX   || defined ADJUST_WSTRESS || \
     defined adjust_boundary
!
!  If split 4D-Var, read in surface forcing and or lateral boundary
!  increments (X-space) from ITL file Rec5.
!
      DO ng=1,ngrids
        ldefitl(ng)=.false.
        CALL tl_def_ini (ng)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
        inprec=rec5
        CALL get_state (ng, itlm, 1, itl(ng), inprec, ltlm1)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  If split 4D-Var, reset reset surface forcing and lateral boundary
!  output time indices to LADJ2 since they are changed in the inner
!  loops.
!
      DO ng=1,ngrids
        lfout(ng)=ladj2
#   ifdef ADJUST_BOUNDARY
        lbout(ng)=ladj2
#   endif
      END DO
#  endif
 
#  ifdef FORWARD_FLUXES
!
!  If not first NLM run, set BLK structure to the previous quicksave
!  trajectory.  There is a logic in "get_data" that reads from BLK.
!  (HGA: This probably legacy code that it is no longer needed)
!
      DO ng=1,ngrids
        WRITE (qck(ng)%name,10) trim(qck(ng)%head), nouter-1
        lstr=len_trim(qck(ng)%name)
        qck(ng)%base=qck(ng)%name(1:lstr-3)
      END DO
!
      CALL edit_multifile ('QCK2BLK')
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
#  endif
# endif
!
!-----------------------------------------------------------------------
!  Initialize nonlinear model.
!-----------------------------------------------------------------------
!
!  Set nonlinear output history file name. Create a basic state file
!  for each outher loop. Notice that the LreadBLK and LreadFWD switches
!  are turned off to suppress processing of the structures when
!  "check_multifile" during nonlinear model execution.
!
      DO ng=1,ngrids
        idefhis(ng)=-1
        ldefhis(ng)=.true.
        lwrthis(ng)=.true.
# ifdef FORWARD_FLUXES
        lreadblk(ng)=.false.
# endif
        lreadfwd(ng)=.false.
        his(ng)%Rindex=0
        fcount=his(ng)%load
        his(ng)%Nrec(fcount)=0
        WRITE (his(ng)%name,10) trim(fwd(ng)%head), nouter
        lstr=len_trim(his(ng)%name)
        his(ng)%base=his(ng)%name(1:lstr-3)
      END DO
!
!  Set the nonlinear model output quicksave-history file for the
!  posterior analysis trajectory. Notice that the LreadBLK switch
!  is turned off to suppress processing of the structure in
!  "check_multifile" during nonlinear model execution.
!
      DO ng=1,ngrids
        idefqck(ng)=-1
        ldefqck(ng)=.true.
        lwrtqck(ng)=.true.
# ifdef FORWARD_FLUXES
        lreadblk(ng)=.false.
# endif
        WRITE (qck(ng)%name,10) trim(qck(ng)%head), nouter
        lstr=len_trim(qck(ng)%name)
        qck(ng)%base=qck(ng)%name(1:lstr-3)
      END DO
!
!  Initialize nonlinear model with estimated initial conditions.  Reset
!  the value of INI(ng)%Rindex, which is needed in "initial" to the
!  4D-Var analysis record.
!
      DO ng=1,ngrids
        wrtnlmod(ng)=.true.
        wrttlmod(ng)=.false.
        wrtmisfit(ng)=.false.
        rst(ng)%Rindex=0
        fcount=rst(ng)%load
        rst(ng)%Nrec(fcount)=0
        ini(ng)%Rindex=lini
      END DO
!
      CALL initial
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!  Clear NLobsCost. Activate switch to write out final misfit between
!  model and observations.
!
      DO ng=1,ngrids
        DO i=0,nobsvar(ng)
          fourdvar(ng)%NLobsCost(i)=0.0_r8
        END DO
        wrtmisfit(ng)=.true.
      END DO
 
# ifdef PROFILE
!
!  Stop profile clock
!
      DO ng=1,ngrids
        DO thread=thread_range
          CALL wclock_off (ng, inlm, 88, __line__, myfile)
        END DO
      END DO
# endif
!
 10   FORMAT (a,'_outer',i0,'.nc')
!
      RETURN
      END SUBROUTINE posterior_analysis_initialize
!
      SUBROUTINE posterior_analysis (RunInterval)
!
!=======================================================================
!                                                                      !
!  This routine initialize the NLM with estimated 4D-Var state and     !
!  interpolates solution at observation locations for posterior        !
!  analysis.                                                           !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     RunInterval     NLM kernel time stepping window (seconds)        !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations
!
      real(dp), intent(in) :: runinterval
!
!  Local variable declarations.
!
      logical :: donestepping
!
      integer :: i, lstr, ng
# ifdef PROFILE
      integer :: thread
# endif
# if defined MODEL_COUPLING && !defined MCT_LIB
      integer :: nstrstep, nendstep, extra
!
      real(dp) :: endtime, nexttime
# endif
!
      character (len=*), parameter :: myfile =                          &
     &  __FILE__//", posterior_analysis"
!
      sourcefile=myfile
 
# if !(defined MODEL_COUPLING && defined ESMF_LIB)
!
!-----------------------------------------------------------------------
!  Set nonlinear model initial conditions.
!-----------------------------------------------------------------------
!
      CALL posterior_analysis_initialize
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
# endif
!
!-----------------------------------------------------------------------
!  Run nonlinear model. Interpolate nonlinear model to observation
!  locations.
# if defined MODEL_COUPLING && !defined MCT_LIB
!  Since the ROMS kernel has a delayed output and line diagnostics by
!  one timestep, subtact an extra value to the report of starting and
!  ending timestep for clarity. Usually, the model coupling interval
!  is of the same size as ROMS timestep.
# endif
!-----------------------------------------------------------------------
 
# ifdef PROFILE
!
!  Start profile clock.
!
      DO ng=1,ngrids
        DO thread=thread_range
          CALL wclock_on (ng, inlm, 88, __line__, myfile)
        END DO
      END DO
# endif
!
!  Initialize various parameters and switches.
!
      myruninterval=runinterval
!
      DO ng=1,ngrids
# ifdef AVERAGES
        idefavg(ng)=-1
        ldefavg(ng)=.true.
        lwrtavg(ng)=.true.
        WRITE (avg(ng)%name,10) trim(avg(ng)%head), outer
        lstr=len_trim(avg(ng)%name)
        avg(ng)%base=avg(ng)%name(1:lstr-3)
# endif
# ifdef DIAGNOSTICS
        idefdia(ng)=-1
        ldefdia(ng)=.true.
        lwrtdia(ng)=.true.
        WRITE (dia(ng)%name,10) trim(dia(ng)%head), outer
        lstr=len_trim(dia(ng)%name)
        dia(ng)%base=dia(ng)%name(1:lstr-3)
# endif
# if defined MODEL_COUPLING && !defined MCT_LIB
!
        nexttime=time(ng)+runinterval
        endtime=initime(ng)+(ntimes(ng)-1)*dt(ng)
        IF ((nexttime.eq.endtime).and.(ng.eq.1)) THEN
          extra=0                                   ! last time interval
        ELSE
          extra=1
        END IF
        step_counter(ng)=0
        nstrstep=iic(ng)
        nendstep=nstrstep+int((myruninterval)/dt(ng))-extra
        IF (master) WRITE (stdout,20) 'NL', ng, nstrstep, nendstep
# else
        IF (master) WRITE (stdout,20) 'NL', ng, ntstart(ng), ntend(ng)
# endif
      END DO
!
# ifdef SOLVE3D
      CALL main3d (runinterval)
# else
      CALL main2d (runinterval)
# endif
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!-----------------------------------------------------------------------
!  If completed stepping, write out and report cost function.
# if defined MODEL_COUPLING && !defined MCT_LIB
!  In coupled applications, RunInterval is much less than ntimes*dt,
!  so we need to wait until the last coupling interval is finished.
!  Otherwise, the control switches will be turned off prematurely.
# endif
!-----------------------------------------------------------------------
!
# if defined MODEL_COUPLING && !defined MCT_LIB
      IF (nendstep.eq.ntend(1)) THEN
        donestepping=.true.
      ELSE
        donestepping=.false.
      END IF
# else
      donestepping=.true.
# endif
!
      IF (donestepping) THEN
!
!  Write out nonlinear model final misfit cost function into
!  DAV(ng)%name NetCDF file. Notice that it is written in the
!  Nouter+1 record.
!
        sourcefile=myfile
        DO ng=1,ngrids
          SELECT CASE (dav(ng)%IOtype)
            CASE (io_nf90)
              CALL netcdf_put_fvar (ng, inlm, dav(ng)%name,             &
     &                              'NLcost_function',                  &
     &                              fourdvar(ng)%NLobsCost(0:),         &
     &                              (/1,nouter+1/),                     &
     &                              (/nobsvar(ng)+1,1/),                &
     &                              ncid = dav(ng)%ncid)
 
# if defined PIO_LIB && defined DISTRIBUTE
            CASE (io_pio)
              CALL pio_netcdf_put_fvar (ng, inlm, dav(ng)%name,         &
     &                                  'NLcost_function',              &
     &                                  fourdvar(ng)%NLobsCost(0:),     &
     &                                  (/1,nouter+1/),                 &
     &                                  (/nobsvar(ng)+1,1/),            &
     &                                  piofile = dav(ng)%pioFile)
# endif
          END SELECT
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
!
!  Report the final value of the nonlinear model misfit cost function.
!
        IF (master) THEN
          DO ng=1,ngrids
            DO i=0,nobsvar(ng)
              IF (fourdvar(ng)%NLobsCost(i).ne.0.0_r8) THEN
                IF (i.eq.0) THEN
                  WRITE (stdout,30) outer, inner,                       &
     &                              fourdvar(ng)%NLobsCost(i)/          &
     &                              fourdvar(ng)%CostNorm(i)
                ELSE
                  WRITE (stdout,40) outer, inner,                       &
     &                              fourdvar(ng)%NLobsCost(i)/          &
     &                              fourdvar(ng)%CostNorm(i),           &
     &                              trim(obsname(i))
                END IF
              END IF
            END DO
          END DO
        END IF
!
!  Done.  Set history file ID to closed state since we manipulated
!  its indices with the forward file ID which was closed above.
!
        DO ng=1,ngrids
          his(ng)%ncid=-1
        END DO
      END IF
 
# ifdef PROFILE
!
!  Stop profile clock
!
      DO ng=1,ngrids
        DO thread=thread_range
          CALL wclock_off (ng, inlm, 88, __line__, myfile)
        END DO
      END DO
# endif
!
 10   FORMAT (a,'_outer',i0,'.nc')
 20   FORMAT (/,1x,a,1x,'ROMS: started time-stepping:',                 &
     &        ' (Grid: ',i0,', TimeSteps: ',i0,' - ',i0,')',/)
 30   FORMAT (/,'>(',i3.3,',',i3.3,'): NLM Cost     J  = ',             &
     &        18x,1p,e17.10,0p)
 40   FORMAT (' (',i3.3,',',i3.3,'): NLM Cost     J  = ',               &
     &        18x,1p,e17.10,0p,t69,a)
!
      RETURN
      END SUBROUTINE posterior_analysis
!
      SUBROUTINE prior_error (ng)
!
!=======================================================================
!                                                                      !
!  This routine processes background prior error covariance standard   !
!  deviations and normalization coefficients.                          !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng              Nested grid number                               !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations
!
      integer, intent(in) :: ng
!
!  Local variable declarations.
!
      integer :: tile
      integer :: nrmrec, stdrec, tindex
!
      character (len=*), parameter :: myfile =                          &
     &  __FILE__//", prior_error"
!
      sourcefile=myfile
!
!-----------------------------------------------------------------------
!  Set application grid, metrics, and associated variables and
!  parameters.
!-----------------------------------------------------------------------
!
!  The ROMS application grid configuration is done once. It is usually
!  done in the "initial" kernel routine. However, since we are calling
!  the "normalization" routine here, we need several grid variables and
!  parameter.  Also, if reading only water points, we need to know the
!  land/sea mask arrays to unpack.
!
      IF (setgridconfig(ng)) THEN
        CALL set_grid (ng, inlm)
      END IF
!
!-----------------------------------------------------------------------
!  Read in standard deviation factors for error covariance.
!-----------------------------------------------------------------------
!
      IF (lgetstd) THEN
!
!  Initial conditions standard deviation. They are loaded in Tindex=1
!  of the e_var(...,Tindex) state variables.
!
        IF (lreadstd(ng)) THEN
          stdrec=1
          tindex=1
# ifdef STD_MODEL
          CALL get_state (ng, 10, 10, std(5,ng), stdrec, tindex)
# else
          CALL get_state (ng, 10, 10, std(1,ng), stdrec, tindex)
# endif
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END IF
 
# ifdef ADJUST_BOUNDARY
!
!  Open boundary conditions standard deviation.
!
        stdrec=1
        tindex=1
        CALL get_state (ng, 12, 12, std(3,ng), stdrec, tindex)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
# endif
 
# if defined ADJUST_WSTRESS || defined ADJUST_STFLUX
!
!  Surface forcing standard deviation.
!
        stdrec=1
        tindex=1
        CALL get_state (ng, 13, 13, std(4,ng), stdrec, tindex)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
# endif
 
# ifdef STD_MODEL
!
!  If computing the standard deviation (STD) directly from the
!  background (prior) field as an alternative to climatological
!  read from the input NetCDF file, define the output STD NetCDF
!  file.
!
        IF (ldefstd(ng)) THEN
          CALL def_std (ng)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END IF
# endif
      END IF
!
!-----------------------------------------------------------------------
!  Error covariance normalization coefficients.
!-----------------------------------------------------------------------
!
      IF (lgetnrm) THEN
!
!  Compute or read in background-error covariance normalization factors.
!  If computing, write out factors to NetCDF. This is an expensive
!  computation that needs to be computed only once for a particular
!  application grid.
!
        IF (any(lwrtnrm(:,ng))) THEN
          CALL def_norm (ng, inlm, 1)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
 
# ifdef ADJUST_BOUNDARY
          CALL def_norm (ng, inlm, 3)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
# endif
 
# if defined ADJUST_WSTRESS || defined ADJUST_STFLUX
          CALL def_norm (ng, inlm, 4)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
# endif
!
          DO tile=first_tile(ng),last_tile(ng),+1
            CALL normalization (ng, tile, 2)
          END DO
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          ldefnrm(1:4,ng)=.false.
          lwrtnrm(1:4,ng)=.false.
 
        ELSE
 
          nrmrec=1
          CALL get_state (ng, 14, 14, nrm(1,ng), nrmrec, 1)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
 
# ifdef ADJUST_BOUNDARY
          CALL get_state (ng, 16, 16, nrm(3,ng), nrmrec, 1)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
# endif
 
# if defined ADJUST_WSTRESS || defined ADJUST_STFLUX
          CALL get_state (ng, 17, 17, nrm(4,ng), nrmrec, 1)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
# endif
 
        END IF
      END IF
!
      RETURN
      END SUBROUTINE prior_error
#endif
      END MODULE i4dvar_mod