ufo_gnssro_bndropp2d_tlad_mod_stub.F90

Go to the documentation of this file.

! (C) Copyright 2017-2018 UCAR
! 
! 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. 
 
!> Stubbed Fortran module for gnssro bending angle ropp2d tangent linear and adjoint
!> following the ROPP (2018 Aug) implementation
 
module ufo_gnssro_bndropp2d_tlad_mod
 
use fckit_configuration_module, only: fckit_configuration 
use kinds
use ufo_vars_mod
use ufo_geovals_mod
use ufo_geovals_mod_c,   only: ufo_geovals_registry
use vert_interp_mod
use ufo_basis_tlad_mod,  only: ufo_basis_tlad
use obsspace_mod
use gnssro_mod_conf
use missing_values_mod
use fckit_log_module, only : fckit_log
 
integer, parameter         :: max_string=800
 
!> Fortran derived type for gnssro trajectory
type, extends(ufo_basis_tlad)   ::  ufo_gnssro_bndropp2d_tlad
  private
  integer                       :: nval, nlocs
  real(kind_real), allocatable  :: prs(:,:), t(:,:), q(:,:), gph(:,:), gph_sfc(:,:)
  integer                       :: n_horiz      ! 2d points along ray path
  integer                       :: iflip        ! geoval ascending order flag
  type(gnssro_conf)             :: roconf       ! ro configuration
  real(kind_real), allocatable  :: obslon2d(:), obslat2d(:)  !2d locations - nobs*n_horiz
  contains
    procedure :: setup      => ufo_gnssro_bndropp2d_tlad_setup
    procedure :: delete     => ufo_gnssro_bndropp2d_tlad_delete
    procedure :: settraj    => ufo_gnssro_bndropp2d_tlad_settraj
    procedure :: simobs_tl  => ufo_gnssro_bndropp2d_simobs_tl
    procedure :: simobs_ad  => ufo_gnssro_bndropp2d_simobs_ad
end type ufo_gnssro_bndropp2d_tlad
 
contains
 
! ------------------------------------------------------------------------------
subroutine ufo_gnssro_bndropp2d_tlad_setup(self, f_conf)
  implicit none
  class(ufo_gnssro_bndropp2d_tlad), intent(inout) :: self
  type(fckit_configuration), intent(in) :: f_conf
 
  call gnssro_conf_setup(self%roconf,f_conf)
 
end subroutine ufo_gnssro_bndropp2d_tlad_setup
 
! ------------------------------------------------------------------------------    
subroutine ufo_gnssro_bndropp2d_tlad_settraj(self, geovals, obss)
       
  implicit none
  class(ufo_gnssro_bndropp2d_tlad), intent(inout) :: self
  type(ufo_geovals),                intent(in)    :: geovals
  type(c_ptr), value,               intent(in)    :: obss
  character(len=*), parameter :: myname_="ufo_gnssro_bndropp2d_tlad_settraj"
  character(max_string)       :: err_msg
  type(ufo_geoval), pointer   :: t, q, prs, gph, gph_sfc
  integer                     :: iobs
 
  write(err_msg,*) "TRACE: ufo_gnssro_bndropp2d_tlad_settraj: begin"
  call fckit_log%info(err_msg) 
 
! get model state variables from geovals
  call ufo_geovals_get_var(geovals, var_ts,    t)         ! temperature
  call ufo_geovals_get_var(geovals, var_q,     q)         ! specific humidity
  call ufo_geovals_get_var(geovals, var_prs,   prs)       ! pressure
  call ufo_geovals_get_var(geovals, var_z,     gph)       ! geopotential height
      
  call self%delete()   
 
! Keep copy of dimensions
  self%nval = prs%nval
  self%nlocs = obsspace_get_nlocs(obss)
 
  allocate(self%t(self%nval,self%nlocs))
  allocate(self%q(self%nval,self%nlocs))
  allocate(self%prs(self%nval,self%nlocs))
  allocate(self%gph(self%nval,self%nlocs))
 
! allocate  
  self%gph     = gph%vals
  self%t       = t%vals
  self%q       = q%vals
  self%prs     = prs%vals
 
  self%ltraj   = .true.
       
end subroutine ufo_gnssro_bndropp2d_tlad_settraj
    
! ------------------------------------------------------------------------------
! ------------------------------------------------------------------------------    
subroutine ufo_gnssro_bndropp2d_simobs_tl(self, geovals, hofx, obss)
 
  implicit none
  class(ufo_gnssro_bndropp2d_tlad), intent(in)    :: self
  type(ufo_geovals),                intent(in)    :: geovals   ! perturbed quantities
  real(kind_real),                  intent(inout) :: hofx(:)
  type(c_ptr),   value,             intent(in)    :: obss
 
  integer                         :: iobs,nlev, nlocs, nvprof
    
  character(len=*), parameter  :: myname_="ufo_gnssro_bndropp2d_simobs_tl"
  character(max_string)        :: err_msg
  type(ufo_geoval), pointer    :: t_d, q_d, prs_d 
 
! hack - set local geopotential height to zero for ropp routines
  real(kind_real), allocatable :: gph_d_zero(:)
  real(kind_real)              :: gph_sfc_d_zero 
  real(kind_real), allocatable :: obslat(:), obslon(:), obsimpp(:), obslocr(:), obsgeoid(:)
! hack - set local geopotential height to zero for ropp routines
  integer                       :: n_horiz
 
  n_horiz = self%roconf%n_horiz
 
  write(err_msg,*) "TRACE: ufo_gnssro_bndropp2d_simobs_tl_stub: begin"
  call fckit_log%info(err_msg)
 
! check if trajectory was set
  if (.not. self%ltraj) then
     write(err_msg,*) myname_, ' trajectory wasnt set!'
     call abor1_ftn(err_msg)
  endif
      
! check if nlocs is consistent in geovals & hofx
  if (geovals%nlocs /= size(hofx)*n_horiz) then
     write(err_msg,*) myname_, ' error: nlocs inconsistent!'
     call abor1_ftn(err_msg)
  endif
 
! get variables from geovals
  call ufo_geovals_get_var(geovals, var_ts,    t_d)         ! temperature
  call ufo_geovals_get_var(geovals, var_q,     q_d)         ! specific humidity
  call ufo_geovals_get_var(geovals, var_prs,   prs_d)       ! pressure
 
  nlev  = self%nval 
  nlocs  = self%nlocs ! number of observations
 
  allocate(gph_d_zero(nlev))
  gph_d_zero     = 0.0
  gph_sfc_d_zero = 0.0
 
! set obs space struture
  allocate(obslon(nlocs))
  allocate(obslat(nlocs))
  allocate(obsimpp(nlocs))
  allocate(obslocr(nlocs))
  allocate(obsgeoid(nlocs))
  call obsspace_get_db(obss, "MetaData", "longitude",        obslon)
  call obsspace_get_db(obss, "MetaData", "latitude",         obslat)
  call obsspace_get_db(obss, "MetaData", "impact_parameter", obsimpp)
  call obsspace_get_db(obss, "MetaData", "earth_radius_of_curvature", obslocr)
  call obsspace_get_db(obss, "MetaData", "geoid_height_above_reference_ellipsoid", obsgeoid) 
 
  nvprof = 1  ! no. of bending angles in profile 
 
! tidy up - deallocate obsspace structures
  deallocate(obslat) 
  deallocate(obslon)
  deallocate(obsimpp)
  deallocate(obslocr)
  deallocate(obsgeoid)
 
  write(err_msg,*) "TRACE: ufo_gnssro_bndropp2d_simobs_tl_stub: complete"
  call fckit_log%info(err_msg)
 
  return
    
end subroutine ufo_gnssro_bndropp2d_simobs_tl
 
! ------------------------------------------------------------------------------
! ------------------------------------------------------------------------------
subroutine ufo_gnssro_bndropp2d_simobs_ad(self, geovals, hofx, obss)
 
  implicit none
  class(ufo_gnssro_bndropp2d_tlad), intent(in)    :: self
  type(ufo_geovals),                intent(inout) :: geovals   ! perturbed quantities
  real(kind_real),                  intent(in)    :: hofx(:)
  type(c_ptr),  value,              intent(in)    :: obss
  real(c_double)              :: missing
 
  type(ufo_geoval),     pointer   :: t_d, q_d, prs_d 
! set local geopotential height to zero for ropp routines
  real(kind_real),      parameter :: gph_sfc_d_zero = 0.0
  real(kind_real),    allocatable :: gph_d_zero(:)
 
  real(kind_real),    allocatable :: obslat(:), obslon(:), obsimpp(:), obslocr(:), obsgeoid(:)
  integer                         :: iobs,nlev, nlocs, nvprof
  integer                         :: n_horiz
  character(len=*), parameter     :: myname_="ufo_gnssro_bndropp2d_simobs_ad"
  character(max_string)           :: err_msg
 
 
  write(err_msg,*) "TRACE: ufo_gnssro_bndropp2d_simobs_ad_stub: begin"
  call fckit_log%info(err_msg)
 
! check if trajectory was set
  if (.not. self%ltraj) then
     write(err_msg,*) myname_, ' trajectory wasnt set!'
     call abor1_ftn(err_msg)
  endif
 
  n_horiz = self%roconf%n_horiz
 
! check if nlocs is consistent in geovals & hofx
  if (geovals%nlocs /= size(hofx)*n_horiz) then
     write(err_msg,*) myname_, ' error: nlocs inconsistent!'
     call abor1_ftn(err_msg)
  endif
     
! get variables from geovals
  call ufo_geovals_get_var(geovals, var_ts,    t_d)         ! temperature
  call ufo_geovals_get_var(geovals, var_q,     q_d)         ! specific humidity
  call ufo_geovals_get_var(geovals, var_prs,   prs_d)       ! pressure
 
! allocate if not yet allocated   
  if (.not. allocated(t_d%vals)) then
      t_d%nlocs = self%nlocs
      t_d%nval = self%nval
      allocate(t_d%vals(t_d%nval,t_d%nlocs))
      t_d%vals = 0.0_kind_real
  endif
 
  if (.not. allocated(prs_d%vals)) then
      prs_d%nlocs = self%nlocs
      prs_d%nval = self%nval
      allocate(prs_d%vals(prs_d%nval,prs_d%nlocs))
      prs_d%vals = 0.0_kind_real
  endif
 
  if (.not. allocated(q_d%vals)) then
      q_d%nlocs = self%nlocs
      q_d%nval = self%nval
      allocate(q_d%vals(q_d%nval,q_d%nlocs))
      q_d%vals = 0.0_kind_real
  endif
 
  if (.not. geovals%linit ) geovals%linit=.true.
 
  nlev  = self%nval 
  nlocs  = self%nlocs
 
  allocate(gph_d_zero(nlev))
  gph_d_zero = 0.0
 
! set obs space struture
  allocate(obslon(nlocs))
  allocate(obslat(nlocs))
  allocate(obsimpp(nlocs))
  allocate(obslocr(nlocs))
  allocate(obsgeoid(nlocs))
 
  call obsspace_get_db(obss, "MetaData", "longitude",        obslon)
  call obsspace_get_db(obss, "MetaData", "latitude",         obslat)
  call obsspace_get_db(obss, "MetaData", "impact_parameter", obsimpp)
  call obsspace_get_db(obss, "MetaData", "earth_radius_of_curvature", obslocr)
  call obsspace_get_db(obss, "MetaData", "geoid_height_above_reference_ellipsoid", obsgeoid)
 
  missing = missing_value(missing)
 
! tidy up - deallocate obsspace structures
  deallocate(obslat) 
  deallocate(obslon)
  deallocate(obsimpp)
  deallocate(obslocr)
  deallocate(obsgeoid)
  deallocate(gph_d_zero)
 
  write(err_msg,*) "TRACE: ufo_gnssro_bndropp2d_simobs_ad_stub: complete"
  call fckit_log%info(err_msg)
 
  return
 
end subroutine ufo_gnssro_bndropp2d_simobs_ad
    
!-------------------------------------------------------------------------
!-------------------------------------------------------------------------
subroutine ufo_gnssro_bndropp2d_tlad_delete(self)
 
  implicit none
  class(ufo_gnssro_bndropp2d_tlad), intent(inout) :: self
  character(len=*), parameter :: myname_="ufo_gnssro_bndropp_tlad_delete"
      
  self%nval = 0
  if (allocated(self%prs)) deallocate(self%prs)
  if (allocated(self%t))   deallocate(self%t)
  if (allocated(self%q))   deallocate(self%q)
  if (allocated(self%gph)) deallocate(self%gph)
!  if (allocated(self%gph_sfc)) deallocate(self%gph_sfc)
 
  self%ltraj = .false. 
 
end subroutine ufo_gnssro_bndropp2d_tlad_delete
 
!-------------------------------------------------------------------------
       
end module ufo_gnssro_bndropp2d_tlad_mod