77
78
85
86# ifdef DISTRIBUTE
89# ifdef SOLVE3D
91# endif
92# endif
94# ifdef SOLVE3D
96# endif
97
98
99
100 integer, intent(in) :: ng, tile, model
101 integer, intent(in) :: LBi, UBi, LBj, UBj
102 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
103
104# ifdef ASSUMED_SHAPE
105# ifdef MASKING
106 real(r8), intent(in) :: rmask(LBi:,LBj:)
107 real(r8), intent(in) :: umask(LBi:,LBj:)
108 real(r8), intent(in) :: vmask(LBi:,LBj:)
109# endif
110# ifdef SOLVE3D
111 real(r8), intent(in) :: z_r(LBi:,LBj:,:)
112 real(r8), intent(inout) :: z_v(LBi:,LBj:,:)
113 real(r8), intent(inout) :: f_u(LBi:,LBj:,:)
114 real(r8), intent(inout) :: f_v(LBi:,LBj:,:)
115 real(r8), intent(inout) :: f_t(LBi:,LBj:,:,:)
116# endif
117 real(r8), intent(inout) :: f_ubar(LBi:,LBj:)
118 real(r8), intent(inout) :: f_vbar(LBi:,LBj:)
119 real(r8), intent(inout) :: f_zeta(LBi:,LBj:)
120# else
121# ifdef MASKING
122 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
123 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
124 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
125# endif
126# ifdef SOLVE3D
127 real(r8), intent(in) :: z_r(LBi:UBi,LBj:UBj,N(ng))
128 real(r8), intent(inout) :: z_v(LBi:UBi,LBj:UBj,N(ng))
129 real(r8), intent(inout) :: f_u(LBi:UBi,LBj:UBj,N(ng))
130 real(r8), intent(inout) :: f_v(LBi:UBi,LBj:UBj,N(ng))
131 real(r8), intent(inout) :: f_t(LBi:UBi,LBj:UBj,N(ng),NT(ng))
132# endif
133 real(r8), intent(inout) :: f_ubar(LBi:UBi,LBj:UBj)
134 real(r8), intent(inout) :: f_vbar(LBi:UBi,LBj:UBj)
135 real(r8), intent(inout) :: f_zeta(LBi:UBi,LBj:UBj)
136# endif
137
138
139
140 integer :: Mstr, Mend, ObsSum, ObsVoid
141# ifdef DISTRIBUTE
142 integer :: Ncollect
143# endif
144 integer :: i, ie, iobs, is, j
145
146# ifdef SOLVE3D
147 integer :: itrc, k
148# endif
149 real(r8) :: angle
150
151 real(r8), parameter :: IniVal = 0.0_r8
152
153 real(r8) :: ad_uradial(Mobs), ad_vradial(Mobs)
154
155# include "set_bounds.h"
156
157
158
159
160
161
162
163# ifdef DISTRIBUTE
164
165
166
167
168
169
170
171
172
173
174
175# endif
176
177
178
179
180
181
183
184
185
186
187
190
191
192
193 DO iobs=mstr,mend
195 END DO
196
197# if defined OBS_SPACE && defined RBL4DVAR_FCT_SENSITIVITY
198
199
200
201# ifndef OBS_IMPACT
202 IF (.not.ladjvar(ng)) THEN
203# endif
205 DO iobs=mstr,mend
208 END DO
209 ELSE
210 DO iobs=mstr,mend
213 END DO
214 END IF
215# ifndef OBS_IMPACT
216 END IF
217# endif
218# endif
219
220# ifdef BGQC
221
222
223
224 DO iobs=mstr,mend
226 END DO
227# endif
228
229
230
231 DO i=lbi,ubi
232 DO j=lbj,ubj
233 f_zeta(i,j)=0.0_r8
234 END DO
235 END DO
238 & lbi, ubi, lbj, ubj, &
240 &
mobs, mstr, mend, &
246 & f_zeta, &
247# ifdef MASKING
248 & rmask, &
249# endif
251# ifdef DISTRIBUTE
253 & lbi, ubi, lbj, ubj, &
256 & f_zeta)
257# endif
258 END IF
259
260
261
262 DO i=lbi,ubi
263 DO j=lbj,ubj
264 f_ubar(i,j)=0.0_r8
265 END DO
266 END DO
269 & lbi, ubi, lbj, ubj, &
271 &
mobs, mstr, mend, &
277 & f_ubar, &
278# ifdef MASKING
279 & umask, &
280# endif
282# ifdef DISTRIBUTE
284 & lbi, ubi, lbj, ubj, &
287 & f_ubar)
288# endif
289 END IF
290
291
292
293 DO i=lbi,ubi
294 DO j=lbj,ubj
295 f_vbar(i,j)=0.0_r8
296 END DO
297 END DO
300 & lbi, ubi, lbj, ubj, &
302 &
mobs, mstr, mend, &
308 & f_vbar, &
309# ifdef MASKING
310 & vmask, &
311# endif
313# ifdef DISTRIBUTE
315 & lbi, ubi, lbj, ubj, &
318 & f_vbar)
319# endif
320 END IF
321
322# ifdef SOLVE3D
323
324
325
327 DO i=lbi,ubi
328 DO j=lbj,ubj
329 f_u(i,j,k)=0.0_r8
330 END DO
331 END DO
332 END DO
335 DO j=jstr-1,jend+1
336 DO i=istru-1,iend+1
337 z_v(i,j,k)=0.5_r8*(z_r(i-1,j,k)+ &
338 & z_r(i ,j,k))
339 END DO
340 END DO
341 END DO
343 & lbi, ubi, lbj, ubj, 1,
n(ng), &
345 &
mobs, mstr, mend, &
351 & f_u, z_v, &
352# ifdef MASKING
353 & umask, &
354# endif
356# ifdef DISTRIBUTE
358 & lbi, ubi, lbj, ubj, 1,
n(ng), &
361 & f_u)
362# endif
363 END IF
364
365
366
368 DO i=lbi,ubi
369 DO j=lbj,ubj
370 f_v(i,j,k)=0.0_r8
371 END DO
372 END DO
373 END DO
376 DO j=jstrv-1,jend+1
377 DO i=istr-1,iend+1
378 z_v(i,j,k)=0.5_r8*(z_r(i,j-1,k)+ &
379 & z_r(i,j ,k))
380 END DO
381 END DO
382 END DO
384 & lbi, ubi, lbj, ubj, 1,
n(ng), &
386 &
mobs, mstr, mend, &
392 & f_v, z_v, &
393# ifdef MASKING
394 & vmask, &
395# endif
397# ifdef DISTRIBUTE
399 & lbi, ubi, lbj, ubj, 1,
n(ng), &
402 & f_v)
403# endif
404 END IF
405
406
407
408
409# ifdef RADIAL_ANGLE_CCW_EAST
410
411
412
413
414
415
416
417
418
419
420
421
422# else
423
424
425
426
427
428
429
430
431
432
433
434
435# endif
436
438 DO iobs=mstr,mend
439 ad_uradial(iobs)=inival
440 ad_vradial(iobs)=inival
441 END DO
442 DO iobs=mstr,mend
444# ifdef RADIAL_ANGLE_CCW_EAST
445# ifdef CURVGRID
447 ad_uradial(iobs)=ad_uradial(iobs)+ &
449 ad_vradial(iobs)=ad_vradial(iobs)+ &
451# else
452 ad_uradial(iobs)=ad_uradial(iobs)+ &
454 ad_vradial(iobs)=ad_vradial(iobs)+ &
456# endif
457# else
458# ifdef CURVGRID
460 ad_uradial(iobs)=ad_uradial(iobs)+ &
462 ad_vradial(iobs)=ad_vradial(iobs)+ &
464# else
465 ad_uradial(iobs)=ad_uradial(iobs)+ &
467 ad_vradial(iobs)=ad_vradial(iobs)+ &
469# endif
470# endif
472 END IF
473 END DO
475 DO j=jstrv-1,jend+1
476 DO i=istr-1,iend+1
477 z_v(i,j,k)=0.5_r8*(z_r(i,j-1,k)+ &
478 & z_r(i,j ,k))
479 END DO
480 END DO
481 END DO
483 & lbi, ubi, lbj, ubj, 1,
n(ng), &
485 &
mobs, mstr, mend, &
491 & f_v, z_v, &
492# ifdef MASKING
493 & vmask, &
494# endif
495 & ad_vradial)
497 DO j=jstr-1,jend+1
498 DO i=istru-1,iend+1
499 z_v(i,j,k)=0.5_r8*(z_r(i-1,j,k)+ &
500 & z_r(i ,j,k))
501 END DO
502 END DO
503 END DO
505 & lbi, ubi, lbj, ubj, 1,
n(ng), &
507 &
mobs, mstr, mend, &
513 & f_u, z_v, &
514# ifdef MASKING
515 & umask, &
516# endif
517 & ad_uradial)
518 END IF
519
520# ifdef DISTRIBUTE
521
522
523
524
529 & lbi, ubi, lbj, ubj, 1,
n(ng), &
532 END IF
533# endif
534
535
536
539 DO i=lbi,ubi
540 DO j=lbj,ubj
541 f_t(i,j,k,itrc)=0.0_r8
542 END DO
543 END DO
544 END DO
547 & lbi, ubi, lbj, ubj, 1,
n(ng), &
549 &
mobs, mstr, mend, &
555 & f_t(:,:,:,itrc), z_r, &
556# ifdef MASKING
557 & rmask, &
558# endif
560# ifdef DISTRIBUTE
562 & lbi, ubi, lbj, ubj, 1,
n(ng), &
565 & f_t(:,:,:,itrc))
566# endif
567
568 END IF
569 END DO
570# endif
571# ifdef DISTRIBUTE
572
573
574
575
576
577
578 ncollect=mend-mstr+1
579 CALL mp_collect (ng, model, ncollect, inival, &
581# endif
582
583
584
585
586
587
588
589 DO iobs=mstr,mend
600# ifdef SOLVE3D
610 ELSE
615 END IF
616 END DO
617# endif
618 END IF
619 END IF
620 END DO
621
622
623
624
630 END DO
631
632
633
634 IF (
domain(ng)%SouthWest_Test(tile))
THEN
636 obssum=0
637 obsvoid=0
640 IF (
fourdvar(ng)%ObsCount(i).gt.0)
THEN
643 & ie-is+1,
fourdvar(ng)%ObsReject(i)
644 is=ie+1
645 obssum=obssum+
fourdvar(ng)%ObsCount(i)
646 obsvoid=obsvoid+
fourdvar(ng)%ObsReject(i)
647 END IF
648 END DO
649 WRITE (
stdout,20) obssum, obsvoid, &
654 10 FORMAT (10x,a,t25,4(1x,i10))
655 20 FORMAT (/,10x,'Total',t47,2(1x,i10), &
656 & /,10x,'Obs Tally',t47,2(1x,i10),/)
657 30 FORMAT (3x,' AD_HTOBS - Computed adjoint observations ', &
658 & 'forcing,',t68,a,/,19x,'(Observation ', &
659 & 'records = ',i7.7,' - ',i7.7,', iic = ',i7.7,')')
660 END IF
661 END IF
662 END IF
663 RETURN
type(t_fourdvar), dimension(:), allocatable fourdvar
real(r8), dimension(:), allocatable obsvetting
integer, dimension(:), allocatable nobsvar
real(r8), dimension(:), allocatable obsval
real(r8), dimension(:), allocatable obsangler
real(r8), dimension(:), allocatable obsscale
real(r8), dimension(:), allocatable obsmeta
integer, dimension(:), allocatable obstype
real(r8), dimension(:), allocatable admodval
real(r8), dimension(:), allocatable zobs
logical, dimension(:), allocatable lobspace
real(dp), dimension(:), allocatable tobs
real(r8), dimension(:), allocatable xobs
integer, dimension(:), allocatable obsstate2type
real(r8), dimension(:), allocatable yobs
character(len=40), dimension(:), allocatable obsname
integer, dimension(:), allocatable nstrobs
logical, dimension(:), allocatable processobs
integer, dimension(:), allocatable nendobs
real(r8), dimension(:), allocatable rymin
real(r8), dimension(:), allocatable vymin
real(r8), dimension(:), allocatable rymax
real(r8), dimension(:), allocatable uymin
real(r8), dimension(:), allocatable vymax
real(r8), dimension(:), allocatable uxmin
real(r8), dimension(:), allocatable uxmax
real(r8), dimension(:), allocatable rxmax
integer, dimension(:), allocatable istvar
real(r8), dimension(:), allocatable uymax
real(r8), dimension(:), allocatable vxmin
real(r8), dimension(:), allocatable vxmax
real(r8), dimension(:), allocatable rxmin
integer, dimension(:), allocatable n
type(t_domain), dimension(:), allocatable domain
integer, dimension(:), allocatable lm
integer, dimension(:), allocatable nt
integer, dimension(:), allocatable mm
integer, dimension(:), allocatable iic
real(dp), dimension(:), allocatable dt
logical, dimension(:), allocatable ewperiodic
logical, dimension(:), allocatable nsperiodic
character(len=22), dimension(:), allocatable time_code
real(dp), dimension(:), allocatable time
subroutine ad_mp_exchange3d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
subroutine ad_mp_exchange2d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)