r4dvar_mod Module Reference

Functions/Subroutines
subroutine, public	background (my_outer, runinterval)
subroutine, public	increment (my_outer, runinterval)
subroutine, public	analysis (my_outer, runinterval)
subroutine, public	prior_error (ng)
subroutine, public	posterior_error (runinterval)

Variables
logical	ldone
integer	lini = 1
integer	lbck = 2
integer	rec1 = 1
integer	rec2 = 2

Function/Subroutine Documentation

analysis()

subroutine, public r4dvar_mod::analysis	(	integer, intent(in)	my_outer,
		real(dp), intent(in)	runinterval )

Definition at line 1383 of file r4dvar.F.

!
!=======================================================================
!                                                                      !
!  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
!
      integer, intent(in) :: my_outer
!
      real(dp), intent(in) :: RunInterval
!
!  Local variable declarations.
!
      integer :: i, ifile, lstr, ng
      integer :: InpRec
# ifdef PROFILE
      integer :: thread
# endif
# ifdef SPLIT_4DVAR
!
      real(dp) :: stime
# endif
!
      character (len=10) :: suffix
      character (len=20) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", analysis"
!
      sourcefile=myfile
!
!-----------------------------------------------------------------------
!  Run representer model and compute a "new estimate" of the state
!  trajectory, X_n(t).
!-----------------------------------------------------------------------
 
# 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
 
# ifdef SPLIT_4DVAR
!
!-----------------------------------------------------------------------
!  If split 4D-Var algorithm, set several variables that computed or
!  assigned in other 4D-Var phase executable.
!-----------------------------------------------------------------------
!
!  Set Nrun>1, to read in surface forcing and open boundary conditions
!  increments in "initial", if appropriate.
!
      nrun=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 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
      END DO
!
!  In the split 4D-Var algorithm, we need to read the values of ObsScale
!  computed in the background phase from the DAV NetCDF file. Such data
!  is in memory in the unsplit algorithm.
!
!  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, irpm, dav(ng)%name,                 &
     &                          vname(1,idobss), obsscale,              &
     &                          ncid = dav(ng)%ncid)
 
#  if defined PIO_LIB && defined DISTRIBUTE
        CASE (io_pio)
          CALL pio_netcdf_get_fvar (ng, irpm, dav(ng)%name,             &
     &                              vname(1,idobss), obsscale,          &
     &                              piofile = dav(ng)%pioFile)
#  endif
      END SELECT
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!  Set nonlinear output history file to be used as the basic state
!  trajectory. The nonlinear model is run outside of the outer loops,
!  so we need outer=0 when updating HIS structure.
!
      DO ng=1,ngrids
        WRITE (his(ng)%name,10) trim(fwd(ng)%head), 0
        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
!
!  Read in 4D-Var starting time (sec) from forward trajectory NetCDF
!  file and set INItime. The starting time is 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, irpm, 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, irpm, 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
!
!  If outer>1, set previous outer loop representer model file.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          WRITE (tlm(ng)%name,10) trim(fwd(ng)%head), my_outer-1
          lstr=len_trim(tlm(ng)%name)
          tlm(ng)%base=tlm(ng)%name(1:lstr-3)
        END DO
      END IF
!
!  Set basic state trajectory to either Nonlinear model (outer=1) or
!  previous outer loop representer model (outer>1). 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.
!
      IF (my_outer.eq.1) THEN
        CALL edit_multifile ('HIS2FWD')
      ELSE
        CALL edit_multifile ('TLM2FWD')
      END IF
      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.
      END DO
#  endif
# endif
!
!-----------------------------------------------------------------------
!  Run representer model with the new analysis initial conditions
!  cpmputed in the "increment" phase.
!-----------------------------------------------------------------------
!
!  Set new basic state trajectory for next outer loop.
!
      DO ng=1,ngrids
        ideftlm(ng)=-1
        ldeftlm(ng)=.true.
        lwrttlm(ng)=.true.
        wrtnlmod(ng)=.false.
        wrttlmod(ng)=.true.
        wrtrpmod(ng)=.true.
        WRITE (tlm(ng)%name,10) trim(fwd(ng)%head), my_outer
        lstr=len_trim(tlm(ng)%name)
        tlm(ng)%base=tlm(ng)%name(1:lstr-3)
      END DO
!
!  If weak constraint, the impulses are time-interpolated at each
!  time-steps.
!
      DO ng=1,ngrids
        IF (frcrec(ng).gt.3) THEN
          frequentimpulse(ng)=.true.
        END IF
      END DO
!
!  Initialize representer model IRP(ng)%name file, record Rec2.
!
      DO ng=1,ngrids
# ifdef DATALESS_LOOPS
        irp(ng)%Rindex=rec1
# else
        irp(ng)%Rindex=rec2
# endif
        CALL rp_initial (ng)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  Activate switch to write out final misfit between model and
!  observations.
!
      IF (my_outer.eq.nouter) THEN
        DO ng=1,ngrids
          wrtmisfit(ng)=.true.
        END DO
      END IF
!
!  Run representer model using previous linearized trajectory, X_n-1, as
!  basic state and forced with convolved adjoint trajectory impulses.
!
      DO ng=1,ngrids
# ifdef RP_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
        IF (master) THEN
          WRITE (stdout,20) 'RP', ng, my_outer, ninner,                 &
     &                      ntstart(ng), ntend(ng)
        END IF
      END DO
!
# ifdef SOLVE3D
      CALL rp_main3d (runinterval)
# else
      CALL rp_main2d (runinterval)
# endif
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
# ifdef RP_AVERAGES
      DO ng=1,ngrids
        ldefavg(ng)=.false.
        lwrtavg(ng)=.false.
      END DO
# endif
!
!  Report data penalty function.
!
      DO ng=1,ngrids
        IF (master) THEN
          DO i=0,nstatevar(ng)
            IF (i.eq.0) THEN
              string='Total'
            ELSE
              string=vname(1,idsvar(i))
            END IF
            IF (fourdvar(ng)%DataPenalty(i).ne.0.0_r8) THEN
              WRITE (stdout,30) my_outer, ninner, 'RPM',                &
     &                          fourdvar(ng)%DataPenalty(i),            &
     &                          trim(string)
# ifdef DATALESS_LOOPS
              WRITE (stdout,30) my_outer, ninner, 'NLM',                &
     &                          fourdvar(ng)%NLPenalty(i),              &
     &                          trim(string)
# endif
            END IF
          END DO
        END IF
      END DO
!
!  Write out final data penalty function to NetCDF file.
!
      sourcefile=myfile
      DO ng=1,ngrids
        SELECT CASE (dav(ng)%IOtype)
          CASE (io_nf90)
            CALL netcdf_put_fvar (ng, irpm, dav(ng)%name,               &
     &                            'RP_fDataPenalty',                    &
     &                            fourdvar(ng)%DataPenalty(0:),         &
     &                            (/1,my_outer/),                       &
     &                            (/nstatevar(ng)+1,1/),                &
     &                            ncid = dav(ng)%ncid)
 
# if defined PIO_LIB && defined DISTRIBUTE
          CASE (io_pio)
            CALL pio_netcdf_put_fvar (ng, irpm, dav(ng)%name,           &
     &                                'RP_fDataPenalty',                &
     &                                fourdvar(ng)%DataPenalty(0:),     &
     &                                (/1,my_outer/),                   &
     &                                (/nstatevar(ng)+1,1/),            &
     &                                piofile = dav(ng)%pioFile)
# endif
        END SELECT
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  Clean array before next run of RP model.
!
      DO ng=1,ngrids
        fourdvar(ng)%DataPenalty=0.0_r8
# ifdef DATALESS_LOOPS
        fourdvar(ng)%NLPenalty=0.0_r8
# endif
        wrtnlmod(ng)=.false.
        wrttlmod(ng)=.false.
      END DO
!
!  Close current forward NetCDF file.  If last outer loop, set history
!  file ID to closed state since we manipulated its indices with the
!  forward file ID, which it was closed.
!
      DO ng=1,ngrids
        CALL close_file (ng, irpm, fwd(ng))
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        IF (my_outer.eq.nouter) THEN
          IF (his(ng)%IOtype.eq.io_nf90) THEN
            his(ng)%ncid=-1
# if defined PIO_LIB && defined DISTRIBUTE
          ELSE IF (his(ng)%IOtype.eq.io_pio) THEN
            his(ng)%pioFile%fh=-1
# endif
          END IF
        END IF
      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')
 20   FORMAT (/,1x,a,1x,'ROMS: started time-stepping:',                 &
     &        ' (Grid: ',i0,', Outer: ',i2.2,', Inner: ',i3.3,          &
              ', TimeSteps: ',i0,' - ',i0,')',/)
 30   FORMAT (' (',i3.3,',',i3.3,'): ',a,' data penalty, Jdata = ',     &
     &        1p,e17.10,0p,t68,a)
!
      RETURN

References mod_iounits::avg, close_io_mod::close_file(), mod_iounits::dav, def_mod_mod::def_mod(), mod_scalars::dt, edit_multifile(), mod_scalars::erstr, mod_scalars::exit_flag, strings_mod::founderror(), mod_fourdvar::fourdvar, mod_scalars::frcrec, mod_scalars::frequentimpulse, mod_iounits::fwd, mod_iounits::his, mod_ncparam::idefavg, mod_ncparam::ideftlm, mod_ncparam::idobss, mod_ncparam::idsvar, mod_ncparam::idtime, mod_scalars::initime, mod_param::inlm, mod_ncparam::io_nf90, mod_ncparam::io_pio, mod_iounits::irp, mod_param::irpm, mod_scalars::ldefavg, mod_scalars::ldefmod, mod_scalars::ldeftlm, mod_scalars::lreadblk, mod_scalars::lreadfrc, mod_scalars::lreadfwd, mod_scalars::lwrtavg, mod_scalars::lwrttlm, mod_parallel::master, mod_scalars::nbrec, mod_scalars::nfrec, mod_param::ngrids, mod_scalars::ninner, mod_scalars::nobc, mod_scalars::noerror, mod_scalars::nouter, mod_scalars::nrun, mod_scalars::nsff, mod_fourdvar::nstatevar, mod_scalars::ntend, mod_scalars::ntstart, mod_scalars::obc_time, mod_fourdvar::obsscale, rec1, rec2, rp_initial(), rp_main2d(), rp_main3d(), mod_scalars::sf_time, mod_iounits::sourcefile, mod_iounits::stdout, mod_iounits::tlm, mod_ncparam::vname, wclock_off(), wclock_on(), mod_fourdvar::wrtmisfit, mod_fourdvar::wrtnlmod, mod_fourdvar::wrtrpmod, and mod_fourdvar::wrttlmod.

Here is the call graph for this function:

background()

subroutine, public r4dvar_mod::background	(	integer, intent(in)	my_outer,
		real(dp), intent(in)	runinterval )

Definition at line 157 of file r4dvar.F.

!
!=======================================================================
!                                                                      !
!  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.
!
      integer :: lstr, ng
      integer :: Fcount, Tindex
# 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
!
!-----------------------------------------------------------------------
!  Initialize and set nonlinear model initial conditions.
!-----------------------------------------------------------------------
 
# 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 the switch to gather weak constraint forcing.
!
      DO ng=1,ngrids
        wrtforce(ng)=.false.
      END DO
!
!  Initialize and set nonlinear model initial conditions.
!
      DO ng=1,ngrids
        wrtnlmod(ng)=.true.
        wrtrpmod(ng)=.false.
        wrttlmod(ng)=.false.
      END DO
!
      CALL initial
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!  Save nonlinear initial conditions (currently in time index 1,
!  background) into record "Lini" of INI(ng)%name NetCDF file. The
!  record "Lbck" becomes the background state record and the record
!  "Lini" becomes current nonlinear initial conditions.
!
      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
 
# 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.0) 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
!
!  Set nonlinear output history file as the initial basic state
!  trajectory.
!
      DO ng=1,ngrids
        ldefhis(ng)=.true.
        lwrthis(ng)=.true.
        WRITE (his(ng)%name,10) trim(fwd(ng)%head), my_outer
        lstr=len_trim(his(ng)%name)
        his(ng)%base=his(ng)%name(1:lstr-3)
      END DO
!
!  Define output 4DVAR NetCDF file containing all processed data
!  at observation locations.
!
      DO ng=1,ngrids
        ldefmod(ng)=.true.
        CALL def_mod (ng)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!-----------------------------------------------------------------------
!  Run nonlinear model and compute basic state trajectory. 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
!-----------------------------------------------------------------------
!
      myruninterval=runinterval
      IF (master) WRITE (stdout,'(1x)')
!
      DO ng=1,ngrids
# ifdef RP_AVERAGES
        idefavg(ng)=-1
        ldefavg(ng)=.false.
        lwrtavg(ng)=.false.
        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
        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
!
      DO ng=1,ngrids
        wrtnlmod(ng)=.false.
        wrtobsscale(ng)=.false.
      END DO
 
# 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

References mod_iounits::avg, def_mod_mod::def_mod(), mod_scalars::dt, mod_scalars::exit_flag, mod_parallel::first_tile, strings_mod::founderror(), mod_iounits::fwd, mod_iounits::his, mod_ncparam::idefavg, mod_scalars::iic, mod_iounits::ini, initial(), mod_scalars::initime, mod_param::inlm, mod_parallel::last_tile, mod_scalars::ldefavg, mod_scalars::ldefhis, mod_scalars::ldefmod, mod_scalars::lwrtavg, mod_scalars::lwrthis, main2d(), main3d(), mod_parallel::master, mod_parallel::myrank, mod_scalars::myruninterval, mod_param::ngrids, mod_scalars::noerror, mod_scalars::ntend, mod_scalars::ntimes, mod_scalars::ntstart, mod_iounits::sourcefile, mod_iounits::std, mod_iounits::stdout, mod_scalars::step_counter, mod_scalars::time, wclock_off(), wclock_on(), wrt_ini_mod::wrt_ini(), mod_fourdvar::wrtforce, mod_fourdvar::wrtnlmod, mod_fourdvar::wrtobsscale, mod_fourdvar::wrtrpmod, and mod_fourdvar::wrttlmod.

Here is the call graph for this function:

increment()

subroutine, public r4dvar_mod::increment	(	integer, intent(in)	my_outer,
		real(dp), intent(in)	runinterval )

Definition at line 379 of file r4dvar.F.

!
!=======================================================================
!                                                                      !
!  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)   !
!                                                                      !
!                                                                      !
!  It solves the system:                                               !
!                                                                      !
!     (R_n + Cobs) * Beta_n = h_n                                      !
!                                                                      !
!     h_n = Xo - H * X_n                                               !
!                                                                      !
!  where R_n is the representer matrix, Cobs is the observation-error  !
!  covariance, Beta_n are the representer coefficients, h_n is the     !
!  misfit between observations (Xo) and model (H * X_n), and H is      !
!  the linearized observation operator. Here, _n denotes a sequence    !
!  of estimates.                                                       !
!                                                                      !
!  The system does not need to be solved explicitly by inverting the   !
!  symmetric stabilized representer matrix, P_n:                       !
!                                                                      !
!     P_n = R_n + Cobs                                                 !
!                                                                      !
!  but by computing the action of P_n on any vector PSI, such that     !
!                                                                      !
!     P_n * PSI = R_n * PSI + Cobs * PSI                               !
!                                                                      !
!  The representer matrix is not explicitly computed but evaluated by  !
!  one integration backward of the adjoint model and one integration   !
!  forward of the tangent linear model for any forcing vector PSI.     !
!                                                                      !
!  A preconditioned conjugate gradient algorithm is used to compute    !
!  an approximation PSI for Beta_n.                                    !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations
!
      integer, intent(in) :: my_outer
!
      real(dp), intent(in) :: RunInterval
!
!  Local variable declarations.
!
      logical :: Lcgini, Linner, Lposterior, add
!
      integer :: i, ifile, lstr, my_inner, ng, tile
      integer :: Fcount, InpRec, Tindex
# ifdef PROFILE
      integer :: thread
# endif
# ifdef SPLIT_4DVAR
!
      real(dp) :: stime
# endif
!
      character (len=6  ) :: driver = 'r4dvar'
      character (len=10 ) :: suffix
      character (len=20 ) :: string
# ifdef SPLIT_4DVAR
      character (len=256) :: ncname
# endif
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", increment"
!
      sourcefile=myfile
!
!-----------------------------------------------------------------------
!  Run representer model and compute a "prior estimate" state
!  trajectory, X_n(t). Use linearized state trajectory (X_n-1) as
!  basic state.
!-----------------------------------------------------------------------
 
# 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
      END IF
!
!  Open Nonlinear model initial conditions NetCDF file (INI struc) and
!  inquire about its variables IDs.
!
      DO ng=1,ngrids
        ldefini(ng)=.false.
        CALL def_ini (ng)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  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 representer model initial conditions NetCDF file
!  (IRP struc) and inquire about its variables IDs.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          ldefirp(ng)=.false.
          CALL rp_def_ini (ng)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
      END IF
!
!  If outer>1, open impulse forcing NetCDF file (TLF struc) and inquire
!  about its variables IDs.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          ldeftlf(ng)=.false.
          CALL def_impulse (ng)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
      END IF
!
!  If outer>1, open adjoint history NetCDF file (ADM struc) and inquire
!  about its variables IDs and set "FrcRec".
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          ldefadj(ng)=.false.
          CALL ad_def_his (ng, ldefadj(ng))
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          fcount=adm(ng)%Fcount
          frcrec(ng)=adm(ng)%Nrec(fcount)
        END DO
      END IF
!
!  Open 4D-Var NetCDF file (DAV struc) and inquire about its variables.
!  Deactivate "haveNLmod" since its values are read below. Otherwise,
!  the TLM will read zero values when calling "obs_read" for outer>1.
!  The DAV file does not have values for NLmodel_value(:,outer) yet.
!
      DO ng=1,ngrids
        ldefmod(ng)=.false.
        CALL def_mod (ng)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        havenlmod(ng)=.false.        ! because is activated in "def_mod"
      END DO
!
!  If split 4D-Var and outer>1, read several variables from 4D-VAR
!  NetCDF (DAV struc) file needed in the conjugate gradient algorithm.
!  In the unsplit case, such values are available in memory.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          CALL cg_read_congrad (ng, itlm, my_outer)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
      END IF
!
!  In the split 4D-Var algorithm, we need to read in initial NLmodVal
!  ("NLmodel_initial") and ObsScale ("obs_scale"), computed in the
!  background phase, from the DAV NetCDF file. Such data is in memory
!  in the unsplit algorithm.
!
!  HGA: What to do in 4D-Var with nested grids?
!
      IF (my_outer.eq.1) THEN
        ng=1                         ! initial values from "background"
        SELECT CASE (dav(ng)%IOtype)
          CASE (io_nf90)
            CALL netcdf_get_fvar (ng, itlm, dav(ng)%name,               &
     &                            vname(1,idnlmi), nlmodval,            &
     &                            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,idnlmi), nlmodval,        &
     &                                piofile = dav(ng)%pioFile)
#  endif
        END SELECT
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END IF
!
      ng=1
      SELECT CASE (dav(ng)%IOtype)
        CASE (io_nf90)
          CALL netcdf_get_fvar (ng, itlm, dav(ng)%name,                 &
     &                          vname(1,idobss), obsscale,              &
     &                          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), obsscale,          &
     &                              piofile = dav(ng)%pioFile)
#  endif
      END SELECT
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!  In the split 4D-Var alorithm, we also need to read in ObsVal
!  ("obs_value") and ObsErr ("obs_error") from the observation file.
!  They are used in the initialization of the conjugate gradient
!  algorithm.
!
      ng=1
      SELECT CASE (obs(ng)%IOtype)
        CASE (io_nf90)
          CALL netcdf_get_fvar (ng, itlm, obs(ng)%name,                 &
     &                          vname(1,idoval), obsval)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
          CALL netcdf_get_fvar (ng, itlm, obs(ng)%name,                 &
     &                          vname(1,idoerr), obserr)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
 
#  if defined PIO_LIB && defined DISTRIBUTE
        CASE (io_pio)
          CALL pio_netcdf_get_fvar (ng, itlm, obs(ng)%name,             &
     &                              vname(1,idoval), obsval)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
          CALL pio_netcdf_get_fvar (ng, itlm, obs(ng)%name,             &
     &                              vname(1,idoerr), obserr)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
#  endif
      END SELECT
!
!  Set nonlinear output history file to be used as the basic state
!  trajectory. The nonlinear model is run outside of the outer loops,
!  so we need outer=0 when updating HIS structure.  Notice that this
!  structure is needed to set the BLK structure below.
!
      DO ng=1,ngrids
        WRITE (his(ng)%name,10) trim(fwd(ng)%head), 0
        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
!
!  Read in 4D-Var starting time (sec) from forward trajectory NetCDF
!  file and set INItime. The starting time is 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
 
#  if defined ADJUST_BOUNDARY || \
      defined adjust_stflux   || defined adjust_wstress
!
!  If outer>1, read in adjust forcing arrays from IRP file (Rec2),
!  which are computed in the previous outer loop when calling the
!  "error_covarinace" after the inner loops. Such values are in
!  memory in the unsplit algorithm. Use "iTLM" descriptor so the
!  switch get_adjust=.TRUE.  Notice that all the TL arrays are
!  cleared in the next call to "rp_initial" except the "tl_*_obc"
!  arrays used when adjusting OBCs.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          inprec=rec2
          tindex=1
          CALL get_state (ng, itlm, 1, irp(ng), inprec, tindex)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
      END IF
#  endif
!
!  If outer>1, set previous outer loop representer model file.
!
      IF (my_outer.gt.1) THEN
        DO ng=1,ngrids
          WRITE (tlm(ng)%name,10) trim(fwd(ng)%head), my_outer-1
          lstr=len_trim(tlm(ng)%name)
          tlm(ng)%base=tlm(ng)%name(1:lstr-3)
        END DO
      END IF
# endif
!
!-----------------------------------------------------------------------
!  On first pass (outer=1), create NetCDF files and initialize all the
!  records in the ITL file to zero.
!-----------------------------------------------------------------------
!
      check_outer1 : IF (my_outer.eq.1) THEN
!
!  If outer=1, define tangent linear initial conditions file.
!
        DO ng=1,ngrids
          ldefitl(ng)=.true.
          CALL tl_def_ini (ng)
          ldefitl(ng)=.false.
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
!
!  If outer=1, define TLM/RPM impulse forcing NetCDF file.
!
        DO ng=1,ngrids
          ldeftlf(ng)=.true.
          CALL def_impulse (ng)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
 
# if defined POSTERIOR_EOFS    || defined POSTERIOR_ERROR_I || \
     defined posterior_error_f
!
!  Define output Hessian NetCDF file that will eventually contain
!  the intermediate posterior analysis error covariance matrix
!  fields or its EOFs.
!
        DO ng=1,ngrids
          ldefhss(ng)=.true.
          CALL def_hessian (ng)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
# endif
 
# if defined POSTERIOR_ERROR_I || defined POSTERIOR_ERROR_F
!
!  Define output initial or final full posterior error covariance
!  (diagonal) matrix NetCDF.
!
        DO ng=1,ngrids
          ldeferr(ng)=.true.
          CALL def_error (ng)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
# endif
      END IF check_outer1
!
!-----------------------------------------------------------------------
!  Run finite amplitude tangent linear (representers) model.
!-----------------------------------------------------------------------
!
!  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. This 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
!
!  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.
!
      IF (my_outer.eq.1) THEN
        CALL edit_multifile ('HIS2FWD')
      ELSE
        CALL edit_multifile ('TLM2FWD')
      END IF
      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.
      END DO
# endif
!
!  Set representer model output file name.  The strategy is to write
!  the representer solution at the beginning of each outer loop.
!
      DO ng=1,ngrids
        ideftlm(ng)=-1
        ldeftlm(ng)=.true.
        lwrttlm(ng)=.true.
        WRITE (tlm(ng)%name,10) trim(fwd(ng)%head), my_outer
        lstr=len_trim(tlm(ng)%name)
        tlm(ng)%base=tlm(ng)%name(1:lstr-3)
      END DO
!
!  Activate switch to write the representer model at observation points.
!  Turn off writing into history file and turn off impulse forcing.
!
      DO ng=1,ngrids
        wrtrpmod(ng)=.true.
        sporadicimpulse(ng)=.false.
        frequentimpulse(ng)=.false.
      END DO
 
# ifndef DATALESS_LOOPS
!
!  As in the nonlinear model, initialize always the representer model
!  here with the background or reference state (IRP(ng)%name, record
!  Rec1).
!
      DO ng=1,ngrids
        irp(ng)%Rindex=rec1
        CALL rp_initial (ng)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  Run representer model using the nonlinear trajectory as a basic
!  state.  Compute model solution at observation points, H * X_n.
!
      DO ng=1,ngrids
#  ifdef RP_AVERAGES
        ldefavg(ng)=.false.
        lwrtavg(ng)=.false.
#  endif
        IF (master) THEN
          WRITE (stdout,20) 'RP', ng, my_outer, 0,                      &
     &                      ntstart(ng), ntend(ng)
        END IF
      END DO
!
#  ifdef SOLVE3D
      CALL rp_main3d (runinterval)
#  else
      CALL rp_main2d (runinterval)
#  endif
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!  Report data penalty function.
!
      DO ng=1,ngrids
        IF (master) THEN
          DO i=0,nstatevar(ng)
            IF (i.eq.0) THEN
              string='Total'
            ELSE
              string=vname(1,idsvar(i))
            END IF
            IF (fourdvar(ng)%DataPenalty(i).ne.0.0_r8) THEN
              WRITE (stdout,30) my_outer, inner, 'RPM',                 &
     &                          fourdvar(ng)%DataPenalty(i),            &
     &                          trim(string)
            END IF
          END DO
        END IF
!
!  Write out initial data penalty function to NetCDF file.
!
        sourcefile=myfile
        SELECT CASE (dav(ng)%IOtype)
          CASE (io_nf90)
            CALL netcdf_put_fvar (ng, irpm, dav(ng)%name,               &
     &                            'RP_iDataPenalty',                    &
     &                            fourdvar(ng)%DataPenalty(0:),         &
     &                            (/1,my_outer/),                       &
     &                            (/nstatevar(ng)+1,1/),                &
     &                            ncid = dav(ng)%ncid)
 
#  if defined PIO_LIB && defined DISTRIBUTE
          CASE (io_pio)
            CALL pio_netcdf_put_fvar (ng, irpm, dav(ng)%name,           &
     &                                'RP_iDataPenalty',                &
     &                                fourdvar(ng)%DataPenalty(0:),     &
     &                                (/1,my_outer/),                   &
     &                                (/nstatevar(ng)+1,1/),            &
     &                                piofile = dav(ng)%pioFile)
#  endif
        END SELECT
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!  Clean penalty array before next run of RP model.
!
        fourdvar(ng)%DataPenalty=0.0_r8
      END DO
!
!  Turn off IO switches.
!
      DO ng=1,ngrids
        ldeftlm(ng)=.false.
        lwrttlm(ng)=.false.
        wrtrpmod(ng)=.false.
      END DO
!
!  Clear tangent linear forcing arrays before entering inner-loop.
!  This is very important since these arrays are non-zero after
!  running the representer model and must be zero when running the
!  tangent linear model.
!
      DO ng=1,ngrids
        DO tile=first_tile(ng),last_tile(ng),+1
          CALL initialize_forces (ng, tile, itlm)
#  ifdef ADJUST_BOUNDARY
          CALL initialize_boundary (ng, tile, itlm)
#  endif
        END DO
      END DO
 
#  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
          CALL get_state (ng, inlm, 2, ini(ng), lini, lini)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
          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
!
!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
!  4D-Var inner loops.
!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
!
      inner_loop : DO my_inner=0,ninner
        inner=my_inner
!
! Initialize conjugate gradient algorithm depending on hot start or
! outer loop index.
!
        IF (my_inner.eq.0) THEN
          lcgini=.true.
          DO ng=1,ngrids
            CALL congrad (ng, irpm, my_outer, my_inner, ninner, lcgini)
          END DO
        END IF
!
!  If initialization step, skip the inner-loop computations.
!
        linner=.false.
        IF ((my_inner.ne.0).or.(nrun.ne.1)) THEN
          IF (((my_inner.eq.0).and.lhotstart).or.(my_inner.ne.0)) THEN
            linner=.true.
          END IF
        END IF
!
!  Start inner loop computations.
!
        inner_compute : IF (linner) THEN
!
!-----------------------------------------------------------------------
!  Integrate adjoint model forced with any vector PSI at the observation
!  locations and generate adjoint trajectory, Lambda_n(t).
!-----------------------------------------------------------------------
!
!  Initialize the adjoint model from rest.
!
          DO ng=1,ngrids
            CALL ad_initial (ng)
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
            wrtmisfit(ng)=.false.
          END DO
 
#  ifdef RPM_RELAXATION
!
!  Adjoint of representer relaxation is not applied during the
!  inner-loops.
!
          DO ng=1,ngrids
            lweakrelax(ng)=.false.
          END DO
#  endif
!
!  Set adjoint history NetCDF parameters.  Define adjoint history
!  file only once to avoid opening too many files.
!
          DO ng=1,ngrids
            wrtforce(ng)=.true.
            IF (nrun.gt.1) ldefadj(ng)=.false.
            fcount=adm(ng)%load
            adm(ng)%Nrec(fcount)=0
            adm(ng)%Rindex=0
          END DO
!
!  Time-step adjoint model backwards forced with current PSI vector.
!
          DO ng=1,ngrids
            IF (master) THEN
              WRITE (stdout,20) '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
!
!  Activate "LwrtState2d" switch to write the correct ad_ubar, ad_vbar,
!  ad_zeta here instead of ad_ubar_sol, ad_vbar_sol, and ad_zeta_sol in
!  the calls to "ad_wrt_his" below (HGA).
!  Here, ad_zeta(:,:,kout)=ad_zeta_sol. However, ad_ubar and ad_vbar
!  not equal to ad_ubar_sol and ad_vbar_sol, respectively. It is
!  irrelevant because ubar and vbar are not part of the state in
!  3D application.  Notice that "LwrtState2d" will be turned off at
!  the bottom of "error_covariance".
!
          DO ng=1,ngrids
            lwrtstate2d(ng)=.true.
          END DO
!
!  Write out last weak-constraint forcing (WRTforce is still .TRUE.)
!  record into the adjoint history file.
!
          DO ng=1,ngrids
#  ifdef DISTRIBUTE
            CALL ad_wrt_his (ng, myrank)
#  else
            CALL ad_wrt_his (ng, -1)
#  endif
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END DO
!
!  Write out adjoint initial condition record into the adjoint
!  history file.
!
          DO ng=1,ngrids
            wrtforce(ng)=.false.
            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
          END DO
!
!  Convolve adjoint trajectory with error covariances.  Notice that we
!  use iTLM to write the convolved solution into the ITL(ng)%name file
!  (record Rec1) as the TLM initial conditions for the next inner loop.
!
#  ifdef POSTERIOR_ERROR_I
          lposterior=.true.
#  else
          lposterior=.false.
#  endif
          CALL error_covariance (itlm, driver, my_outer, my_inner,      &
     &                           lbck, lini, lold, lnew,                &
     &                           rec1, rec2, lposterior)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!  Convert the current adjoint solution in ADM(ng)%name to impulse
!  forcing. Write out impulse forcing into TLF(ng)%name NetCDF file.
!  To facilitate the forcing to the TLM and RPM, the forcing is
!  processed and written in increasing time coordinates (recall that
!  the adjoint solution in ADM(ng)%name is backwards in time).
!
          IF (master) THEN
            WRITE (stdout,40) my_outer, my_inner
          END IF
          DO ng=1,ngrids
            tlf(ng)%Rindex=0
#  ifdef DISTRIBUTE
            CALL wrt_impulse (ng, myrank, iadm, adm(ng)%name)
#  else
            CALL wrt_impulse (ng, -1, iadm, adm(ng)%name)
#  endif
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END DO
!
!-----------------------------------------------------------------------
!  Integrate tangent linear model forced by the convolved adjoint
!  trajectory (impulse forcing) to compute R_n * PSI at observation
!  points.
!-----------------------------------------------------------------------
!
          DO ng=1,ngrids
            wrtnlmod(ng)=.false.
            wrttlmod(ng)=.true.
          END DO
!
!  If weak constraint, the impulses are time-interpolated at each
!  time-steps.
!
          DO ng=1,ngrids
            IF (frcrec(ng).gt.3) THEN
              frequentimpulse(ng)=.true.
            END IF
          END DO
!
!  Initialize tangent linear model from ITL(ng)%name, record Rec1.
!
          DO ng=1,ngrids
            itl(ng)%Rindex=rec1
            CALL tl_initial (ng)
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END DO
!
!  Activate switch to write out initial misfit between model and
!  observations.
!
          IF ((my_outer.eq.1).and.(my_inner.eq.1)) THEN
            DO ng=1,ngrids
              wrtmisfit(ng)=.true.
            END DO
          END IF
!
!  Set tangent linear history NetCDF parameters.  Define tangent linear
!  history file at the beggining of each inner loop  to avoid opening
!  too many NetCDF files.
!
          DO ng=1,ngrids
            IF (my_inner.gt.1) ldeftlm(ng)=.false.
            fcount=tlm(ng)%load
            tlm(ng)%Nrec(fcount)=0
            tlm(ng)%Rindex=0
          END DO
!
!  Run tangent linear model forward and force with convolved adjoint
!  trajectory impulses. Compute R_n * PSI at observation points which
!  are used in the conjugate gradient algorithm.
!
          DO ng=1,ngrids
            IF (master) THEN
              WRITE (stdout,20) '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
!
          DO ng=1,ngrids
            wrtnlmod(ng)=.false.
            wrttlmod(ng)=.false.
          END DO
 
#  ifdef POSTERIOR_ERROR_F
!
!  Copy the final time tl_var(Lold) into ad_var(Lold) so that it can be
!  written to the Hessian NetCDF file.
!
          add=.false.
          DO ng=1,ngrids
            DO tile=first_tile(ng),last_tile(ng),+1
              CALL load_tltoad (ng, tile, lold(ng), lold(ng), add)
            END DO
          END DO
!
!  Write evolved tangent solution into hessian netcdf file for use
!  later.
!
          IF (my_inner.ne.0) THEN
            DO ng=1,ngrids
#   ifdef DISTRIBUTE
              CALL wrt_hessian (ng, myrank, lold(ng), lold(ng))
#   else
              CALL wrt_hessian (ng, -1, lold(ng), lold(ng))
#   endif
              IF (founderror(exit_flag, noerror,                        &
     &                       __line__, myfile)) RETURN
            END DO
          END IF
#  endif
!
!-----------------------------------------------------------------------
!  Use conjugate gradient algorithm to find a better approximation
!  PSI to representer coefficients Beta_n.
!-----------------------------------------------------------------------
!
          nrun=nrun+1
          DO ng=1,ngrids
            lcgini=.false.
            CALL congrad (ng, irpm, my_outer, my_inner, ninner, lcgini)
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END DO
 
        END IF inner_compute
 
      END DO inner_loop
!
!  Close tangent linear 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
!
!-----------------------------------------------------------------------
!  Once that the representer coefficients, Beta_n, have been
!  approximated with sufficient accuracy, compute estimates of
!  Lambda_n and Xhat_n by carrying out one backward intergration
!  of the adjoint model and one forward itegration of the representer
!  model.
!-----------------------------------------------------------------------
!
!  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
 
#  ifdef RPM_RELAXATION
!
!  Adjoint of representer relaxation is applied during the
!  outer-loops.
!
      DO ng=1,ngrids
        lweakrelax(ng)=.true.
      END DO
#  endif
!
!  Set adjoint history NetCDF parameters.  Define adjoint history
!  file one to avoid opening to many files.
!
      DO ng=1,ngrids
        wrtforce(ng)=.true.
        IF (nrun.gt.1) ldefadj(ng)=.false.
        fcount=adm(ng)%load
        adm(ng)%Nrec(fcount)=0
        adm(ng)%Rindex=0
      END DO
!
!  Time-step adjoint model backwards forced with estimated representer
!  coefficients, Beta_n.
!
      DO ng=1,ngrids
        IF (master) THEN
          WRITE (stdout,20) 'AD', ng, my_outer, ninner,                 &
     &                      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
!
!  Write out last weak-constraint forcing (WRTforce is still .TRUE.)
!  record into the adjoint history file.  Note that the weak-constraint
!  forcing is delayed by nADJ time-steps.
!
      DO ng=1,ngrids
#  ifdef DISTRIBUTE
        CALL ad_wrt_his (ng, myrank)
#  else
        CALL ad_wrt_his (ng, -1)
#  endif
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  Write out adjoint initial condition record into the adjoint
!  history file.
!
      DO ng=1,ngrids
        wrtforce(ng)=.false.
#  ifdef DISTRIBUTE
        CALL ad_wrt_his (ng, myrank)
#  else
        CALL ad_wrt_his (ng, -1)
#  endif
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  Convolve adjoint trajectory with error covariances.  Notice that we
!  use iRPM to write the convolved solution into the IRP(ng)%name file
!  (record Rec2) as the RPM initial conditions for the next outer loop.
!
      lposterior=.false.
      CALL error_covariance (irpm, driver, my_outer, inner,             &
     &                       lbck, lini, lold, lnew,                    &
     &                       rec1, rec2, lposterior)
      IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!  Convert the current adjoint solution in ADM(ng)%name to impulse
!  forcing. Write out impulse forcing into TLF(ng)%name NetCDF file.
!  To facilitate the forcing to the TLM and RPM, the forcing is
!  processed and written in increasing time coordinates (recall that
!  the adjoint solution in ADM(ng)%name is backwards in time).
!
      IF (master) THEN
        WRITE (stdout,40) my_outer, inner
      END IF
      DO ng=1,ngrids
        tlf(ng)%Rindex=0
#  ifdef DISTRIBUTE
        CALL wrt_impulse (ng, myrank, iadm, adm(ng)%name)
#  else
        CALL wrt_impulse (ng, -1, iadm, adm(ng)%name)
#  endif
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
 
# endif /* !DATALESS_LOOPS */
 
# 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 (/,1x,a,1x,'ROMS: started time-stepping:',                 &
     &        ' (Grid: ',i0,', Outer: ',i2.2,', Inner: ',i3.3,          &
              ', TimeSteps: ',i0,' - ',i0,')',/)
 30   FORMAT (' (',i3.3,',',i3.3,'): ',a,' data penalty, Jdata = ',     &
     &        1p,e17.10,0p,t68,a)
 40   FORMAT (/,' Converting Convolved Adjoint Trajectory to',          &
     &          ' Impulses: Outer = ',i3.3,' Inner = ',i3.3,/)
!
      RETURN

References ad_def_his_mod::ad_def_his(), ad_initial(), ad_main2d(), ad_main3d(), ad_wrt_his_mod::ad_wrt_his(), mod_iounits::adm, mod_scalars::balance, zeta_balance_mod::balance_ref(), zeta_balance_mod::biconj(), congrad_mod::cg_read_congrad(), close_io_mod::close_file(), congrad_mod::congrad(), mod_iounits::dav, def_error_mod::def_error(), def_hessian_mod::def_hessian(), def_impulse_mod::def_impulse(), def_ini_mod::def_ini(), def_mod_mod::def_mod(), mod_scalars::dt, edit_multifile(), convolve_mod::error_covariance(), mod_scalars::exit_flag, mod_parallel::first_tile, strings_mod::founderror(), mod_fourdvar::fourdvar, mod_scalars::frcrec, mod_scalars::frequentimpulse, mod_iounits::fwd, get_state_mod::get_state(), mod_fourdvar::havenlmod, mod_iounits::his, mod_param::iadm, mod_ncparam::ideftlm, mod_ncparam::idnlmi, mod_ncparam::idobss, mod_ncparam::idoerr, mod_ncparam::idoval, mod_ncparam::idsvar, mod_ncparam::idtime, mod_iounits::ini, mod_boundary::initialize_boundary(), mod_forces::initialize_forces(), mod_ocean::initialize_ocean(), mod_scalars::initime, mod_param::inlm, mod_scalars::inner, mod_ncparam::io_nf90, mod_ncparam::io_pio, mod_iounits::irp, mod_param::irpm, mod_ncparam::isfsur, mod_iounits::itl, mod_param::itlm, mod_parallel::last_tile, lbck, mod_scalars::ldefadj, mod_scalars::ldefavg, mod_scalars::ldeferr, mod_scalars::ldefhss, mod_scalars::ldefini, mod_scalars::ldefirp, mod_scalars::ldefitl, mod_scalars::ldefmod, mod_scalars::ldeftlf, mod_scalars::ldeftlm, mod_fourdvar::lhotstart, lini, mod_stepping::lnew, mod_stepping::lold, mod_scalars::lreadblk, mod_scalars::lreadfrc, mod_scalars::lreadfwd, mod_fourdvar::lweakrelax, mod_scalars::lwrtavg, mod_scalars::lwrtstate2d, mod_scalars::lwrttlm, mod_parallel::master, mod_parallel::myrank, mod_scalars::nbrec, mod_scalars::nfrec, mod_param::ngrids, mod_scalars::ninner, mod_fourdvar::nlmodval, mod_scalars::nobc, mod_scalars::noerror, mod_scalars::nrun, mod_scalars::nsff, mod_fourdvar::nstatevar, mod_scalars::ntend, mod_scalars::ntstart, mod_scalars::obc_time, mod_iounits::obs, mod_fourdvar::obserr, mod_fourdvar::obsscale, mod_fourdvar::obsval, rec1, rec2, rp_def_ini_mod::rp_def_ini(), rp_initial(), rp_main2d(), rp_main3d(), mod_scalars::sf_time, mod_iounits::sourcefile, mod_scalars::sporadicimpulse, mod_iounits::stdout, tl_def_ini_mod::tl_def_ini(), tl_initial(), tl_main2d(), tl_main3d(), mod_iounits::tlf, mod_iounits::tlm, mod_ncparam::vname, wclock_off(), wclock_on(), wrt_hessian_mod::wrt_hessian(), wrt_impulse_mod::wrt_impulse(), mod_fourdvar::wrtforce, mod_fourdvar::wrtmisfit, mod_fourdvar::wrtnlmod, mod_fourdvar::wrtrpmod, mod_fourdvar::wrttlmod, and mod_fourdvar::wrtzetaref.

Here is the call graph for this function:

posterior_error()

subroutine, public r4dvar_mod::posterior_error

(

real(dp), intent(in)

runinterval

)

Definition at line 1945 of file r4dvar.F.

!
!=======================================================================
!                                                                      !
!  This routine computes posterior analysis error covariance matrix    !
!  using the Lanczos vectors.                                          !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     RunInterval     Kernel time stepping window (seconds)            !
!                                                                      !
!  Warning:                                                            !
!                                                                      !
!  Currently, this code only works for a single outer-loop.            !
!                                                                      !
!=======================================================================
!
!  Imported variable declarations
!
      real(dp), intent(in) :: RunInterval
!
!  Local variable declarations.
!
      logical :: Ltrace
!
      integer :: my_inner, my_outer, ng, tile
      integer :: Fcount, Rec
!
      character (len=6) :: driver = 'w4dvar'
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", posterior_error"
!
      sourcefile=myfile
 
#  if defined POSTERIOR_ERROR_I || defined POSTERIOR_ERROR_F
!
!-----------------------------------------------------------------------
!  Compute full (diagonal) posterior analysis error covariance matrix.
!-----------------------------------------------------------------------
!
!  Clear tangent and adjoint arrays because they are used as
!  work arrays below.
!
      DO ng=1,ngrids
        DO tile=first_tile(ng),last_tile(ng),+1
          CALL initialize_ocean (ng, tile, iadm)
          CALL initialize_ocean (ng, tile, itlm)
          CALL initialize_forces (ng, tile, iadm)
          CALL initialize_forces (ng, tile, itlm)
#   ifdef ADJUST_BOUNDARY
          CALL initialize_boundary (ng, tile, iadm)
          CALL initialize_boundary (ng, tile, itlm)
#   endif
        END DO
      END DO
!
!   Compute the diagonal of the posterior/analysis error covariance
!   matrix. The result is written to record 2 of the ITL netcdf file.
!
      var_oloop : DO my_outer=1,nouter
        outer=my_outer
        DO ng=1,ngrids
          DO tile=first_tile(ng),last_tile(ng),+1
            CALL posterior_var (ng, tile, itlm, my_outer)
          END DO
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END DO
      END DO var_oloop
!
!  Write out the diagonal of the posterior/analysis covariance matrix
!  which is in tl_var(Rec1) to 4DVar error NetCDF file.
!
      DO ng=1,ngrids
#   ifdef DISTRIBUTE
        CALL wrt_error (ng, myrank, rec1, rec1)
#   else
        CALL wrt_error (ng, -1, rec1, rec1)
#   endif
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END DO
!
!  Clear tangent and adjoint arrays because they are used as
!  work arrays below.
!
      DO ng=1,ngrids
        DO tile=first_tile(ng),last_tile(ng),+1
          CALL initialize_ocean (ng, tile, iadm)
          CALL initialize_ocean (ng, tile, itlm)
          CALL initialize_forces (ng, tile, iadm)
          CALL initialize_forces (ng, tile, itlm)
#   ifdef ADJUST_BOUNDARY
          CALL initialize_boundary (ng, tile, iadm)
          CALL initialize_boundary (ng, tile, itlm)
#   endif
        END DO
      END DO
#  endif
 
#  ifdef POSTERIOR_EOFS
!
!-----------------------------------------------------------------------
!  Compute the posterior analysis error covariance matrix EOFs using a
!  Lanczos algorithm.
!
!  NOTE: Currently, this code only works for a single outer-loop.
!-----------------------------------------------------------------------
!
      IF (master) WRITE (stdout,10)
!
!  Estimate first the trace of the posterior analysis error
!  covariance matrix since the evolved and convolved Lanczos
!  vectors stored in the Hessian NetCDF file will be destroyed
!  later.
!
      ltrace=.true.
 
      trace_oloop : DO my_outer=1,nouter
        outer=my_outer
        inner=0
 
        trace_iloop : DO my_inner=1,nposti
          inner=my_inner
!
!  Initialize the tangent linear variables with a random vector
!  comprised of +1 and -1 elements randomly chosen.
!
          DO ng=1,ngrids
            DO tile=first_tile(ng),last_tile(ng),+1
              CALL random_ic (ng, tile, itlm, inner, outer,             &
     &                        lold(ng), ltrace)
            END DO
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END DO
!
!  Apply horizontal convolution.
!
          CALL convolve (driver, lini, lold, lnew)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!  Compute Lanczos vector and eigenvectors of the posterior analysis
!  error covariance matrix.
!
          DO ng=1,ngrids
            DO tile=first_tile(ng),last_tile(ng),+1
              CALL posterior (ng, tile, itlm, inner, outer, ltrace)
            END DO
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END DO
 
        END DO trace_iloop
 
      END DO trace_oloop
!
!  Estimate posterior analysis error covariance matrix.
!
      ltrace=.false.
 
      post_oloop : DO my_outer=1,nouter
        outer=my_outer
        inner=0
!
!  The Lanczos algorithm requires to save all the Lanczos vectors.
!  They are used to compute the posterior EOFs.
!
        DO ng=1,ngrids
          adm(ng)%Rindex=0
          fcount=adm(ng)%load
          adm(ng)%Nrec(fcount)=0
        END DO
 
        post_iloop : DO my_inner=0,nposti
          inner=my_inner
!
!  Read first record of ITL file and apply convolutions.
!
!  NOTE: If inner=0, we would like to use a random starting vector.
!        For now we can use what ever is in record 1.
!
          IF (my_inner.ne.0) THEN
            DO ng=1,ngrids
              rec=1
              CALL get_state (ng, itlm, 1, itl(ng), rec, lold(ng))
              IF (founderror(exit_flag, noerror,                        &
     &                       __line__, myfile)) RETURN
            END DO
          ELSE
            DO ng=1,ngrids
              DO tile=first_tile(ng),last_tile(ng),+1
                CALL random_ic (ng, tile, itlm, inner, outer,           &
     &                          lold(ng), ltrace)
              END DO
              IF (founderror(exit_flag, noerror,                        &
     &                       __line__, myfile)) RETURN
            END DO
          END IF
!
!  Apply horizontal convolution.
!
          CALL convolve (driver, lini, lold, lnew)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
!
!  Compute Lanczos vector and eigenvectors of the posterior analysis
!  error covariance matrix.
!
          DO ng=1,ngrids
            DO tile=first_tile(ng),last_tile(ng),+1
              CALL posterior (ng, tile, itlm, inner, outer, ltrace)
            END DO
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END DO
!
!   Write the Lanczos vectors of the posterior error covariance
!   to the adjoint NetCDF file.
!
          DO ng=1,ngrids
#   if defined ADJUST_STFLUX || defined ADJUST_WSTRESS
            lfout(ng)=lnew(ng)
#   endif
#   ifdef ADJUST_BOUNDARY
            lbout(ng)=lnew(ng)
#   endif
            kstp(ng)=lnew(ng)
#   ifdef SOLVE3D
            nstp(ng)=lnew(ng)
#   endif
            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 tangent linear model initial conditions and tangent
!  linear surface forcing adjustments for next inner loop into
!  ITL(ng)%name (record Rec1).
!
          DO ng=1,ngrids
#   ifdef DISTRIBUTE
            CALL tl_wrt_ini (ng, myrank, lnew(ng), rec1)
#   else
            CALL tl_wrt_ini (ng, -1, lnew(ng), rec1)
#   endif
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END DO
 
        END DO post_iloop
 
      END DO post_oloop
 
#  endif /* POSTERIOR_EOFS */
!
!  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
 
#  ifdef POSTERIOR_EOFS
!
 10   FORMAT (/,' <<<< Posterior Analysis Error Covariance Matrix',     &
     &          ' Estimation >>>>',/)
#  endif
!
      RETURN

References ad_wrt_his_mod::ad_wrt_his(), mod_iounits::adm, convolve_mod::convolve(), mod_scalars::exit_flag, mod_parallel::first_tile, strings_mod::founderror(), get_state_mod::get_state(), mod_iounits::his, mod_param::iadm, mod_boundary::initialize_boundary(), mod_forces::initialize_forces(), mod_ocean::initialize_ocean(), mod_scalars::inner, mod_iounits::itl, mod_param::itlm, mod_stepping::kstp, mod_parallel::last_tile, mod_stepping::lbout, mod_stepping::lfout, lini, mod_stepping::lnew, mod_stepping::lold, mod_scalars::lwrtstate2d, mod_parallel::master, mod_parallel::myrank, mod_param::ngrids, mod_scalars::noerror, mod_scalars::nouter, mod_fourdvar::nposti, mod_stepping::nstp, mod_scalars::outer, posterior_mod::posterior(), posterior_var_mod::posterior_var(), random_ic_mod::random_ic(), rec1, mod_iounits::sourcefile, mod_iounits::stdout, and tl_wrt_ini_mod::tl_wrt_ini().

Here is the call graph for this function:

prior_error()

subroutine, public r4dvar_mod::prior_error

(

integer, intent(in)

ng

)

Definition at line 1781 of file r4dvar.F.

!
!=======================================================================
!                                                                      !
!  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.
!-----------------------------------------------------------------------
!
!  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
!
!  Model error standard deviation. They are loaded in Tindex=2
!  of the e_var(...,Tindex) state variables.
!
      stdrec=1
      tindex=2
      IF (nsa.eq.2) THEN
        CALL get_state (ng, 11, 11, std(2,ng), stdrec, tindex)
        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
!
!-----------------------------------------------------------------------
!  Error covariance normalization coefficients.
!-----------------------------------------------------------------------
!
!  Compute or read in the 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 and decorrelation scales.
!
      IF (any(lwrtnrm(:,ng))) THEN
        CALL def_norm (ng, inlm, 1)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
 
        IF (nsa.eq.2) THEN
          CALL def_norm (ng, inlm, 2)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END IF
 
# 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
        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
 
        IF (nsa.eq.2) THEN
          CALL get_state (ng, 15, 15, nrm(2,ng), nrmrec, 2)
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END IF
 
# 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
!
      RETURN

References def_norm_mod::def_norm(), mod_scalars::exit_flag, mod_parallel::first_tile, strings_mod::founderror(), get_state_mod::get_state(), mod_param::inlm, mod_parallel::last_tile, mod_scalars::ldefnrm, mod_scalars::lreadstd, mod_scalars::lwrtnrm, mod_scalars::noerror, normalization_mod::normalization(), mod_iounits::nrm, mod_param::nsa, posterior_mod::posterior_eofs(), set_grid(), mod_scalars::setgridconfig, mod_iounits::sourcefile, and mod_iounits::std.

Here is the call graph for this function:

Variable Documentation

lbck

integer r4dvar_mod::lbck = 2

Definition at line 151 of file r4dvar.F.

      integer :: Lbck = 2       ! background record in INI

Referenced by increment().

ldone

logical r4dvar_mod::ldone

Definition at line 147 of file r4dvar.F.

      logical :: Ldone

lini

integer r4dvar_mod::lini = 1

Definition at line 150 of file r4dvar.F.

      integer :: Lini = 1       ! NLM initial conditions record in INI

Referenced by increment(), and posterior_error().

rec1

integer r4dvar_mod::rec1 = 1

Definition at line 152 of file r4dvar.F.

      integer :: Rec1 = 1

Referenced by analysis(), increment(), and posterior_error().

rec2

integer r4dvar_mod::rec2 = 2

Definition at line 153 of file r4dvar.F.

      integer :: Rec2 = 2

Referenced by analysis(), and increment().