ufo_gnssroonedvarcheck_pen_mod.f90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
! (C) British Crown Copyright 2020 Met Office
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
!-------------------------------------------------------------------------------
 
!> Calculates GPSRO penalty.
 
module ufo_gnssroonedvarcheck_pen_mod
 
use kinds, only: kind_real
use missing_values_mod, only: missing_value
 
private
public :: ops_gpsro_pen
 
contains
 
SUBROUTINE ops_gpsro_pen (Nstate,   &   ! size of state vec.
                          Nobs,     &   ! size of obs vec.
                          x,        &   ! current estimate of soltution
                          xb,       &   ! background
                          yobs,     &   ! observed values
                          ycalc,    &   ! y(x)
                          bm1,      &   ! inverse .of bsck cov matrix
                          om1,      &   ! inv. of obs+forw cov matrix
                          pen_ob,   &   ! obs penalty
                          pen_back, &   ! back penalty
                          pen_func)     ! total penalty
 
 
IMPLICIT NONE
 
! Subroutine arguments:
INTEGER, INTENT(IN)         :: nstate
INTEGER, INTENT(IN)         :: nobs
REAL(kind_real), INTENT(IN)            :: x(:)
REAL(kind_real), INTENT(IN)            :: xb(:)
REAL(kind_real), INTENT(IN)            :: yobs(:)
REAL(kind_real), INTENT(IN)            :: ycalc(:)
REAL(kind_real), INTENT(IN)            :: bm1(:,:)
REAL(kind_real), INTENT(IN)            :: om1(:,:)
REAL(kind_real),  INTENT(OUT)          :: pen_ob
REAL(kind_real),  INTENT(OUT)          :: pen_back
REAL(kind_real),  INTENT(OUT)          :: pen_func
 
! Local declarations:
REAL(kind_real)                        :: dx(nstate)
REAL(kind_real)                        :: dy(nobs)
REAL(kind_real)                        :: bdx(nstate)
REAL(kind_real)                        :: ody(nobs)
REAL(kind_real)                        :: j_back
REAL(kind_real)                        :: j_obs
CHARACTER(len=*), PARAMETER :: routinename = "Ops_GPSRO_pen"
 
! deviation from background
 
dx(:) = x(:) - xb(:)
 
! calc. Bdx matrix   ie B^-1(x-xb)
 
bdx(:) = matmul(bm1(:,:), dx(:))
 
! background term (scalar)
 
j_back = dot_product(dx(:), bdx(:))
 
! obs. meas-calc
 
dy(:) = yobs(:) - ycalc(:)
 
!make sure missing data is not included
WHERE (ycalc(:) == missing_value(ycalc(1)) .OR. &
       yobs(:) == missing_value(yobs(1)))
 
  dy(:) = 0.0
END WHERE
 
! Ody   O^-1 (ymeas-ycalc)
 
ody(:) = matmul(om1(:,:), dy(:))
 
! observation term. (scalar)
 
j_obs = dot_product(dy(:), ody(:))
 
! SCALAR value required
 
pen_func = 0.5 * (j_back + j_obs)
 
pen_ob = 0.5 * j_obs
pen_back = 0.5 * j_back
 
END SUBROUTINE ops_gpsro_pen
 
end module ufo_gnssroonedvarcheck_pen_mod