ad_htobs.F

Go to the documentation of this file.

#include "cppdefs.h"
      MODULE ad_htobs_mod
#if defined ADJOINT && defined OBSERVATIONS && defined WEAK_CONSTRAINT
!
!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 routine computes the adjoint observation operator,             !
!                                                                      !
!       transpose(H) * X                                               !
!                                                                      !
!  which loads the observation vector into the adjoint forcing arrays. !
!                                                                      !
!  The observation screening and quality control variable "ObsScale"   !
!  is not modified in this routine. Their values are the ones set in   !
!  obs_write.F during the running of the nonlinear model.              !
!                                                                      !
!=======================================================================
!
      implicit none
 
      CONTAINS
!
!***********************************************************************
      SUBROUTINE ad_htobs (ng, tile, model)
!***********************************************************************
!
      USE mod_param
      USE mod_grid
      USE mod_ocean
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, tile, model
!
!  Local variable declarations.
!
# include "tile.h"
!
      CALL ad_htobs_tile (ng, tile, model,                              &
     &                    lbi, ubi, lbj, ubj,                           &
     &                    imins, imaxs, jmins, jmaxs,                   &
# ifdef MASKING
     &                    grid(ng) % rmask,                             &
     &                    grid(ng) % umask,                             &
     &                    grid(ng) % vmask,                             &
# endif
# ifdef SOLVE3D
     &                    grid(ng) % z_r,                               &
     &                    grid(ng) % z_v,                               &
     &                    ocean(ng) % f_u,                              &
     &                    ocean(ng) % f_v,                              &
     &                    ocean(ng) % f_t,                              &
# endif
     &                    ocean(ng) % f_ubar,                           &
     &                    ocean(ng) % f_vbar,                           &
     &                    ocean(ng) % f_zeta)
      RETURN
      END SUBROUTINE ad_htobs
!
!***********************************************************************
      SUBROUTINE ad_htobs_tile (ng, tile, model,                        &
     &                          LBi, UBi, LBj, UBj,                     &
     &                          IminS, ImaxS, JminS, JmaxS,             &
# ifdef MASKING
     &                          rmask, umask, vmask,                    &
# endif
# ifdef SOLVE3D
     &                          z_r, z_v,                               &
     &                          f_u, f_v, f_t,                          &
# endif
     &                          f_ubar, f_vbar, f_zeta)
!***********************************************************************
!
      USE mod_param
      USE mod_parallel
      USE mod_fourdvar
      USE mod_iounits
      USE mod_ncparam
      USE mod_scalars
!
# ifdef DISTRIBUTE
      USE distribute_mod, ONLY : mp_collect
      USE mp_exchange_mod, ONLY : ad_mp_exchange2d
#  ifdef SOLVE3D
      USE mp_exchange_mod, ONLY : ad_mp_exchange3d
#  endif
# endif
      USE ad_extract_obs_mod, ONLY : ad_extract_obs2d
# ifdef SOLVE3D
      USE ad_extract_obs_mod, ONLY : ad_extract_obs3d
# endif
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, tile, model
      integer, intent(in) :: LBi, UBi, LBj, UBj
      integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
!
# ifdef ASSUMED_SHAPE
#  ifdef MASKING
      real(r8), intent(in) :: rmask(LBi:,LBj:)
      real(r8), intent(in) :: umask(LBi:,LBj:)
      real(r8), intent(in) :: vmask(LBi:,LBj:)
#  endif
#  ifdef SOLVE3D
      real(r8), intent(in) :: z_r(LBi:,LBj:,:)
      real(r8), intent(inout) :: z_v(LBi:,LBj:,:)
      real(r8), intent(inout) :: f_u(LBi:,LBj:,:)
      real(r8), intent(inout) :: f_v(LBi:,LBj:,:)
      real(r8), intent(inout) :: f_t(LBi:,LBj:,:,:)
#  endif
      real(r8), intent(inout) :: f_ubar(LBi:,LBj:)
      real(r8), intent(inout) :: f_vbar(LBi:,LBj:)
      real(r8), intent(inout) :: f_zeta(LBi:,LBj:)
# else
#  ifdef MASKING
      real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
      real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
      real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
#  endif
#  ifdef SOLVE3D
      real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,N(ng))
      real(r8), intent(inout) :: z_v(LBi:UBi,LBj:UBj,N(ng))
      real(r8), intent(inout) :: f_u(LBi:UBi,LBj:UBj,N(ng))
      real(r8), intent(inout) :: f_v(LBi:UBi,LBj:UBj,N(ng))
      real(r8), intent(inout) :: f_t(LBi:UBi,LBj:UBj,N(ng),NT(ng))
#  endif
      real(r8), intent(inout) :: f_ubar(LBi:UBi,LBj:UBj)
      real(r8), intent(inout) :: f_vbar(LBi:UBi,LBj:UBj)
      real(r8), intent(inout) :: f_zeta(LBi:UBi,LBj:UBj)
# endif
!
!  Local variable declarations.
!
      integer :: Mstr, Mend, ObsSum, ObsVoid
# ifdef DISTRIBUTE
      integer :: Ncollect
# endif
      integer :: i, ie, iobs, is, j
 
# ifdef SOLVE3D
      integer :: itrc, k
# endif
      real(r8) :: angle
 
      real(r8), parameter :: IniVal = 0.0_r8
 
      real(r8) :: ad_uradial(Mobs), ad_vradial(Mobs)
 
# include "set_bounds.h"
!
!-----------------------------------------------------------------------
!  Compute model minus observations adjoint misfit forcing. The
!  representer coefficients (or its approximation PSI) has been
!  already loaded into vector ADmodVal in the conjugate gradient
!  or read in.
!
# ifdef DISTRIBUTE
!  The adjoint of this operator is tricky in parallel (tile partitions)
!  because we need to avoid adding observation contributions to ghost
!  points. In the case that an observation is located between neighbor
!  tiles, both tiles need to process it and the contribution to f_var
!  (an adjoint variable) is only done in the tile where (i,j) or
!  (i,j,k) is not a ghost point.
!
!  Alternatively, only one tile process such observation and the
!  ad_mp_exchange*d routine is used to add the contribution to the
!  correct (i,j) or (i,j,k) point. This is the strategy used here.
!
# endif
!  The processing flag used to reject (ObsVetting=0) or accept
!  (ObsVetting=1) observations is computed here but it is never
!  used. The observation screening and quality control variable
!  (ObsScale) is only computed in routine obs_write.
!-----------------------------------------------------------------------
!
      IF (processobs(ng)) THEN
!
!  Set starting and ending indices of representer coefficient vector to
!  proccess. The adjoint forcing is only computed for current time
!  survey observations.
!
        mstr=nstrobs(ng)
        mend=nendobs(ng)
!
!  Initialize observation reject/accept processing flag.
!
        DO iobs=mstr,mend
          obsvetting(iobs)=inival
        END DO
 
# if defined OBS_SPACE && defined RBL4DVAR_FCT_SENSITIVITY
!
!  Define ADmodVal to be the impact forcing in observation space.
!
#  ifndef OBS_IMPACT
        IF (.not.ladjvar(ng)) THEN
#  endif
          IF (lobspace(ng)) THEN
            DO iobs=mstr,mend
              admodval(iobs)=obsval(iobs)
              obsscale(iobs)=1.0_r8
            END DO
          ELSE
            DO iobs=mstr,mend
              admodval(iobs)=0.0_r8
              obsscale(iobs)=1.0_r8
            END DO
          END IF
#  ifndef OBS_IMPACT
        END IF
#  endif
# endif
 
# ifdef BGQC
!
!  Reject observation that fail background quality control check.
!
        DO iobs=mstr,mend
          admodval(iobs)=obsscale(iobs)*admodval(iobs)
        END DO
# endif
!
!  Free-surface.
!
        DO i=lbi,ubi
          DO j=lbj,ubj
            f_zeta(i,j)=0.0_r8
          END DO
        END DO
        IF (fourdvar(ng)%ObsCount(isfsur).gt.0) THEN
          CALL ad_extract_obs2d (ng, 0, lm(ng)+1, 0, mm(ng)+1,          &
     &                           lbi, ubi, lbj, ubj,                    &
     &                           obsstate2type(isfsur),                 &
     &                           mobs, mstr, mend,                      &
     &                           rxmin(ng), rxmax(ng),                  &
     &                           rymin(ng), rymax(ng),                  &
     &                           time(ng), dt(ng),                      &
     &                           obstype, obsvetting,                   &
     &                           tobs, xobs, yobs,                      &
     &                           f_zeta,                                &
# ifdef MASKING
     &                           rmask,                                 &
# endif
     &                           admodval)
# ifdef DISTRIBUTE
          CALL ad_mp_exchange2d (ng, tile, iadm, 1,                     &
     &                           lbi, ubi, lbj, ubj,                    &
     &                           nghostpoints,                          &
     &                           ewperiodic(ng), nsperiodic(ng),        &
     &                           f_zeta)
# endif
        END IF
!
!  2D u-momentum component.
!
        DO i=lbi,ubi
          DO j=lbj,ubj
            f_ubar(i,j)=0.0_r8
          END DO
        END DO
        IF (fourdvar(ng)%ObsCount(isubar).gt.0) THEN
          CALL ad_extract_obs2d (ng, 1, lm(ng)+1, 0, mm(ng)+1,          &
     &                           lbi, ubi, lbj, ubj,                    &
     &                           obsstate2type(isubar),                 &
     &                           mobs, mstr, mend,                      &
     &                           uxmin(ng), uxmax(ng),                  &
     &                           uymin(ng), uymax(ng),                  &
     &                           time(ng), dt(ng),                      &
     &                           obstype, obsvetting,                   &
     &                           tobs, xobs, yobs,                      &
     &                           f_ubar,                                &
# ifdef MASKING
     &                           umask,                                 &
# endif
     &                           admodval)
# ifdef DISTRIBUTE
          CALL ad_mp_exchange2d (ng, tile, iadm, 1,                     &
     &                           lbi, ubi, lbj, ubj,                    &
     &                           nghostpoints,                          &
     &                           ewperiodic(ng), nsperiodic(ng),        &
     &                           f_ubar)
# endif
        END IF
!
!  2D v-momentum component.
!
        DO i=lbi,ubi
          DO j=lbj,ubj
            f_vbar(i,j)=0.0_r8
          END DO
        END DO
        IF (fourdvar(ng)%ObsCount(isvbar).gt.0) THEN
          CALL ad_extract_obs2d (ng, 0, lm(ng)+1, 1, mm(ng)+1,          &
     &                           lbi, ubi, lbj, ubj,                    &
     &                           obsstate2type(isvbar),                 &
     &                           mobs, mstr, mend,                      &
     &                           vxmin(ng), vxmax(ng),                  &
     &                           vymin(ng), vymax(ng),                  &
     &                           time(ng), dt(ng),                      &
     &                           obstype, obsvetting,                   &
     &                           tobs, xobs, yobs,                      &
     &                           f_vbar,                                &
# ifdef MASKING
     &                           vmask,                                 &
# endif
     &                           admodval)
# ifdef DISTRIBUTE
          CALL ad_mp_exchange2d (ng, tile, iadm, 1,                     &
     &                           lbi, ubi, lbj, ubj,                    &
     &                           nghostpoints,                          &
     &                           ewperiodic(ng), nsperiodic(ng),        &
     &                           f_vbar)
# endif
        END IF
 
# ifdef SOLVE3D
!
!  3D u-momentum component.
!
        DO k=1,n(ng)
          DO i=lbi,ubi
            DO j=lbj,ubj
              f_u(i,j,k)=0.0_r8
            END DO
          END DO
        END DO
        IF (fourdvar(ng)%ObsCount(isuvel).gt.0) THEN
          DO k=1,n(ng)
            DO j=jstr-1,jend+1
              DO i=istru-1,iend+1
                z_v(i,j,k)=0.5_r8*(z_r(i-1,j,k)+                        &
     &                             z_r(i  ,j,k))
              END DO
            END DO
          END DO
          CALL ad_extract_obs3d (ng, 1, lm(ng)+1, 0, mm(ng)+1,          &
     &                           lbi, ubi, lbj, ubj, 1, n(ng),          &
     &                           obsstate2type(isuvel),                 &
     &                           mobs, mstr, mend,                      &
     &                           uxmin(ng), uxmax(ng),                  &
     &                           uymin(ng), uymax(ng),                  &
     &                           time(ng), dt(ng),                      &
     &                           obstype, obsvetting,                   &
     &                           tobs, xobs, yobs, zobs,                &
     &                           f_u, z_v,                              &
#  ifdef MASKING
     &                           umask,                                 &
#  endif
     &                           admodval)
#  ifdef DISTRIBUTE
          CALL ad_mp_exchange3d (ng, tile, iadm, 1,                     &
     &                           lbi, ubi, lbj, ubj, 1, n(ng),          &
     &                           nghostpoints,                          &
     &                           ewperiodic(ng), nsperiodic(ng),        &
     &                           f_u)
#  endif
        END IF
!
!  3D v-momentum component.
!
        DO k=1,n(ng)
          DO i=lbi,ubi
            DO j=lbj,ubj
              f_v(i,j,k)=0.0_r8
            END DO
          END DO
        END DO
        IF (fourdvar(ng)%ObsCount(isvvel).gt.0) THEN
          DO k=1,n(ng)
            DO j=jstrv-1,jend+1
              DO i=istr-1,iend+1
                z_v(i,j,k)=0.5_r8*(z_r(i,j-1,k)+                        &
     &                             z_r(i,j  ,k))
              END DO
            END DO
          END DO
          CALL ad_extract_obs3d (ng, 0, lm(ng)+1, 1, mm(ng)+1,          &
     &                           lbi, ubi, lbj, ubj, 1, n(ng),          &
     &                           obsstate2type(isvvel),                 &
     &                           mobs, mstr, mend,                      &
     &                           vxmin(ng), vxmax(ng),                  &
     &                           vymin(ng), vymax(ng),                  &
     &                           time(ng), dt(ng),                      &
     &                           obstype, obsvetting,                   &
     &                           tobs, xobs, yobs, zobs,                &
     &                           f_v, z_v,                              &
#  ifdef MASKING
     &                           vmask,                                 &
#  endif
     &                           admodval)
#  ifdef DISTRIBUTE
          CALL ad_mp_exchange3d (ng, tile, iadm, 1,                     &
     &                           lbi, ubi, lbj, ubj, 1, n(ng),          &
     &                           nghostpoints,                          &
     &                           ewperiodic(ng), nsperiodic(ng),        &
     &                           f_v)
#  endif
        END IF
!
!  Radial Velocity.  The observations are in terms of radial speed and
!  angle (stored in obs_meta).  The observation angle converts the
!  velocity components to geographical EAST and North components.
#  ifdef RADIAL_ANGLE_CCW_EAST
!  The radial velocity observations are processed as magnitude and
!  heading angle (obs_meta; radians) in the math convention: an
!  azimuth that is counterclockwise from TRUE East.
!
!  In curvilinear coordinates, the radial forward problem is:
!
!     radial = u * COS(obs_meta - angler) + v * SIN(obs_meta - angler)
!
!  In the adjoint, u and v are given by:
!
!        f_v = f_v + ADmodVal * SIN(obs_meta - angler)
!        f_u = f_u + ADmodVal * COS(obs_meta - angler)
#  else
!  By default, the radial velocity observations are processed as
!  magnitude and heading angle (obs_meta; radians) in the navigation
!  convention: an azimuth that is clockwise from TRUE North.
!
!  In curvilinear coordinates, the radial forward problem is:
!
!     radial = u * SIN(obs_meta + angler) + v * COS(obs_meta + angler)
!
!  In the adjoint, u and v are given by:
!
!        f_v = f_v + ADmodVal * COS(obs_meta + angler)
!        f_u = f_u + ADmodVal * SIN(obs_meta + angler)
#  endif
!
        IF (fourdvar(ng)%ObsCount(isradial).gt.0) THEN
          DO iobs=mstr,mend
            ad_uradial(iobs)=inival
            ad_vradial(iobs)=inival
          END DO
          DO iobs=mstr,mend
            IF (obstype(iobs).eq.obsstate2type(isradial)) THEN
#  ifdef RADIAL_ANGLE_CCW_EAST
#   ifdef CURVGRID
              angle=obsmeta(iobs)-obsangler(iobs)
              ad_uradial(iobs)=ad_uradial(iobs)+                        &
     &                         admodval(iobs)*cos(angle)
              ad_vradial(iobs)=ad_vradial(iobs)+                        &
     &                         admodval(iobs)*sin(angle)
#   else
              ad_uradial(iobs)=ad_uradial(iobs)+                        &
     &                         admodval(iobs)*cos(obsmeta(iobs))
              ad_vradial(iobs)=ad_vradial(iobs)+                        &
     &                         admodval(iobs)*sin(obsmeta(iobs))
#   endif
#  else
#   ifdef CURVGRID
              angle=obsmeta(iobs)+obsangler(iobs)
              ad_uradial(iobs)=ad_uradial(iobs)+                        &
     &                         admodval(iobs)*sin(angle)
              ad_vradial(iobs)=ad_vradial(iobs)+                        &
     &                         admodval(iobs)*cos(angle)
#   else
              ad_uradial(iobs)=ad_uradial(iobs)+                        &
     &                         admodval(iobs)*sin(obsmeta(iobs))
              ad_vradial(iobs)=ad_vradial(iobs)+                        &
     &                         admodval(iobs)*cos(obsmeta(iobs))
#   endif
#  endif
              admodval(iobs)=0.0_r8
            END IF
          END DO
          DO k=1,n(ng)
            DO j=jstrv-1,jend+1
              DO i=istr-1,iend+1
                z_v(i,j,k)=0.5_r8*(z_r(i,j-1,k)+                        &
     &                             z_r(i,j  ,k))
              END DO
            END DO
          END DO
          CALL ad_extract_obs3d (ng, 0, lm(ng)+1, 1, mm(ng)+1,          &
     &                           lbi, ubi, lbj, ubj, 1, n(ng),          &
     &                           obsstate2type(isradial),               &
     &                           mobs, mstr, mend,                      &
     &                           vxmin(ng), vxmax(ng),                  &
     &                           vymin(ng), vymax(ng),                  &
     &                           time(ng), dt(ng),                      &
     &                           obstype, obsvetting,                   &
     &                           tobs, xobs, yobs, zobs,                &
     &                           f_v, z_v,                              &
#  ifdef MASKING
     &                           vmask,                                 &
#  endif
     &                           ad_vradial)
          DO k=1,n(ng)
            DO j=jstr-1,jend+1
              DO i=istru-1,iend+1
                z_v(i,j,k)=0.5_r8*(z_r(i-1,j,k)+                        &
     &                             z_r(i  ,j,k))
              END DO
            END DO
          END DO
          CALL ad_extract_obs3d (ng, 1, lm(ng)+1, 0, mm(ng)+1,          &
     &                           lbi, ubi, lbj, ubj, 1, n(ng),          &
     &                           obsstate2type(isradial),               &
     &                           mobs, mstr, mend,                      &
     &                           uxmin(ng), uxmax(ng),                  &
     &                           uymin(ng), uymax(ng),                  &
     &                           time(ng), dt(ng),                      &
     &                           obstype, obsvetting,                   &
     &                           tobs, xobs, yobs, zobs,                &
     &                           f_u, z_v,                              &
#  ifdef MASKING
     &                           umask,                                 &
#  endif
     &                           ad_uradial)
        END IF
 
#  ifdef DISTRIBUTE
!
!  Exchange adjoint velocites forcing terms, after all the 3D velocity
!  observations are processed.
!
        IF ((fourdvar(ng)%ObsCount(isuvel).gt.0).or.                    &
     &      (fourdvar(ng)%ObsCount(isvvel).gt.0).or.                    &
     &      (fourdvar(ng)%ObsCount(isradial).gt.0)) THEN
          CALL ad_mp_exchange3d (ng, tile, iadm, 2,                     &
     &                           lbi, ubi, lbj, ubj, 1, n(ng),          &
     &                           nghostpoints, ewperiodic(ng),          &
     &                           nsperiodic(ng), f_u, f_v)
        END IF
#  endif
!
!  Tracer type variables.
!
        DO itrc=1,nt(ng)
          DO k=1,n(ng)
            DO i=lbi,ubi
              DO j=lbj,ubj
                f_t(i,j,k,itrc)=0.0_r8
              END DO
            END DO
          END DO
          IF (fourdvar(ng)%ObsCount(istvar(itrc)).gt.0) THEN
            CALL ad_extract_obs3d (ng, 0, lm(ng)+1, 0, mm(ng)+1,        &
     &                             lbi, ubi, lbj, ubj, 1, n(ng),        &
     &                             obsstate2type(istvar(itrc)),         &
     &                             mobs, mstr, mend,                    &
     &                             rxmin(ng), rxmax(ng),                &
     &                             rymin(ng), rymax(ng),                &
     &                             time(ng), dt(ng),                    &
     &                             obstype, obsvetting,                 &
     &                             tobs, xobs, yobs, zobs,              &
     &                             f_t(:,:,:,itrc), z_r,                &
#  ifdef MASKING
     &                             rmask,                               &
#  endif
     &                             admodval)
#  ifdef DISTRIBUTE
            CALL ad_mp_exchange3d (ng, tile, iadm, 1,                   &
     &                             lbi, ubi, lbj, ubj, 1, n(ng),        &
     &                             nghostpoints,                        &
     &                             ewperiodic(ng), nsperiodic(ng),      &
     &                             f_t(:,:,:,itrc))
#  endif
 
          END IF
        END DO
# endif
# ifdef DISTRIBUTE
!
!-----------------------------------------------------------------------
!  For debugging purposes, collect all observations reject/accept
!  processing flag.
!-----------------------------------------------------------------------
!
        ncollect=mend-mstr+1
        CALL mp_collect (ng, model, ncollect, inival,                   &
     &                   obsvetting(mstr:))
# endif
!
!-----------------------------------------------------------------------
!  Set counters for the number of rejected observations for each state
!  variable. Although unnecessary, the counters are recomputed here to
!  check if "ObsScale" changed from its initial values.
!-----------------------------------------------------------------------
!
        DO iobs=mstr,mend
          IF (obsscale(iobs).lt.1.0) THEN
            IF  (obstype(iobs).eq.obsstate2type(isfsur)) THEN
              fourdvar(ng)%ObsReject(isfsur)=                           &
     &                              fourdvar(ng)%ObsReject(isfsur)+1
            ELSE IF (obstype(iobs).eq.obsstate2type(isubar)) THEN
              fourdvar(ng)%ObsReject(isubar)=                           &
     &                              fourdvar(ng)%ObsReject(isubar)+1
            ELSE IF (obstype(iobs).eq.obsstate2type(isvbar)) THEN
              fourdvar(ng)%ObsReject(isvbar)=                           &
     &                              fourdvar(ng)%ObsReject(isvbar)+1
# ifdef SOLVE3D
            ELSE IF (obstype(iobs).eq.obsstate2type(isuvel)) THEN
              fourdvar(ng)%ObsReject(isuvel)=                           &
     &                              fourdvar(ng)%ObsReject(isuvel)+1
            ELSE IF (obstype(iobs).eq.obsstate2type(isvvel)) THEN
              fourdvar(ng)%ObsReject(isvvel)=                           &
     &                              fourdvar(ng)%ObsReject(isvvel)+1
            ELSE IF (obstype(iobs).eq.obsstate2type(isradial)) THEN
              fourdvar(ng)%ObsReject(isradial)=                         &
     &                              fourdvar(ng)%ObsReject(isradial)+1
            ELSE
              DO itrc=1,nt(ng)
                IF (obstype(iobs).eq.obsstate2type(istvar(itrc))) THEN
                  i=istvar(itrc)
                  fourdvar(ng)%ObsReject(i)=fourdvar(ng)%ObsReject(i)+1
                END IF
              END DO
# endif
            END IF
          END IF
        END DO
!
!  Load total available and rejected observations into structure
!  array.
!
        DO i=1,nobsvar(ng)
          fourdvar(ng)%ObsCount(0)=fourdvar(ng)%ObsCount(0)+            &
     &                             fourdvar(ng)%ObsCount(i)
          fourdvar(ng)%ObsReject(0)=fourdvar(ng)%ObsReject(0)+          &
     &                              fourdvar(ng)%ObsReject(i)
        END DO
!
!  Report.
!
        IF (domain(ng)%SouthWest_Test(tile)) THEN
          IF (master) THEN
            obssum=0
            obsvoid=0
            is=nstrobs(ng)
            DO i=1,nobsvar(ng)
              IF (fourdvar(ng)%ObsCount(i).gt.0) THEN
                ie=is+fourdvar(ng)%ObsCount(i)-1
                WRITE (stdout,10) trim(obsname(i)), is, ie,             &
     &                            ie-is+1, fourdvar(ng)%ObsReject(i)
                is=ie+1
                obssum=obssum+fourdvar(ng)%ObsCount(i)
                obsvoid=obsvoid+fourdvar(ng)%ObsReject(i)
              END IF
            END DO
            WRITE (stdout,20) obssum, obsvoid,                          &
     &                        fourdvar(ng)%ObsCount(0),                 &
     &                        fourdvar(ng)%ObsReject(0)
            WRITE (stdout,30) time_code(ng), nstrobs(ng), nendobs(ng),  &
     &                        iic(ng)
  10        FORMAT (10x,a,t25,4(1x,i10))
  20        FORMAT (/,10x,'Total',t47,2(1x,i10),                        &
     &              /,10x,'Obs Tally',t47,2(1x,i10),/)
  30        FORMAT (3x,' AD_HTOBS    - Computed adjoint observations ', &
     &              'forcing,',t68,a,/,19x,'(Observation ',      &
     &              'records = ',i7.7,' - ',i7.7,', iic = ',i7.7,')')
          END IF
        END IF
      END IF
      RETURN
      END SUBROUTINE ad_htobs_tile
#endif
      END MODULE ad_htobs_mod