ROMS
Loading...
Searching...
No Matches
ad_conv_2d.F
Go to the documentation of this file.
1#include "cppdefs.h"
2
3 MODULE ad_conv_2d_mod
4
5#if defined ADJOINT && defined FOUR_DVAR
6!
7!git $Id$
8!================================================== Hernan G. Arango ===
9! Copyright (c) 2002-2025 The ROMS Group Andrew M. Moore !
10! Licensed under a MIT/X style license !
11! See License_ROMS.md !
12!=======================================================================
13! !
14! These routines applies the background error covariance to data !
15! assimilation fields via the adjoint space convolution of the !
16! diffusion equation (filter) for 3D state variables. The filter !
17! is solved using an explicit (inefficient) algorithm. !
18! !
19! For Gaussian (bell-shaped) correlations, the space convolution !
20! of the diffusion operator is an efficient way to estimate the !
21! finite domain error covariances. !
22! !
23! On Input: !
24! !
25! ng Nested grid number. !
26! model Calling model identifier. !
27! Istr Starting tile index in the I-direction. !
28! Iend Ending tile index in the I-direction. !
29! Jstr Starting tile index in the J-direction. !
30! Jend Ending tile index in the J-direction. !
31! LBi I-dimension Lower bound. !
32! UBi I-dimension Upper bound. !
33! LBj J-dimension Lower bound. !
34! UBj J-dimension Upper bound. !
35! Nghost Number of ghost points. !
36! NHsteps Number of horizontal diffusion integration steps. !
37! DTsizeH Horizontal diffusion pseudo time-step size. !
38! Kh Horizontal diffusion coefficients. !
39! ad_A 2D adjoint state variable to diffuse. !
40! !
41! On Output: !
42! !
43! ad_A Diffused 2D adjoint state variable. !
44! !
45! Routines: !
46! !
47! ad_conv_r2d_tile Adjoint 2D convolution at RHO-points !
48! ad_conv_u2d_tile Adjoint 2D convolution at U-points !
49! ad_conv_v2d_tile Adjoint 2D convolution at V-points !
50! !
51!=======================================================================
52!
53 implicit none
54!
55 PUBLIC
56!
57 CONTAINS
58!
59!***********************************************************************
60 SUBROUTINE ad_conv_r2d_tile (ng, tile, model, &
61 & LBi, UBi, LBj, UBj, &
62 & IminS, ImaxS, JminS, JmaxS, &
63 & Nghost, NHsteps, DTsizeH, &
64 & Kh, &
65 & pm, pn, pmon_u, pnom_v, &
66# ifdef MASKING
67 & rmask, umask, vmask, &
68# endif
69 & ad_A)
70!***********************************************************************
71!
72 USE mod_param
73 USE mod_scalars
74!
75 USE ad_bc_2d_mod, ONLY: ad_dabc_r2d_tile
76# ifdef DISTRIBUTE
77 USE mp_exchange_mod, ONLY : ad_mp_exchange2d
78# endif
79!
80! Imported variable declarations.
81!
82 integer, intent(in) :: ng, tile, model
83 integer, intent(in) :: LBi, UBi, LBj, UBj
84 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
85 integer, intent(in) :: Nghost, NHsteps
86
87 real(r8), intent(in) :: DTsizeH
88!
89# ifdef ASSUMED_SHAPE
90 real(r8), intent(in) :: pm(LBi:,LBj:)
91 real(r8), intent(in) :: pn(LBi:,LBj:)
92 real(r8), intent(in) :: pmon_u(LBi:,LBj:)
93 real(r8), intent(in) :: pnom_v(LBi:,LBj:)
94# ifdef MASKING
95 real(r8), intent(in) :: rmask(LBi:,LBj:)
96 real(r8), intent(in) :: umask(LBi:,LBj:)
97 real(r8), intent(in) :: vmask(LBi:,LBj:)
98# endif
99 real(r8), intent(in) :: Kh(LBi:,LBj:)
100 real(r8), intent(inout) :: ad_A(LBi:,LBj:)
101# else
102 real(r8), intent(in) :: pm(LBi:UBi,LBj:UBj)
103 real(r8), intent(in) :: pn(LBi:UBi,LBj:UBj)
104 real(r8), intent(in) :: pmon_u(LBi:UBi,LBj:UBj)
105 real(r8), intent(in) :: pnom_v(LBi:UBi,LBj:UBj)
106# ifdef MASKING
107 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
108 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
109 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
110# endif
111 real(r8), intent(in) :: Kh(LBi:UBi,LBj:UBj)
112 real(r8), intent(inout) :: ad_A(LBi:UBi,LBj:UBj)
113# endif
114!
115! Local variable declarations.
116!
117 integer :: Nnew, Nold, Nsav, i, j, step
118
119 real(r8) :: adfac, cff
120
121 real(r8), dimension(LBi:UBi,LBj:UBj,2) :: ad_Awrk
122
123 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_FE
124 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_FX
125 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Hfac
126
127# include "set_bounds.h"
128!
129!-----------------------------------------------------------------------
130! Initialize adjoint private variables.
131!-----------------------------------------------------------------------
132!
133 ad_awrk(lbi:ubi,lbj:ubj,1:2)=0.0_r8
134
135 ad_fe(imins:imaxs,jmins:jmaxs)=0.0_r8
136 ad_fx(imins:imaxs,jmins:jmaxs)=0.0_r8
137!
138!-----------------------------------------------------------------------
139! Adjoint space convolution of the diffusion equation for a 2D state
140! variable at RHO-points.
141!-----------------------------------------------------------------------
142!
143! Compute metrics factor.
144!
145 DO j=jstr,jend
146 DO i=istr,iend
147 hfac(i,j)=dtsizeh*pm(i,j)*pn(i,j)
148 END DO
149 END DO
150 nold=1
151 nnew=2
152!
153!------------------------------------------------------------------------
154! Adjoint of load convolved solution.
155!------------------------------------------------------------------------
156!
157# ifdef DISTRIBUTE
158!^ CALL mp_exchange2d (ng, tile, model, 1, &
159!^ & LBi, UBi, LBj, UBj, &
160!^ & Nghost, &
161!^ & EWperiodic(ng), NSperiodic(ng), &
162!^ & tl_A)
163!^
164 CALL ad_mp_exchange2d (ng, tile, model, 1, &
165 & lbi, ubi, lbj, ubj, &
166 & nghost, &
167 & ewperiodic(ng), nsperiodic(ng), &
168 & ad_a)
169# endif
170!^ CALL dabc_r2d_tile (ng, tile, &
171!^ & LBi, UBi, LBj, UBj, &
172!^ & tl_A)
173!^
174 CALL ad_dabc_r2d_tile (ng, tile, &
175 & lbi, ubi, lbj, ubj, &
176 & ad_a)
177 DO j=jstr,jend
178 DO i=istr,iend
179!^ tl_A(i,j)=tl_Awrk(i,j,Nold)
180!^
181 ad_awrk(i,j,nold)=ad_awrk(i,j,nold)+ad_a(i,j)
182 ad_a(i,j)=0.0_r8
183 END DO
184 END DO
185!
186!-----------------------------------------------------------------------
187! Integrate adjoint horizontal diffusion terms.
188!-----------------------------------------------------------------------
189!
190 DO step=1,nhsteps
191!
192! Update integration indices.
193!
194 nsav=nnew
195 nnew=nold
196 nold=nsav
197!
198! Apply adjoint boundary conditions. If applicable, exchange boundary
199! data.
200!
201# ifdef DISTRIBUTE
202!^ CALL mp_exchange2d (ng, tile, model, 1, &
203!^ & LBi, UBi, LBj, UBj, &
204!^ & Nghost, &
205!^ & EWperiodic(ng), NSperiodic(ng), &
206!^ & tl_Awrk(:,:,Nnew))
207!^
208 CALL ad_mp_exchange2d (ng, tile, model, 1, &
209 & lbi, ubi, lbj, ubj, &
210 & nghost, &
211 & ewperiodic(ng), nsperiodic(ng), &
212 & ad_awrk(:,:,nnew))
213# endif
214!^ CALL dabc_r2d_tile (ng, tile, &
215!^ & LBi, UBi, LBj, UBj, &
216!^ & tl_Awrk(:,:,Nnew))
217!^
218 CALL ad_dabc_r2d_tile (ng, tile, &
219 & lbi, ubi, lbj, ubj, &
220 & ad_awrk(:,:,nnew))
221!
222! Time-step adjoint horizontal diffusion terms.
223!
224 DO j=jstr,jend
225 DO i=istr,iend
226!^ tl_Awrk(i,j,Nnew)=tl_Awrk(i,j,Nold)+ &
227!^ & Hfac(i,j)* &
228!^ & (tl_FX(i+1,j)-tl_FX(i,j)+ &
229!^ & tl_FE(i,j+1)-tl_FE(i,j))
230!^
231 adfac=hfac(i,j)*ad_awrk(i,j,nnew)
232 ad_fe(i,j )=ad_fe(i,j )-adfac
233 ad_fe(i,j+1)=ad_fe(i,j+1)+adfac
234 ad_fx(i ,j)=ad_fx(i ,j)-adfac
235 ad_fx(i+1,j)=ad_fx(i+1,j)+adfac
236 ad_awrk(i,j,nold)=ad_awrk(i,j,nold)+ad_awrk(i,j,nnew)
237 ad_awrk(i,j,nnew)=0.0_r8
238 END DO
239 END DO
240!
241! Compute XI- and ETA-components of the adjoint diffusive flux.
242!
243 DO j=jstr,jend+1
244 DO i=istr,iend
245# ifdef MASKING
246!^ tl_FE(i,j)=tl_FE(i,j)*vmask(i,j)
247!^
248 ad_fe(i,j)=ad_fe(i,j)*vmask(i,j)
249# endif
250!^ tl_FE(i,j)=pnom_v(i,j)*0.5_r8*(Kh(i,j-1)+Kh(i,j))* &
251!^ & (tl_Awrk(i,j,Nold)-tl_Awrk(i,j-1,Nold))
252!^
253 adfac=pnom_v(i,j)*0.5_r8*(kh(i,j-1)+kh(i,j))*ad_fe(i,j)
254 ad_awrk(i,j-1,nold)=ad_awrk(i,j-1,nold)-adfac
255 ad_awrk(i,j ,nold)=ad_awrk(i,j ,nold)+adfac
256 ad_fe(i,j)=0.0_r8
257 END DO
258 END DO
259 DO j=jstr,jend
260 DO i=istr,iend+1
261# ifdef MASKING
262!^ tl_FX(i,j)=tl_FX(i,j)*umask(i,j)
263!^
264 ad_fx(i,j)=ad_fx(i,j)*umask(i,j)
265# endif
266!^ tl_FX(i,j)=pmon_u(i,j)*0.5_r8*(Kh(i-1,j)+Kh(i,j))* &
267!^ & (tl_Awrk(i,j,Nold)-tl_Awrk(i-1,j,Nold))
268!^
269 adfac=pmon_u(i,j)*0.5_r8*(kh(i-1,j)+kh(i,j))*ad_fx(i,j)
270 ad_awrk(i-1,j,nold)=ad_awrk(i-1,j,nold)-adfac
271 ad_awrk(i ,j,nold)=ad_awrk(i ,j,nold)+adfac
272 ad_fx(i,j)=0.0_r8
273 END DO
274 END DO
275
276 END DO
277!
278! Set adjoint initial conditions.
279!
280 DO j=jstr-1,jend+1
281 DO i=istr-1,iend+1
282!^ tl_Awrk(i,j,Nold)=tl_A(i,j)
283!^
284 ad_a(i,j)=ad_a(i,j)+ad_awrk(i,j,nold)
285 ad_awrk(i,j,nold)=0.0_r8
286 END DO
287 END DO
288# ifdef DISTRIBUTE
289!^ CALL mp_exchange2d (ng, tile, model, 1, &
290!^ & LBi, UBi, LBj, UBj, &
291!^ & Nghost, &
292!^ EWperiodic(ng), NSperiodic(ng), &
293!^ & tl_A)
294!^
295 CALL ad_mp_exchange2d (ng, tile, model, 1, &
296 & lbi, ubi, lbj, ubj, &
297 & nghost, &
298 & ewperiodic(ng), nsperiodic(ng), &
299 & ad_a)
300# endif
301!^ CALL dabc_r2d_tile (ng, tile, &
302!^ & LBi, UBi, LBj, UBj, &
303!^ & tl_A)
304!^
305 CALL ad_dabc_r2d_tile (ng, tile, &
306 & lbi, ubi, lbj, ubj, &
307 & ad_a)
308
309 RETURN
310 END SUBROUTINE ad_conv_r2d_tile
311!
312!***********************************************************************
313 SUBROUTINE ad_conv_u2d_tile (ng, tile, model, &
314 & LBi, UBi, LBj, UBj, &
315 & IminS, ImaxS, JminS, JmaxS, &
316 & Nghost, NHsteps, DTsizeH, &
317 & Kh, &
318 & pm, pn, pmon_r, pnom_p, &
319# ifdef MASKING
320 & umask, pmask, &
321# endif
322 & ad_A)
323!***********************************************************************
324!
325 USE mod_param
326 USE mod_scalars
327!
328 USE ad_bc_2d_mod, ONLY: ad_dabc_u2d_tile
329# ifdef DISTRIBUTE
330 USE mp_exchange_mod, ONLY : ad_mp_exchange2d
331# endif
332!
333! Imported variable declarations.
334!
335 integer, intent(in) :: ng, tile, model
336 integer, intent(in) :: LBi, UBi, LBj, UBj
337 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
338 integer, intent(in) :: Nghost, NHsteps
339
340 real(r8), intent(in) :: DTsizeH
341!
342# ifdef ASSUMED_SHAPE
343 real(r8), intent(in) :: pm(LBi:,LBj:)
344 real(r8), intent(in) :: pn(LBi:,LBj:)
345 real(r8), intent(in) :: pmon_r(LBi:,LBj:)
346 real(r8), intent(in) :: pnom_p(LBi:,LBj:)
347# ifdef MASKING
348 real(r8), intent(in) :: umask(LBi:,LBj:)
349 real(r8), intent(in) :: pmask(LBi:,LBj:)
350# endif
351 real(r8), intent(in) :: Kh(LBi:,LBj:)
352 real(r8), intent(inout) :: ad_A(LBi:,LBj:)
353# else
354 real(r8), intent(in) :: pm(LBi:UBi,LBj:UBj)
355 real(r8), intent(in) :: pn(LBi:UBi,LBj:UBj)
356 real(r8), intent(in) :: pmon_r(LBi:UBi,LBj:UBj)
357 real(r8), intent(in) :: pnom_p(LBi:UBi,LBj:UBj)
358# ifdef MASKING
359 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
360 real(r8), intent(in) :: pmask(LBi:UBi,LBj:UBj)
361# endif
362 real(r8), intent(in) :: Kh(LBi:UBi,LBj:UBj)
363 real(r8), intent(inout) :: ad_A(LBi:UBi,LBj:UBj)
364# endif
365!
366! Local variable declarations.
367!
368 integer :: Nnew, Nold, Nsav, i, j, step
369
370 real(r8) :: adfac, cff
371
372 real(r8), dimension(LBi:UBi,LBj:UBj,2) :: ad_Awrk
373
374 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_FE
375 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_FX
376 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Hfac
377
378# include "set_bounds.h"
379!
380!-----------------------------------------------------------------------
381! Initialize adjoint private variables.
382!-----------------------------------------------------------------------
383!
384 ad_awrk(lbi:ubi,lbj:ubj,1:2)=0.0_r8
385
386 ad_fe(imins:imaxs,jmins:jmaxs)=0.0_r8
387 ad_fx(imins:imaxs,jmins:jmaxs)=0.0_r8
388!
389!-----------------------------------------------------------------------
390! Adjoint space convolution of the diffusion equation for a 2D state
391! variable at U-points.
392!-----------------------------------------------------------------------
393!
394! Compute metrics factor.
395!
396 cff=dtsizeh*0.25_r8
397 DO j=jstr,jend
398 DO i=istru,iend
399 hfac(i,j)=cff*(pm(i-1,j)+pm(i,j))*(pn(i-1,j)+pn(i,j))
400 END DO
401 END DO
402 nold=1
403 nnew=2
404!
405!------------------------------------------------------------------------
406! Adjoint of load convolved solution.
407!------------------------------------------------------------------------
408!
409# ifdef DISTRIBUTE
410!^ CALL mp_exchange2d (ng, tile, model, 1, &
411!^ & LBi, UBi, LBj, UBj, &
412!^ & Nghost, &
413!^ & EWperiodic(ng), NSperiodic(ng), &
414!^ & tl_A)
415!^
416 CALL ad_mp_exchange2d (ng, tile, model, 1, &
417 & lbi, ubi, lbj, ubj, &
418 & nghost, &
419 & ewperiodic(ng), nsperiodic(ng), &
420 & ad_a)
421# endif
422!^ CALL dabc_u2d_tile (ng, tile, &
423!^ & LBi, UBi, LBj, UBj, &
424!^ & tl_A)
425!^
426 CALL ad_dabc_u2d_tile (ng, tile, &
427 & lbi, ubi, lbj, ubj, &
428 & ad_a)
429 DO j=jstr,jend
430 DO i=istru,iend
431!^ tl_A(i,j)=tl_Awrk(i,j,Nold)
432!^
433 ad_awrk(i,j,nold)=ad_awrk(i,j,nold)+ad_a(i,j)
434 ad_a(i,j)=0.0_r8
435 END DO
436 END DO
437!
438!-----------------------------------------------------------------------
439! Integrate adjoint horizontal diffusion terms.
440!-----------------------------------------------------------------------
441!
442 DO step=1,nhsteps
443!
444! Update integration indices.
445!
446 nsav=nnew
447 nnew=nold
448 nold=nsav
449!
450! Apply adjoint boundary conditions. If applicable, exchange boundary
451! data.
452!
453# ifdef DISTRIBUTE
454!^ CALL mp_exchange2d (ng, tile, model, 1, &
455!^ & LBi, UBi, LBj, UBj, &
456!^ & Nghost, &
457!^ & EWperiodic(ng), NSperiodic(ng), &
458!^ & tl_Awrk(:,:,Nnew))
459!^
460 CALL ad_mp_exchange2d (ng, tile, model, 1, &
461 & lbi, ubi, lbj, ubj, &
462 & nghost, &
463 & ewperiodic(ng), nsperiodic(ng), &
464 & ad_awrk(:,:,nnew))
465# endif
466!^ CALL dabc_u2d_tile (ng, tile, &
467!^ & LBi, UBi, LBj, UBj, &
468!^ & tl_Awrk(:,:,Nnew))
469!^
470 CALL ad_dabc_u2d_tile (ng, tile, &
471 & lbi, ubi, lbj, ubj, &
472 & ad_awrk(:,:,nnew))
473!
474! Time-step adjoint horizontal diffusion terms.
475!
476 DO j=jstr,jend
477 DO i=istru,iend
478!^ tl_Awrk(i,j,Nnew)=tl_Awrk(i,j,Nold)+ &
479!^ & Hfac(i,j)* &
480!^ & (tl_FX(i,j)-tl_FX(i-1,j)+ &
481!^ & tl_FE(i,j+1)-tl_FE(i,j))
482!^
483 adfac=hfac(i,j)*ad_awrk(i,j,nnew)
484 ad_fe(i,j )=ad_fe(i,j )-adfac
485 ad_fe(i,j+1)=ad_fe(i,j+1)+adfac
486 ad_fx(i-1,j)=ad_fx(i-1,j)-adfac
487 ad_fx(i ,j)=ad_fx(i ,j)+adfac
488 ad_awrk(i,j,nold)=ad_awrk(i,j,nold)+ad_awrk(i,j,nnew)
489 ad_awrk(i,j,nnew)=0.0_r8
490 END DO
491 END DO
492!
493! Compute XI- and ETA-components of the adjoint diffusive flux.
494!
495 DO j=jstr,jend+1
496 DO i=istru,iend
497# ifdef MASKING
498!^ tl_FE(i,j)=tl_FE(i,j)*pmask(i,j)
499!^
500 ad_fe(i,j)=ad_fe(i,j)*pmask(i,j)
501# endif
502!^ tl_FE(i,j)=pnom_p(i,j)*0.25_r8*(Kh(i-1,j )+Kh(i,j )+ &
503!^ & Kh(i-1,j-1)+Kh(i,j-1))* &
504!^ & (tl_Awrk(i,j,Nold)-tl_Awrk(i,j-1,Nold))
505!^
506 adfac=pnom_p(i,j)*0.25_r8*(kh(i-1,j )+kh(i,j )+ &
507 & kh(i-1,j-1)+kh(i,j-1))* &
508 & ad_fe(i,j)
509 ad_awrk(i,j-1,nold)=ad_awrk(i,j-1,nold)-adfac
510 ad_awrk(i,j ,nold)=ad_awrk(i,j ,nold)+adfac
511 ad_fe(i,j)=0.0_r8
512 END DO
513 END DO
514 DO j=jstr,jend
515 DO i=istru-1,iend
516!^ tl_FX(i,j)=pmon_r(i,j)*Kh(i,j)* &
517!^ & (tl_Awrk(i+1,j,Nold)-tl_Awrk(i,j,Nold))
518!^
519 adfac=pmon_r(i,j)*kh(i,j)*ad_fx(i,j)
520 ad_awrk(i ,j,nold)=ad_awrk(i ,j,nold)-adfac
521 ad_awrk(i+1,j,nold)=ad_awrk(i+1,j,nold)+adfac
522 ad_fx(i,j)=0.0_r8
523 END DO
524 END DO
525
526 END DO
527!
528! Set adjoint initial conditions.
529!
530 DO j=jstr-1,jend+1
531 DO i=istru-1,iend+1
532!^ tl_Awrk(i,j,Nold)=tl_A(i,j)
533!^
534 ad_a(i,j)=ad_a(i,j)+ad_awrk(i,j,nold)
535 ad_awrk(i,j,nold)=0.0_r8
536 END DO
537 END DO
538# ifdef DISTRIBUTE
539!^ CALL mp_exchange2d (ng, tile, model, 1, &
540!^ & LBi, UBi, LBj, UBj, &
541!^ & Nghost, &
542!^ & EWperiodic(ng), NSperiodic(ng), &
543!^ & tl_A)
544!^
545 CALL ad_mp_exchange2d (ng, tile, model, 1, &
546 & lbi, ubi, lbj, ubj, &
547 & nghost, &
548 & ewperiodic(ng), nsperiodic(ng), &
549 & ad_a)
550# endif
551!^ CALL dabc_u2d_tile (ng, tile, &
552!^ & LBi, UBi, LBj, UBj, &
553!^ & tl_A)
554!^
555 CALL ad_dabc_u2d_tile (ng, tile, &
556 & lbi, ubi, lbj, ubj, &
557 & ad_a)
558
559 RETURN
560 END SUBROUTINE ad_conv_u2d_tile
561!
562!***********************************************************************
563 SUBROUTINE ad_conv_v2d_tile (ng, tile, model, &
564 & LBi, UBi, LBj, UBj, &
565 & IminS, ImaxS, JminS, JmaxS, &
566 & Nghost, NHsteps, DTsizeH, &
567 & Kh, &
568 & pm, pn, pmon_p, pnom_r, &
569# ifdef MASKING
570 & vmask, pmask, &
571# endif
572 & ad_A)
573!***********************************************************************
574!
575 USE mod_param
576 USE mod_scalars
577!
578 USE ad_bc_2d_mod, ONLY: ad_dabc_v2d_tile
579# ifdef DISTRIBUTE
580 USE mp_exchange_mod, ONLY : ad_mp_exchange2d
581# endif
582!
583! Imported variable declarations.
584!
585 integer, intent(in) :: ng, tile, model
586 integer, intent(in) :: LBi, UBi, LBj, UBj
587 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
588 integer, intent(in) :: Nghost, NHsteps
589
590 real(r8), intent(in) :: DTsizeH
591!
592# ifdef ASSUMED_SHAPE
593 real(r8), intent(in) :: pm(LBi:,LBj:)
594 real(r8), intent(in) :: pn(LBi:,LBj:)
595 real(r8), intent(in) :: pmon_p(LBi:,LBj:)
596 real(r8), intent(in) :: pnom_r(LBi:,LBj:)
597# ifdef MASKING
598 real(r8), intent(in) :: vmask(LBi:,LBj:)
599 real(r8), intent(in) :: pmask(LBi:,LBj:)
600# endif
601 real(r8), intent(in) :: Kh(LBi:,LBj:)
602 real(r8), intent(inout) :: ad_A(LBi:,LBj:)
603# else
604 real(r8), intent(in) :: pm(LBi:UBi,LBj:UBj)
605 real(r8), intent(in) :: pn(LBi:UBi,LBj:UBj)
606 real(r8), intent(in) :: pmon_p(LBi:UBi,LBj:UBj)
607 real(r8), intent(in) :: pnom_r(LBi:UBi,LBj:UBj)
608# ifdef MASKING
609 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
610 real(r8), intent(in) :: pmask(LBi:UBi,LBj:UBj)
611# endif
612 real(r8), intent(in) :: Kh(LBi:UBi,LBj:UBj)
613 real(r8), intent(inout) :: ad_A(LBi:UBi,LBj:UBj)
614# endif
615!
616! Local variable declarations.
617!
618 integer :: Nnew, Nold, Nsav, i, j, step
619
620 real(r8) :: adfac, cff
621
622 real(r8), dimension(LBi:UBi,LBj:UBj,2) :: ad_Awrk
623
624 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_FE
625 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: ad_FX
626 real(r8), dimension(IminS:ImaxS,JminS:JmaxS) :: Hfac
627
628# include "set_bounds.h"
629!
630!-----------------------------------------------------------------------
631! Initialize adjoint private variables.
632!-----------------------------------------------------------------------
633!
634 ad_awrk(lbi:ubi,lbj:ubj,1:2)=0.0_r8
635
636 ad_fe(imins:imaxs,jmins:jmaxs)=0.0_r8
637 ad_fx(imins:imaxs,jmins:jmaxs)=0.0_r8
638!
639!-----------------------------------------------------------------------
640! Space convolution of the diffusion equation for a 2D state variable
641! at V-points.
642!-----------------------------------------------------------------------
643!
644! Compute metrics factor.
645!
646 cff=dtsizeh*0.25_r8
647 DO j=jstrv,jend
648 DO i=istr,iend
649 hfac(i,j)=cff*(pm(i,j-1)+pm(i,j))*(pn(i,j-1)+pn(i,j))
650 END DO
651 END DO
652 nold=1
653 nnew=2
654!
655!------------------------------------------------------------------------
656! Adjoint of load convolved solution.
657!------------------------------------------------------------------------
658!
659# ifdef DISTRIBUTE
660!^ CALL mp_exchange2d (ng, tile, model, 1, &
661!^ & LBi, UBi, LBj, UBj, &
662!^ & Nghost, &
663!^ & EWperiodic(ng), NSperiodic(ng), &
664!^ & tl_A)
665!^
666 CALL ad_mp_exchange2d (ng, tile, model, 1, &
667 & lbi, ubi, lbj, ubj, &
668 & nghost, &
669 & ewperiodic(ng), nsperiodic(ng), &
670 & ad_a)
671# endif
672!^ CALL dabc_v2d_tile (ng, tile, &
673!^ & LBi, UBi, LBj, UBj, &
674!^ & tl_A)
675!^
676 CALL ad_dabc_v2d_tile (ng, tile, &
677 & lbi, ubi, lbj, ubj, &
678 & ad_a)
679 DO j=jstrv,jend
680 DO i=istr,iend
681!^ tl_A(i,j)=tl_Awrk(i,j,Nold)
682!^
683 ad_awrk(i,j,nold)=ad_awrk(i,j,nold)+ad_a(i,j)
684 ad_a(i,j)=0.0_r8
685 END DO
686 END DO
687!
688!-----------------------------------------------------------------------
689! Integrate adjoint horizontal diffusion terms.
690!-----------------------------------------------------------------------
691!
692 DO step=1,nhsteps
693!
694! Update integration indices.
695!
696 nsav=nnew
697 nnew=nold
698 nold=nsav
699!
700! Apply adjoint boundary conditions. If applicable, exchange boundary
701! data.
702!
703# ifdef DISTRIBUTE
704!^ CALL mp_exchange2d (ng, tile, model, 1, &
705!^ & LBi, UBi, LBj, UBj, &
706!^ & Nghost, &
707!^ & EWperiodic(ng), NSperiodic(ng), &
708!^ & tl_Awrk(:,:,Nnew))
709!^
710 CALL ad_mp_exchange2d (ng, tile, model, 1, &
711 & lbi, ubi, lbj, ubj, &
712 & nghost, &
713 & ewperiodic(ng), nsperiodic(ng), &
714 & ad_awrk(:,:,nnew))
715# endif
716!^ CALL dabc_v2d_tile (ng, tile, &
717!^ & LBi, UBi, LBj, UBj, &
718!^ & tl_Awrk(:,:,Nnew))
719!^
720 CALL ad_dabc_v2d_tile (ng, tile, &
721 & lbi, ubi, lbj, ubj, &
722 & ad_awrk(:,:,nnew))
723!
724! Time-step adjoint horizontal diffusion terms.
725!
726 DO j=jstrv,jend
727 DO i=istr,iend
728!^ tl_Awrk(i,j,Nnew)=tl_Awrk(i,j,Nold)+ &
729!^ & Hfac(i,j)* &
730!^ & (tl_FX(i+1,j)-tl_FX(i,j)+ &
731!^ & tl_FE(i,j)-tl_FE(i,j-1))
732!^
733 adfac=hfac(i,j)*ad_awrk(i,j,nnew)
734 ad_fe(i,j-1)=ad_fe(i,j-1)-adfac
735 ad_fe(i,j )=ad_fe(i,j )+adfac
736 ad_fx(i ,j)=ad_fx(i ,j)-adfac
737 ad_fx(i+1,j)=ad_fx(i+1,j)+adfac
738 ad_awrk(i,j,nold)=ad_awrk(i,j,nold)+ad_awrk(i,j,nnew)
739 ad_awrk(i,j,nnew)=0.0_r8
740 END DO
741 END DO
742!
743! Compute XI- and ETA-components of the adjoint diffusive flux.
744!
745 DO j=jstrv-1,jend
746 DO i=istr,iend
747!^ tl_FE(i,j)=pnom_r(i,j)*Kh(i,j)* &
748!^ & (tl_Awrk(i,j+1,Nold)-tl_Awrk(i,j,Nold))
749!^
750 adfac=pnom_r(i,j)*kh(i,j)*ad_fe(i,j)
751 ad_awrk(i,j ,nold)=ad_awrk(i,j ,nold)-adfac
752 ad_awrk(i,j+1,nold)=ad_awrk(i,j+1,nold)+adfac
753 ad_fe(i,j)=0.0_r8
754 END DO
755 END DO
756 DO j=jstrv,jend
757 DO i=istr,iend+1
758# ifdef MASKING
759!^ tl_FX(i,j)=tl_FX(i,j)*pmask(i,j)
760!^
761 ad_fx(i,j)=ad_fx(i,j)*pmask(i,j)
762# endif
763!^ tl_FX(i,j)=pmon_p(i,j)*0.25_r8*(Kh(i-1,j )+Kh(i,j )+ &
764!^ & Kh(i-1,j-1)+Kh(i,j-1))* &
765!^ & (tl_Awrk(i,j,Nold)-tl_Awrk(i-1,j,Nold))
766!^
767 adfac=pmon_p(i,j)*0.25_r8*(kh(i-1,j )+kh(i,j )+ &
768 & kh(i-1,j-1)+kh(i,j-1))* &
769 & ad_fx(i,j)
770 ad_awrk(i-1,j,nold)=ad_awrk(i-1,j,nold)-adfac
771 ad_awrk(i ,j,nold)=ad_awrk(i ,j,nold)+adfac
772 ad_fx(i,j)=0.0_r8
773 END DO
774 END DO
775
776 END DO
777!
778! Set adjoint initial conditions.
779!
780 DO j=jstrv-1,jend+1
781 DO i=istr-1,iend+1
782!^ tl_Awrk(i,j,Nold)=tl_A(i,j)
783!^
784 ad_a(i,j)=ad_a(i,j)+ad_awrk(i,j,nold)
785 ad_awrk(i,j,nold)=0.0_r8
786 END DO
787 END DO
788# ifdef DISTRIBUTE
789!^ CALL mp_exchange2d (ng, tile, model, 1, &
790!^ & LBi, UBi, LBj, UBj, &
791!^ & Nghost, &
792!^ & EWperiodic(ng), NSperiodic(ng), &
793!^ & tl_A)
794!^
795 CALL ad_mp_exchange2d (ng, tile, model, 1, &
796 & lbi, ubi, lbj, ubj, &
797 & nghost, &
798 & ewperiodic(ng), nsperiodic(ng), &
799 & ad_a)
800# endif
801!^ CALL dabc_v2d_tile (ng, tile, &
802!^ & LBi, UBi, LBj, UBj, &
803!^ & tl_A)
804!^
805 CALL ad_dabc_v2d_tile (ng, tile, &
806 & lbi, ubi, lbj, ubj, &
807 & ad_a)
808
809 RETURN
810 END SUBROUTINE ad_conv_v2d_tile
811#endif
812 END MODULE ad_conv_2d_mod
ad_bc_2d_mod
Definition ad_bc_2d.F:2
ad_bc_2d_mod::ad_dabc_v2d_tile
subroutine ad_dabc_v2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
Definition ad_bc_2d.F:969
ad_bc_2d_mod::ad_dabc_r2d_tile
subroutine ad_dabc_r2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
Definition ad_bc_2d.F:653
ad_bc_2d_mod::ad_dabc_u2d_tile
subroutine ad_dabc_u2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
Definition ad_bc_2d.F:810
ad_conv_2d_mod
Definition ad_conv_2d.F:3
ad_conv_2d_mod::ad_conv_u2d_tile
subroutine ad_conv_u2d_tile(ng, tile, model, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nghost, nhsteps, dtsizeh, kh, pm, pn, pmon_r, pnom_p, umask, pmask, ad_a)
Definition ad_conv_2d.F:323
ad_conv_2d_mod::ad_conv_r2d_tile
subroutine ad_conv_r2d_tile(ng, tile, model, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nghost, nhsteps, dtsizeh, kh, pm, pn, pmon_u, pnom_v, rmask, umask, vmask, ad_a)
Definition ad_conv_2d.F:70
ad_conv_2d_mod::ad_conv_v2d_tile
subroutine ad_conv_v2d_tile(ng, tile, model, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nghost, nhsteps, dtsizeh, kh, pm, pn, pmon_p, pnom_r, vmask, pmask, ad_a)
Definition ad_conv_2d.F:573
mod_param
Definition mod_param.F:2
mod_scalars
Definition mod_scalars.F:2
mod_scalars::ewperiodic
logical, dimension(:), allocatable ewperiodic
Definition mod_scalars.F:510
mod_scalars::nsperiodic
logical, dimension(:), allocatable nsperiodic
Definition mod_scalars.F:511
mp_exchange_mod
Definition mp_exchange.F:2
mp_exchange_mod::ad_mp_exchange2d
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)
Definition mp_exchange.F:4058