ROMS
Loading...
Searching...
No Matches
ad_extract_obs.F
Go to the documentation of this file.
1#include "cppdefs.h"
3#if defined ADJOINT && defined FOUR_DVAR && defined OBSERVATIONS
4!
5!git $Id$
6!================================================== Hernan G. Arango ===
7! Copyright (c) 2002-2025 The ROMS Group !
8! Licensed under a MIT/X style license !
9! See License_ROMS.md !
10!=======================================================================
11! !
12! This subroutine computes the adjoint misfit forcing terms at the !
13! observations locations (Xobs,Yobs,Zobs). The extraction is done !
14! via linear interpolation. The (Xobs,Yobs) locations must be in !
15! grid coordinates. Zobs can be in grid coordinates (Zobs >= 0) or !
16! actual depths (Zobs < 0), if applicable. !
17! !
18! On Input: !
19! !
20! ng Nested grid number. !
21! Imin Global I-coordinate lower bound threshold for !
22! requested state field type. !
23! Imax Global I-coordinate upper bound threshold for !
24! requested state field type. !
25! Jmin Global J-coordinate lower bound threshold for !
26! requested state field type. !
27! Jmax Global J-coordinate upper bound threshold for !
28! requested state field type. !
29! LBi I-dimension Lower bound. !
30! UBi I-dimension Upper bound. !
31! LBj J-dimension Lower bound. !
32! UBj J-dimension Upper bound. !
33! LBk K-dimension Lower bound. !
34! UBk K-dimension Upper bound. !
35! ifield State field identification to process. !
36! Mobs Observation dimension in the calling program. !
37! NobsSTR Starting observation to process. !
38! NobsEND Last observations to process. !
39! Xmin Global minimum fractional I-coordinate to consider. !
40! Xmax Global maximum fractional I-coordinate to consider. !
41! Ymin Global minimum fractional J-coordinate to consider. !
42! Ymax Global maximum fractional J-coordinate to consider. !
43! time Current model time (secods). !
44! dt Model baroclinic time-step (seconds). !
45! ObsType Observations type. !
46! Tobs Observations time (days). !
47! Xobs Observations X-locations (grid coordinates). !
48! Yobs Observations Y-locations (grid coordinates). !
49! Zobs Observations Z-locations (grid coordinates or meters).!
50! ad_Aobs Adjoint forcing term at observations locations. !
51! Adepth Depths (meter; negative). !
52! Amask Land-sea masking. !
53! !
54! On Output: !
55! !
56! ObsVetting Observation screenning flag, 0: reject or 1: accept. !
57! ad_A Adjoint equations forcing array (2D or 3D). !
58! ad_Aobs Adjoint forcing term at observations locations. !
59! Zobs Observations Z-locations (grid coordinates). !
60! !
61! The interpolation weights matrix, Hmat(1:8), is as follows: !
62! !
63! 8____________7 !
64! /. /| (i2,j2,k2) !
65! / . / | !
66! 5/___________/6 | !
67! | . | | !
68! | . | | Grid Cell !
69! | 4.........|..|3 !
70! | . | / !
71! |. | / !
72! (i1,j1,k1) |___________|/ !
73! 1 2 !
74! !
75! Notice that the indices i2 and j2 are reset when observations are !
76! located exactly at the eastern and/or northern boundaries. This is !
77! needed to avoid out-of-range array computations. !
78! !
79! All the observations are assumed to in fractional coordinates with !
80! respect to RHO-points: !
81! !
82! !
83! M r..u..r..u..r..u..r..u..r..u..r..u..r..u..r..u..r..u..r !
84! : : !
85! Mm+.5 v p++v++p++v++p++v++p++v++p++v++p++v++p++v++p++v++p v !
86! : + | | | | | | | + : !
87! Mm r u r u r u r u r u r u r u r u r u r !
88! : + | | | | | | | + : !
89! Mm-.5 v p--v--p--v--p--v--p--v--p--v--p--v--p--v--p--v--p v !
90! : + | | | | | | | + : !
91! r u r u r u r u r u r u r u r u r u r !
92! : + | | | | | | | + : !
93! v p--v--p--v--p--v--p--v--p--v--p--v--p--v--p--v--p v !
94! : + | | | | | | | + : !
95! r u r u r u r u r u r u r u r u r u r !
96! : + | | | | | | | + : !
97! 2.5 v p--v--p--v--p--v--p--v--p--v--p--v--p--v--p--v--p v !
98! : + | | | | | | | + : !
99! 2.0 r u r u r u r u r u r u r u r u r u r !
100! : + | | | | | | | + : !
101! 1.5 v p--v--p--v--p--v--p--v--p--v--p--v--p--v--p--v--p v !
102! : + | | | | | | | + : !
103! 1.0 r u r u r u r u r u r u r u r u r u r !
104! : + | | | | | | | + : !
105! 0.5 v p++v++p++v++p++v++p++v++p++v++p++v++p++v++p++v++p v !
106! : : !
107! 0.0 r..u..r..u..r..u..r..u..r..u..r..u..r..u..r..u..r..u..r !
108! !
109! 0.5 1.5 2.5 Lm-.5 Lm+.5 !
110! !
111! 0.0 1.0 2.0 Lm L !
112! !
113!=======================================================================
114!
115 USE mod_kinds
116
117 implicit none
118
119 PUBLIC :: ad_extract_obs2d
120# ifdef SOLVE3D
121 PUBLIC :: ad_extract_obs3d
122# endif
123
124 CONTAINS
125!
126!***********************************************************************
127 SUBROUTINE ad_extract_obs2d (ng, Imin, Imax, Jmin, Jmax, &
128 & LBi, UBi, LBj, UBj, &
129 & ifield, Mobs, NobsSTR, NobsEND, &
130 & Xmin, Xmax, Ymin, Ymax, &
131 & time, dt, &
132 & ObsType, ObsVetting, &
133 & Tobs, Xobs, Yobs, &
134 & ad_A, &
135# ifdef MASKING
136 & Amask, &
137# endif
138 & ad_Aobs)
139!***********************************************************************
140!
141 USE mod_ncparam, ONLY : isubar, isvbar
142 USE mod_fourdvar, ONLY : obsstate2type
143!
144! Imported variable declarations.
145!
146 integer, intent(in) :: ng, imin, imax, jmin, jmax
147 integer, intent(in) :: lbi, ubi, lbj, ubj
148 integer, intent(in) :: ifield, mobs, nobsstr, nobsend
149!
150 real(r8), intent(in) :: xmin, xmax, ymin, ymax
151 real(dp), intent(in) :: time, dt
152!
153# ifdef ASSUMED_SHAPE
154 integer, intent(in) :: obstype(:)
155
156 real(dp), intent(in) :: tobs(:)
157 real(r8), intent(in) :: xobs(:)
158 real(r8), intent(in) :: yobs(:)
159# ifdef MASKING
160 real(r8), intent(in) :: amask(lbi:,lbj:)
161# endif
162 real(r8), intent(inout) :: obsvetting(:)
163 real(r8), intent(inout) :: ad_aobs(:)
164 real(r8), intent(inout) :: ad_a(lbi:,lbj:)
165
166# else
167 integer, intent(in) :: obstype(mobs)
168
169 real(dp), intent(in) :: tobs(mobs)
170 real(r8), intent(in) :: xobs(mobs)
171 real(r8), intent(in) :: yobs(mobs)
172# ifdef MASKING
173 real(r8), intent(in) :: amask(lbi:ubi,lbj:ubj)
174# endif
175 real(r8), intent(inout) :: obsvetting(mobs)
176 real(r8), intent(inout) :: ad_aobs(mobs)
177 real(r8), intent(inout) :: ad_a(lbi:ubi,lbj:ubj)
178# endif
179!
180! Local variable declarations.
181!
182 integer :: ic, iobs, i1, i2, j1, j2
183
184 real(dp) :: timelb, timeub
185
186 real(r8) :: p1, p2, q1, q2, wsum
187
188 real(r8), dimension(8) :: hmat
189!
190!-----------------------------------------------------------------------
191! Interpolate from requested 2D state field when appropriate.
192!-----------------------------------------------------------------------
193!
194 timelb=(time-0.5_dp*dt)/86400.0_dp
195 timeub=(time+0.5_dp*dt)/86400.0_dp
196!
197 DO iobs=nobsstr,nobsend
198 IF ((obstype(iobs).eq.ifield).and. &
199 & ((timelb.le.tobs(iobs)).and.(tobs(iobs).lt.timeub)).and. &
200 & ((xmin.le.xobs(iobs)).and.(xobs(iobs).lt.xmax)).and. &
201 & ((ymin.le.yobs(iobs)).and.(yobs(iobs).lt.ymax))) THEN
202 IF (obstype(iobs).eq.obsstate2type(isubar)) THEN
203 i1=int(xobs(iobs)+0.5_r8) ! 2D U-grid type variable
204 j1=int(yobs(iobs))
205 ELSE IF (obstype(iobs).eq.obsstate2type(isvbar)) THEN
206 i1=int(xobs(iobs)) ! 2D V-grid type variable
207 j1=int(yobs(iobs)+0.5_r8)
208 ELSE
209 i1=int(xobs(iobs)) ! 2D RHO-grid type variable
210 j1=int(yobs(iobs))
211 END IF
212 i2=i1+1
213 j2=j1+1
214 IF (i2.gt.imax) THEN
215 i2=i1 ! Observation at the eastern boundary
216 END IF
217 IF (j2.gt.jmax) THEN
218 j2=j1 ! Observation at the northern boundary
219 END IF
220 p2=real(i2-i1,r8)*(xobs(iobs)-real(i1,r8))
221 q2=real(j2-j1,r8)*(yobs(iobs)-real(j1,r8))
222 p1=1.0_r8-p2
223 q1=1.0_r8-q2
224 hmat(1)=p1*q1
225 hmat(2)=p2*q1
226 hmat(3)=p2*q2
227 hmat(4)=p1*q2
228# ifdef MASKING
229 hmat(1)=hmat(1)*amask(i1,j1)
230 hmat(2)=hmat(2)*amask(i2,j1)
231 hmat(3)=hmat(3)*amask(i2,j2)
232 hmat(4)=hmat(4)*amask(i1,j2)
233 wsum=0.0_r8
234 DO ic=1,4
235 wsum=wsum+hmat(ic)
236 END DO
237 IF (wsum.gt.0.0_r8) THEN
238 wsum=1.0_r8/wsum
239 DO ic=1,4
240 hmat(ic)=hmat(ic)*wsum
241 END DO
242 END IF
243# endif
244!^ Aobs(iobs)=Hmat(1)*A(i1,j1)+ &
245!^ & Hmat(2)*A(i2,j1)+ &
246!^ & Hmat(3)*A(i2,j2)+ &
247!^ & Hmat(4)*A(i1,j2)
248!^
249 ad_a(i1,j1)=ad_a(i1,j1)+hmat(1)*ad_aobs(iobs)
250 ad_a(i2,j1)=ad_a(i2,j1)+hmat(2)*ad_aobs(iobs)
251 ad_a(i2,j2)=ad_a(i2,j2)+hmat(3)*ad_aobs(iobs)
252 ad_a(i1,j2)=ad_a(i1,j2)+hmat(4)*ad_aobs(iobs)
253 ad_aobs(iobs)=0.0_r8
254# ifdef MASKING
255 IF (wsum.gt.0.0_r8) obsvetting(iobs)=1.0_r8
256# else
257 obsvetting(iobs)=1.0_r8
258# endif
259 END IF
260 END DO
261
262 RETURN
263 END SUBROUTINE ad_extract_obs2d
264
265# ifdef SOLVE3D
266!
267!***********************************************************************
268 SUBROUTINE ad_extract_obs3d (ng, Imin, Imax, Jmin, Jmax, &
269 & LBi, UBi, LBj, UBj, LBk, UBk, &
270 & ifield, Mobs, NobsSTR, NobsEND, &
271 & Xmin, Xmax, Ymin, Ymax, &
272 & time, dt, &
273 & ObsType, ObsVetting, &
274 & Tobs, Xobs, Yobs, Zobs, &
275 & ad_A, Adepth, &
276# ifdef MASKING
277 & Amask, &
278# endif
279 & ad_Aobs)
280!***********************************************************************
281!
282 USE mod_param
283!
284 USE mod_ncparam, ONLY : isuvel, isvvel
285 USE mod_fourdvar, ONLY : obsstate2type
286!
287! Imported variable declarations.
288!
289 integer, intent(in) :: ng, imin, imax, jmin, jmax
290 integer, intent(in) :: lbi, ubi, lbj, ubj, lbk, ubk
291 integer, intent(in) :: ifield, mobs, nobsstr, nobsend
292!
293 real(r8), intent(in) :: xmin, xmax, ymin, ymax
294 real(dp), intent(in) :: time, dt
295!
296# ifdef ASSUMED_SHAPE
297 integer, intent(in) :: obstype(:)
298
299 real(dp), intent(in) :: tobs(:)
300 real(r8), intent(in) :: xobs(:)
301 real(r8), intent(in) :: yobs(:)
302 real(r8), intent(in) :: adepth(lbi:,lbj:,lbk:)
303# ifdef MASKING
304 real(r8), intent(in) :: amask(lbi:,lbj:)
305# endif
306 real(r8), intent(inout) :: obsvetting(:)
307 real(r8), intent(inout) :: ad_aobs(:)
308 real(r8), intent(inout) :: zobs(:)
309 real(r8), intent(inout) :: ad_a(lbi:,lbj:,lbk:)
310# else
311 integer, intent(in) :: obstype(mobs)
312
313 real(dp), intent(in) :: tobs(mobs)
314 real(r8), intent(in) :: xobs(mobs)
315 real(r8), intent(in) :: yobs(mobs)
316 real(r8), intent(in) :: adepth(lbi:ubi,lbj:ubj,lbk:ubk)
317# ifdef MASKING
318 real(r8), intent(in) :: amask(lbi:ubi,lbj:ubj)
319# endif
320 real(r8), intent(inout) :: obsvetting(mobs)
321 real(r8), intent(inout) :: ad_aobs(mobs)
322 real(r8), intent(inout) :: zobs(mobs)
323 real(r8), intent(inout) :: ad_a(lbi:ubi,lbj:ubj,lbk:ubk)
324# endif
325!
326! Local variable declarations.
327!
328 integer :: i, ic, iobs, i1, i2, j1, j2, k, k1, k2
329
330 real(dp) :: timelb, timeub
331
332 real(r8) :: zbot, ztop, dz, p1, p2, q1, q2, r1, r2
333 real(r8) :: w11, w12, w21, w22, wsum
334
335 real(r8), dimension(8) :: hmat
336!
337!-----------------------------------------------------------------------
338! Interpolate from requested 3D state field.
339!-----------------------------------------------------------------------
340!
341 timelb=(time-0.5_dp*dt)/86400.0_dp
342 timeub=(time+0.5_dp*dt)/86400.0_dp
343!
344 DO iobs=nobsstr,nobsend
345 IF ((obstype(iobs).eq.ifield).and. &
346 & ((timelb.le.tobs(iobs)).and.(tobs(iobs).lt.timeub)).and. &
347 & ((xmin.le.xobs(iobs)).and.(xobs(iobs).lt.xmax)).and. &
348 & ((ymin.le.yobs(iobs)).and.(yobs(iobs).lt.ymax))) THEN
349 IF (obstype(iobs).eq.obsstate2type(isuvel)) THEN
350 i1=int(xobs(iobs)+0.5_r8) ! 3D U-grid type variable
351 j1=int(yobs(iobs))
352 ELSE IF (obstype(iobs).eq.obsstate2type(isvvel)) THEN
353 i1=int(xobs(iobs)) ! 3D V-grid type variable
354 j1=int(yobs(iobs)+0.5_r8)
355 ELSE
356 i1=int(xobs(iobs)) ! 3D RHO-grid type variable
357 j1=int(yobs(iobs))
358 END IF
359 i2=i1+1
360 j2=j1+1
361 IF (i2.gt.imax) THEN
362 i2=i1 ! Observation at the eastern boundary
363 END IF
364 IF (j2.gt.jmax) THEN
365 j2=j1 ! Observation at the northern boundary
366 END IF
367 p2=real(i2-i1,r8)*(xobs(iobs)-real(i1,r8))
368 q2=real(j2-j1,r8)*(yobs(iobs)-real(j1,r8))
369 p1=1.0_r8-p2
370 q1=1.0_r8-q2
371 w11=p1*q1
372 w21=p2*q1
373 w22=p2*q2
374 w12=p1*q2
375 IF (zobs(iobs).gt.0.0_r8) THEN
376 k1=max(1,int(zobs(iobs))) ! Positions in fractional
377 k2=min(k1+1,n(ng)) ! levels
378 r2=real(k2-k1,r8)*(zobs(iobs)-real(k1,r8))
379 r1=1.0_r8-r2
380 ELSE
381 ztop=adepth(i1,j1,n(ng))
382 zbot=adepth(i1,j1,1 )
383 IF (zobs(iobs).ge.ztop) THEN
384 k1=n(ng) ! If shallower, assign to
385 k2=n(ng) ! top grid cell. The
386 r1=1.0_r8 ! observation is located
387 r2=0.0_r8 ! on the upper cell half
388 zobs(iobs)=real(n(ng),r8) ! above its middle depth.
389 ELSE IF (zbot.ge.zobs(iobs)) THEN
390 r1=0.0_r8 ! If deeper, ignore.
391 r2=0.0_r8
392 obsvetting(iobs)=0.0_r8
393 ELSE
394 DO k=n(ng),2,-1 ! Otherwise, interpolate
395 ztop=adepth(i1,j1,k ) ! to fractional level
396 zbot=adepth(i1,j1,k-1)
397 IF ((ztop.gt.zobs(iobs)).and.(zobs(iobs).ge.zbot)) THEN
398 k1=k-1
399 k2=k
400 END IF
401 END DO
402 dz=adepth(i1,j1,k2)-adepth(i1,j1,k1)
403 r2=(zobs(iobs)-adepth(i1,j1,k1))/dz
404 r1=1.0_r8-r2
405 zobs(iobs)=real(k1,r8)+r2 ! overwrite
406 END IF
407 END IF
408 IF ((r1+r2).gt.0.0_r8) THEN
409 hmat(1)=w11*r1
410 hmat(2)=w21*r1
411 hmat(3)=w22*r1
412 hmat(4)=w12*r1
413 hmat(5)=w11*r2
414 hmat(6)=w21*r2
415 hmat(7)=w22*r2
416 hmat(8)=w12*r2
417# ifdef MASKING
418 hmat(1)=hmat(1)*amask(i1,j1)
419 hmat(2)=hmat(2)*amask(i2,j1)
420 hmat(3)=hmat(3)*amask(i2,j2)
421 hmat(4)=hmat(4)*amask(i1,j2)
422 hmat(5)=hmat(5)*amask(i1,j1)
423 hmat(6)=hmat(6)*amask(i2,j1)
424 hmat(7)=hmat(7)*amask(i2,j2)
425 hmat(8)=hmat(8)*amask(i1,j2)
426 wsum=0.0_r8
427 DO ic=1,8
428 wsum=wsum+hmat(ic)
429 END DO
430 IF (wsum.gt.0.0_r8) THEN
431 wsum=1.0_r8/wsum
432 DO ic=1,8
433 hmat(ic)=hmat(ic)*wsum
434 END DO
435 END IF
436# endif
437!^ Aobs(iobs)=Hmat(1)*A(i1,j1,k1)+ &
438!^ & Hmat(2)*A(i2,j1,k1)+ &
439!^ & Hmat(3)*A(i2,j2,k1)+ &
440!^ & Hmat(4)*A(i1,j2,k1)+ &
441!^ & Hmat(5)*A(i1,j1,k2)+ &
442!^ & Hmat(6)*A(i2,j1,k2)+ &
443!^ & Hmat(7)*A(i2,j2,k2)+ &
444!^ & Hmat(8)*A(i1,j2,k2)
445!^
446 ad_a(i1,j1,k1)=ad_a(i1,j1,k1)+hmat(1)*ad_aobs(iobs)
447 ad_a(i2,j1,k1)=ad_a(i2,j1,k1)+hmat(2)*ad_aobs(iobs)
448 ad_a(i2,j2,k1)=ad_a(i2,j2,k1)+hmat(3)*ad_aobs(iobs)
449 ad_a(i1,j2,k1)=ad_a(i1,j2,k1)+hmat(4)*ad_aobs(iobs)
450 ad_a(i1,j1,k2)=ad_a(i1,j1,k2)+hmat(5)*ad_aobs(iobs)
451 ad_a(i2,j1,k2)=ad_a(i2,j1,k2)+hmat(6)*ad_aobs(iobs)
452 ad_a(i2,j2,k2)=ad_a(i2,j2,k2)+hmat(7)*ad_aobs(iobs)
453 ad_a(i1,j2,k2)=ad_a(i1,j2,k2)+hmat(8)*ad_aobs(iobs)
454 ad_aobs(iobs)=0.0_r8
455# ifdef MASKING
456 IF (wsum.gt.0.0_r8) obsvetting(iobs)=1.0_r8
457# else
458 obsvetting(iobs)=1.0_r8
459# endif
460 END IF
461 END IF
462 END DO
463
464 RETURN
465 END SUBROUTINE ad_extract_obs3d
466# endif
467#endif
468 END MODULE ad_extract_obs_mod
subroutine, public ad_extract_obs3d(ng, imin, imax, jmin, jmax, lbi, ubi, lbj, ubj, lbk, ubk, ifield, mobs, nobsstr, nobsend, xmin, xmax, ymin, ymax, time, dt, obstype, obsvetting, tobs, xobs, yobs, zobs, ad_a, adepth, amask, ad_aobs)
subroutine, public ad_extract_obs2d(ng, imin, imax, jmin, jmax, lbi, ubi, lbj, ubj, ifield, mobs, nobsstr, nobsend, xmin, xmax, ymin, ymax, time, dt, obstype, obsvetting, tobs, xobs, yobs, ad_a, amask, ad_aobs)
real(r8), dimension(:), allocatable obsvetting
integer, dimension(:), allocatable obstype
real(r8), dimension(:), allocatable zobs
real(dp), dimension(:), allocatable tobs
real(r8), dimension(:), allocatable xobs
integer, dimension(:), allocatable obsstate2type
real(r8), dimension(:), allocatable yobs
integer, parameter r8
Definition mod_kinds.F:28
integer, parameter dp
Definition mod_kinds.F:25
integer isvvel
integer isvbar
integer isuvel
integer isubar
integer, dimension(:), allocatable n
Definition mod_param.F:479