UFO
ufo_gnssro_bndropp1d_tlad_mod_stub.F90
Go to the documentation of this file.
1 ! (C) Copyright 2017-2018 UCAR
2 !
3 ! This software is licensed under the terms of the Apache Licence Version 2.0
4 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
5 
6 !> Stubbed Fortran module for gnssro bending angle ropp1d tangent linear and adjoint
7 !> following the ROPP (2018 Aug) implementation
8 
9 module ufo_gnssro_bndropp1d_tlad_mod
10 
11 use iso_c_binding
12 use kinds
13 use ufo_vars_mod
14 use ufo_geovals_mod
15 use ufo_geovals_mod_c, only: ufo_geovals_registry
16 use vert_interp_mod
17 use ufo_basis_tlad_mod, only: ufo_basis_tlad
18 use obsspace_mod
19 use gnssro_mod_conf
20 use missing_values_mod
21 use fckit_log_module, only : fckit_log
22 
23 integer, parameter :: max_string=800
24 
25 !> Fortran derived type for gnssro trajectory
26 type, extends(ufo_basis_tlad) :: ufo_gnssro_bndropp1d_tlad
27  private
28  integer :: nval, nlocs
29  real(kind_real), allocatable :: prs(:,:), t(:,:), q(:,:), gph(:,:), gph_sfc(:,:)
30  contains
31  procedure :: delete => ufo_gnssro_bndropp1d_tlad_delete
32  procedure :: settraj => ufo_gnssro_bndropp1d_tlad_settraj
33  procedure :: simobs_tl => ufo_gnssro_bndropp1d_simobs_tl
34  procedure :: simobs_ad => ufo_gnssro_bndropp1d_simobs_ad
35 end type ufo_gnssro_bndropp1d_tlad
36 
37 contains
38 
39 ! ------------------------------------------------------------------------------
40 ! ------------------------------------------------------------------------------
41 subroutine ufo_gnssro_bndropp1d_tlad_settraj(self, geovals, obss)
42 
43  implicit none
44  class(ufo_gnssro_bndropp1d_tlad), intent(inout) :: self
45  type(ufo_geovals), intent(in) :: geovals
46  type(c_ptr), value, intent(in) :: obss
47  character(len=*), parameter :: myname_="ufo_gnssro_bndropp1d_tlad_settraj"
48  character(max_string) :: err_msg
49  type(ufo_geoval), pointer :: t, q, prs, gph, gph_sfc
50  integer :: iobs
51 
52  write(err_msg,*) "TRACE: ufo_gnssro_bndropp1d_tlad_settraj: begin"
53  call fckit_log%info(err_msg)
54 
55 ! get model state variables from geovals
56  call ufo_geovals_get_var(geovals, var_ts, t) ! temperature
57  call ufo_geovals_get_var(geovals, var_q, q) ! specific humidity
58  call ufo_geovals_get_var(geovals, var_prs, prs) ! pressure
59  call ufo_geovals_get_var(geovals, var_z, gph) ! geopotential height
60  call ufo_geovals_get_var(geovals, var_sfc_geomz, gph_sfc) ! surface geopotential height
61 
62  call self%delete()
63 
64 ! Keep copy of dimensions
65  self%nval = prs%nval
66  self%nlocs = obsspace_get_nlocs(obss)
67 
68  allocate(self%t(self%nval,self%nlocs))
69  allocate(self%q(self%nval,self%nlocs))
70  allocate(self%prs(self%nval,self%nlocs))
71  allocate(self%gph(self%nval,self%nlocs))
72  allocate(self%gph_sfc(1,self%nlocs))
73 
74 ! allocate
75  self%gph = gph%vals
76  self%t = t%vals
77  self%q = q%vals
78  self%prs = prs%vals
79  self%gph_sfc = gph_sfc%vals
80 
81  self%ltraj = .true.
82 
83 end subroutine ufo_gnssro_bndropp1d_tlad_settraj
84 
85 ! ------------------------------------------------------------------------------
86 ! ------------------------------------------------------------------------------
87 subroutine ufo_gnssro_bndropp1d_simobs_tl(self, geovals, hofx, obss)
88  implicit none
89  class(ufo_gnssro_bndropp1d_tlad), intent(in) :: self
90  type(ufo_geovals), intent(in) :: geovals ! perturbed quantities
91  real(kind_real), intent(inout) :: hofx(:)
92  type(c_ptr), value, intent(in) :: obss
93 
94  integer :: iobs,nlev, nlocs
95 
96  character(len=*), parameter :: myname_="ufo_gnssro_bndropp1d_simobs_tl"
97  character(max_string) :: err_msg
98  type(ufo_geoval), pointer :: t_d, q_d, prs_d
99 
100 ! hack - set local geopotential height to zero for ropp routines
101  real(kind_real), allocatable :: gph_d_zero(:)
102  real(kind_real) :: gph_sfc_d_zero
103  real(kind_real), allocatable :: obslat(:), obslon(:), obsimpp(:), obslocr(:), obsgeoid(:)
104 ! hack - set local geopotential height to zero for ropp routines
105 
106  write(err_msg,*) "TRACE: ufo_gnssro_bndropp1d_simobs_tl: begin"
107  call fckit_log%info(err_msg)
108 
109 ! check if trajectory was set
110  if (.not. self%ltraj) then
111  write(err_msg,*) myname_, ' trajectory wasnt set!'
112  call abor1_ftn(err_msg)
113  endif
114 
115 ! check if nlocs is consistent in geovals & hofx
116  if (geovals%nlocs /= size(hofx)) then
117  write(err_msg,*) myname_, ' error: nlocs inconsistent!'
118  call abor1_ftn(err_msg)
119  endif
120 
121 ! get variables from geovals
122  call ufo_geovals_get_var(geovals, var_ts, t_d) ! temperature
123  call ufo_geovals_get_var(geovals, var_q, q_d) ! specific humidity
124  call ufo_geovals_get_var(geovals, var_prs, prs_d) ! pressure
125 
126  nlev = self%nval
127  nlocs = self%nlocs ! number of observations
128 
129  allocate(gph_d_zero(nlev))
130  gph_d_zero = 0.0
131  gph_sfc_d_zero = 0.0
132 
133 ! set obs space struture
134  allocate(obslon(nlocs))
135  allocate(obslat(nlocs))
136  allocate(obsimpp(nlocs))
137  allocate(obslocr(nlocs))
138  allocate(obsgeoid(nlocs))
139  call obsspace_get_db(obss, "MetaData", "longitude", obslon)
140  call obsspace_get_db(obss, "MetaData", "latitude", obslat)
141  call obsspace_get_db(obss, "MetaData", "impact_parameter", obsimpp)
142  call obsspace_get_db(obss, "MetaData", "earth_radius_of_curvature", obslocr)
143  call obsspace_get_db(obss, "MetaData", "geoid_height_above_reference_ellipsoid", obsgeoid)
144 
145 ! tidy up - deallocate obsspace structures
146  deallocate(obslat)
147  deallocate(obslon)
148  deallocate(obsimpp)
149  deallocate(obslocr)
150  deallocate(obsgeoid)
151 
152  write(err_msg,*) "TRACE: ufo_gnssro_bndropp1d_simobs_tl: complete"
153  call fckit_log%info(err_msg)
154 
155  return
156 
157 end subroutine ufo_gnssro_bndropp1d_simobs_tl
158 
159 ! ------------------------------------------------------------------------------
160 ! ------------------------------------------------------------------------------
161 subroutine ufo_gnssro_bndropp1d_simobs_ad(self, geovals, hofx, obss)
162  implicit none
163  class(ufo_gnssro_bndropp1d_tlad), intent(in) :: self
164  type(ufo_geovals), intent(inout) :: geovals ! perturbed quantities
165  real(kind_real), intent(in) :: hofx(:)
166  type(c_ptr), value, intent(in) :: obss
167  real(c_double) :: missing
168 
169  type(ufo_geoval), pointer :: t_d, q_d, prs_d
170 ! set local geopotential height to zero for ropp routines
171  real(kind_real), parameter :: gph_sfc_d_zero = 0.0
172  real(kind_real), allocatable :: gph_d_zero(:)
173 
174  real(kind_real), allocatable :: obslat(:), obslon(:), obsimpp(:), obslocr(:), obsgeoid(:)
175  integer :: iobs,nlev, nlocs
176  character(len=*), parameter :: myname_="ufo_gnssro_bndropp1d_simobs_ad"
177  character(max_string) :: err_msg
178 
179  write(err_msg,*) "TRACE: ufo_gnssro_bndropp1d_simobs_ad: begin"
180  call fckit_log%info(err_msg)
181 
182 ! check if trajectory was set
183  if (.not. self%ltraj) then
184  write(err_msg,*) myname_, ' trajectory wasnt set!'
185  call abor1_ftn(err_msg)
186  endif
187 ! check if nlocs is consistent in geovals & hofx
188  if (geovals%nlocs /= size(hofx)) then
189  write(err_msg,*) myname_, ' error: nlocs inconsistent!'
190  call abor1_ftn(err_msg)
191  endif
192 
193 ! get variables from geovals
194  call ufo_geovals_get_var(geovals, var_ts, t_d) ! temperature
195  call ufo_geovals_get_var(geovals, var_q, q_d) ! specific humidity
196  call ufo_geovals_get_var(geovals, var_prs, prs_d) ! pressure
197 
198 ! allocate if not yet allocated
199  if (.not. allocated(t_d%vals)) then
200  t_d%nlocs = self%nlocs
201  t_d%nval = self%nval
202  allocate(t_d%vals(t_d%nval,t_d%nlocs))
203  t_d%vals = 0.0_kind_real
204  endif
205 
206  if (.not. allocated(prs_d%vals)) then
207  prs_d%nlocs = self%nlocs
208  prs_d%nval = self%nval
209  allocate(prs_d%vals(prs_d%nval,prs_d%nlocs))
210  prs_d%vals = 0.0_kind_real
211  endif
212 
213  if (.not. allocated(q_d%vals)) then
214  q_d%nlocs = self%nlocs
215  q_d%nval = self%nval
216  allocate(q_d%vals(q_d%nval,q_d%nlocs))
217  q_d%vals = 0.0_kind_real
218  endif
219 
220  if (.not. geovals%linit ) geovals%linit=.true.
221 
222  nlev = self%nval
223  nlocs = self%nlocs
224 
225  allocate(gph_d_zero(nlev))
226  gph_d_zero = 0.0
227 
228 ! set obs space struture
229  allocate(obslon(nlocs))
230  allocate(obslat(nlocs))
231  allocate(obsimpp(nlocs))
232  allocate(obslocr(nlocs))
233  allocate(obsgeoid(nlocs))
234 
235  call obsspace_get_db(obss, "MetaData", "longitude", obslon)
236  call obsspace_get_db(obss, "MetaData", "latitude", obslat)
237  call obsspace_get_db(obss, "MetaData", "impact_parameter", obsimpp)
238  call obsspace_get_db(obss, "MetaData", "earth_radius_of_curvature", obslocr)
239  call obsspace_get_db(obss, "MetaData", "geoid_height_above_reference_ellipsoid", obsgeoid)
240 
241  missing = missing_value(missing)
242 
243 ! tidy up - deallocate obsspace structures
244  deallocate(obslat)
245  deallocate(obslon)
246  deallocate(obsimpp)
247  deallocate(obslocr)
248  deallocate(obsgeoid)
249  deallocate(gph_d_zero)
250 
251  write(err_msg,*) "TRACE: ufo_gnssro_bndropp1d_simobs_ad: complete"
252  call fckit_log%info(err_msg)
253 
254  return
255 
256 end subroutine ufo_gnssro_bndropp1d_simobs_ad
257 
258 !-------------------------------------------------------------------------
259 !-------------------------------------------------------------------------
260 subroutine ufo_gnssro_bndropp1d_tlad_delete(self)
261 
262  implicit none
263  class(ufo_gnssro_bndropp1d_tlad), intent(inout) :: self
264  character(len=*), parameter :: myname_="ufo_gnssro_bndropp_tlad_delete"
265 
266  self%nval = 0
267  if (allocated(self%prs)) deallocate(self%prs)
268  if (allocated(self%t)) deallocate(self%t)
269  if (allocated(self%q)) deallocate(self%q)
270  if (allocated(self%gph)) deallocate(self%gph)
271  if (allocated(self%gph_sfc)) deallocate(self%gph_sfc)
272  self%ltraj = .false.
273 
274 end subroutine ufo_gnssro_bndropp1d_tlad_delete
275 
276 !-------------------------------------------------------------------------
277 
278 end module ufo_gnssro_bndropp1d_tlad_mod
ufo_basis_tlad_mod
Definition: ufo_basis_tlad_mod.F90:6
ufo_gnssro_bndnbam_tlad_mod::missing
real(c_double) missing
Definition: ufo_gnssro_bndnbam_tlad_mod.F90:23
ufo_gnssro_bndropp1d_tlad_mod::ufo_gnssro_bndropp1d_tlad_delete
subroutine ufo_gnssro_bndropp1d_tlad_delete(self)
Definition: ufo_gnssro_bndropp1d_tlad_mod.F90:404
ufo_gnssro_bndropp1d_tlad_mod::ufo_gnssro_bndropp1d_tlad_settraj
subroutine ufo_gnssro_bndropp1d_tlad_settraj(self, geovals, obss)
Definition: ufo_gnssro_bndropp1d_tlad_mod.F90:43
vert_interp_mod
Fortran module to perform linear interpolation.
Definition: vert_interp.F90:8
ufo_basis_tlad_mod::ufo_basis_tlad
Definition: ufo_basis_tlad_mod.F90:12
ufo_geovals_mod
Definition: ufo_geovals_mod.F90:7
ufo_geovals_mod_c
Definition: GeoVaLs.interface.F90:7
ufo_gnssro_bndropp1d_tlad_mod
Fortran module for gnssro bending angle ropp1d tangent linear and adjoint following the ROPP (2018 Au...
Definition: ufo_gnssro_bndropp1d_tlad_mod.F90:9
ufo_vars_mod::var_sfc_geomz
character(len=maxvarlen), parameter, public var_sfc_geomz
Definition: ufo_variables_mod.F90:70
ufo_vars_mod
Definition: ufo_variables_mod.F90:8
ufo_vars_mod::var_z
character(len=maxvarlen), parameter, public var_z
Definition: ufo_variables_mod.F90:29
ufo_geovals_mod::ufo_geovals_get_var
subroutine, public ufo_geovals_get_var(self, varname, geoval)
Definition: ufo_geovals_mod.F90:128
ufo_vars_mod::var_q
character(len=maxvarlen), parameter, public var_q
Definition: ufo_variables_mod.F90:22
ufo_gnssro_bndropp1d_tlad_mod::ufo_gnssro_bndropp1d_tlad
Fortran derived type for gnssro trajectory.
Definition: ufo_gnssro_bndropp1d_tlad_mod.F90:27
ufo_vars_mod::var_ts
character(len=maxvarlen), parameter, public var_ts
Definition: ufo_variables_mod.F90:19
ufo_geovals_mod::ufo_geovals
type to hold interpolated fields required by the obs operators
Definition: ufo_geovals_mod.F90:47
gnssro_mod_conf
Definition: gnssro_mod_conf.F90:2
ufo_geovals_mod::ufo_geoval
type to hold interpolated field for one variable, one observation
Definition: ufo_geovals_mod.F90:40
ufo_gnssro_bndropp1d_tlad_mod::ufo_gnssro_bndropp1d_simobs_tl
subroutine ufo_gnssro_bndropp1d_simobs_tl(self, geovals, hofx, obss)
Definition: ufo_gnssro_bndropp1d_tlad_mod.F90:96
ufo_vars_mod::var_prs
character(len=maxvarlen), parameter, public var_prs
Definition: ufo_variables_mod.F90:25
ufo_geovals_mod_c::ufo_geovals_registry
type(registry_t), public ufo_geovals_registry
Linked list interface - defines registry_t type.
Definition: GeoVaLs.interface.F90:30
ufo_gnssro_bndropp1d_tlad_mod::ufo_gnssro_bndropp1d_simobs_ad
subroutine ufo_gnssro_bndropp1d_simobs_ad(self, geovals, hofx, obss)
Definition: ufo_gnssro_bndropp1d_tlad_mod.F90:229