FV3 Bundle
a2b_edge_adm.F90
Go to the documentation of this file.
1 !***********************************************************************
2 !* GNU General Public License *
3 !* This file is a part of fvGFS. *
4 !* *
5 !* fvGFS is free software; you can redistribute it and/or modify it *
6 !* and are expected to follow the terms of the GNU General Public *
7 !* License as published by the Free Software Foundation; either *
8 !* version 2 of the License, or (at your option) any later version. *
9 !* *
10 !* fvGFS is distributed in the hope that it will be useful, but *
11 !* WITHOUT ANY WARRANTY; without even the implied warranty of *
12 !* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
13 !* General Public License for more details. *
14 !* *
15 !* For the full text of the GNU General Public License, *
16 !* write to: Free Software Foundation, Inc., *
17 !* 675 Mass Ave, Cambridge, MA 02139, USA. *
18 !* or see: http://www.gnu.org/licenses/gpl.html *
19 !***********************************************************************
20 module a2b_edge_adm_mod
21 
22  use fv_grid_utils_nlm_mod, only: great_circle_dist
23 #ifdef VAN2
24  use fv_grid_utils_nlm_mod, only: van2
25 #endif
26 
27  use fv_arrays_nlm_mod, only: fv_grid_type, r_grid
28 
29  use tapenade_iter, only: pushcontrol, popcontrol, pushinteger, popinteger, &
30  pushrealarray, poprealarray, pushrealarray_adm, poprealarray_adm
31 
32  implicit none
33 
34  real, parameter:: r3 = 1./3.
35 !----------------------------
36 ! 4-pt Lagrange interpolation
37 !----------------------------
38  real, parameter:: a1 = 0.5625 ! 9/16
39  real, parameter:: a2 = -0.0625 ! -1/16
40 !----------------------
41 ! PPM volume mean form:
42 !----------------------
43  real, parameter:: b1 = 7./12. ! 0.58333333
44  real, parameter:: b2 = -1./12.
45 
46  private
47  public :: a2b_ord2, a2b_ord4, &
48  a2b_ord2_fwd, a2b_ord4_fwd, &
49  a2b_ord2_bwd, a2b_ord4_bwd, a2b_ord4_adm
50 
51 CONTAINS
52 ! Differentiation of a2b_ord4 in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2 dyn_c
53 !ore_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_mod.p_grad_c dyn_
54 !core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix_dp dyn_core_mo
55 !d.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dynamic
56 !s_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_utils_m
57 !od.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap_z fv_mapz_mod
58 !.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_mapz_mod.scalar
59 !_profile_fb fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_mapz_mod.steep
60 !z fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_restart_mod.d2c_se
61 !tup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_z main_mod.comp
62 !ute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mod.Riem_Solver_c
63 ! nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.SIM3p0_solver n
64 !h_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nest_halo_nh sw_
65 !core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2c_vect sw_core_
66 !mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v sw_core_mod.co
67 !mpute_divergence_damping_fb sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.copy_corners_
68 !fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_circle
69 !_dist sw_core_mod.edge_interpolate4)):
70 ! gradient of useful results: qin qout
71 ! with respect to varying inputs: qin
72  SUBROUTINE a2b_ord4_adm(qin, qin_ad, qout, qout_ad, gridstruct, npx, &
73 & npy, is, ie, js, je, ng, replace)
74  IMPLICIT NONE
75  INTEGER, INTENT(IN) :: npx, npy, is, ie, js, je, ng
76 ! A-grid field
77  REAL, INTENT(INOUT) :: qin(is-ng:ie+ng, js-ng:je+ng)
78  REAL, INTENT(INOUT) :: qin_ad(is-ng:ie+ng, js-ng:je+ng)
79 ! Output B-grid field
80  REAL, INTENT(INOUT) :: qout(is-ng:ie+ng, js-ng:je+ng)
81  REAL, INTENT(INOUT) :: qout_ad(is-ng:ie+ng, js-ng:je+ng)
82  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
83  LOGICAL, OPTIONAL, INTENT(IN) :: replace
84 ! local: compact 4-pt cubic
85  REAL, PARAMETER :: c1=2./3.
86  REAL, PARAMETER :: c2=-(1./6.)
87 ! Parabolic spline
88 ! real, parameter:: c1 = 0.75
89 ! real, parameter:: c2 = -0.25
90  REAL :: qx(is:ie+1, js-ng:je+ng)
91  REAL :: qx_ad(is:ie+1, js-ng:je+ng)
92  REAL :: qy(is-ng:ie+ng, js:je+1)
93  REAL :: qy_ad(is-ng:ie+ng, js:je+1)
94  REAL :: qxx(is-ng:ie+ng, js-ng:je+ng)
95  REAL :: qxx_ad(is-ng:ie+ng, js-ng:je+ng)
96  REAL :: qyy(is-ng:ie+ng, js-ng:je+ng)
97  REAL :: qyy_ad(is-ng:ie+ng, js-ng:je+ng)
98  REAL :: g_in, g_ou
99  REAL :: p0(2)
100  REAL :: q1(is-1:ie+1), q2(js-1:je+1)
101  REAL :: q1_ad(is-1:ie+1), q2_ad(js-1:je+1)
102  INTEGER :: i, j, is1, js1, is2, js2, ie1, je1
103  REAL, DIMENSION(:, :, :), POINTER :: grid, agrid
104  REAL, DIMENSION(:, :), POINTER :: dxa, dya
105  REAL(kind=r_grid), DIMENSION(:), POINTER :: edge_w, edge_e, edge_s, &
106 & edge_n
107  INTRINSIC max
108  INTRINSIC min
109  INTRINSIC PRESENT
110  INTEGER :: max1
111  INTEGER :: max2
112  INTEGER :: max3
113  INTEGER :: max4
114  INTEGER :: max5
115  INTEGER :: max6
116  INTEGER :: max7
117  INTEGER :: max8
118  INTEGER :: max9
119  INTEGER :: max10
120  INTEGER :: max11
121  INTEGER :: max12
122  INTEGER :: max13
123  INTEGER :: max14
124  INTEGER :: max15
125  INTEGER :: min1
126  INTEGER :: min2
127  INTEGER :: min3
128  INTEGER :: min4
129  INTEGER :: min5
130  INTEGER :: min6
131  INTEGER :: min7
132  INTEGER :: min8
133  INTEGER :: min9
134  INTEGER :: min10
135  INTEGER :: min11
136  INTEGER :: min12
137  INTEGER :: min13
138  INTEGER :: min14
139  INTEGER :: min15
140  REAL :: result1
141  REAL :: result1_ad
142  REAL :: result2
143  REAL :: result2_ad
144  REAL :: result3
145  REAL :: result3_ad
146  REAL :: temp_ad
147  REAL :: temp_ad0
148  REAL :: temp_ad1
149  REAL :: temp_ad2
150  REAL :: temp_ad3
151  REAL :: temp_ad4
152  REAL :: temp_ad5
153  REAL :: temp_ad6
154  REAL :: temp_ad7
155  REAL :: temp_ad8
156  REAL :: temp_ad9
157  REAL :: temp_ad10
158  REAL :: temp_ad11
159  REAL :: temp_ad12
160  REAL :: temp_ad13
161  REAL :: temp_ad14
162  REAL :: temp_ad15
163  REAL :: temp_ad16
164  REAL :: temp_ad17
165  REAL :: temp_ad18
166  REAL :: temp_ad19
167  REAL :: temp_ad20
168  REAL :: temp_ad21
169  REAL :: temp_ad22
170  REAL :: temp_ad23
171  REAL :: temp_ad24
172  REAL :: temp_ad25
173  INTEGER :: ad_from
174  INTEGER :: ad_to
175  INTEGER :: ad_from0
176  INTEGER :: ad_to0
177  INTEGER :: ad_from1
178  INTEGER :: ad_to1
179  INTEGER :: ad_from2
180  INTEGER :: ad_to2
181  INTEGER :: ad_from3
182  INTEGER :: ad_to3
183  INTEGER :: branch
184  edge_w => gridstruct%edge_w
185  edge_e => gridstruct%edge_e
186  edge_s => gridstruct%edge_s
187  edge_n => gridstruct%edge_n
188  agrid => gridstruct%agrid
189  grid => gridstruct%grid
190  dxa => gridstruct%dxa
191  dya => gridstruct%dya
192  IF (gridstruct%grid_type .LT. 3) THEN
193  IF (1 .LT. is - 1) THEN
194  is1 = is - 1
195  ELSE
196  is1 = 1
197  END IF
198  IF (1 .LT. js - 1) THEN
199  js1 = js - 1
200  ELSE
201  js1 = 1
202  END IF
203  IF (2 .LT. is) THEN
204  is2 = is
205  ELSE
206  is2 = 2
207  END IF
208  IF (2 .LT. js) THEN
209  js2 = js
210  ELSE
211  js2 = 2
212  END IF
213  IF (npx - 1 .GT. ie + 1) THEN
214  ie1 = ie + 1
215  ELSE
216  ie1 = npx - 1
217  END IF
218  IF (npy - 1 .GT. je + 1) THEN
219  je1 = je + 1
220  ELSE
221  je1 = npy - 1
222  END IF
223 ! Corners:
224 ! 3-way extrapolation
225  IF (gridstruct%nested) THEN
226  CALL pushcontrol2b(0)
227  ELSE
228  IF (gridstruct%sw_corner) THEN
229  CALL pushcontrol1b(0)
230  ELSE
231  CALL pushcontrol1b(1)
232  END IF
233  IF (gridstruct%se_corner) THEN
234  CALL pushcontrol1b(0)
235  ELSE
236  CALL pushcontrol1b(1)
237  END IF
238  IF (gridstruct%ne_corner) THEN
239  CALL pushcontrol1b(0)
240  ELSE
241  CALL pushcontrol1b(1)
242  END IF
243  IF (gridstruct%nw_corner) THEN
244  p0(1:2) = grid(1, npy, 1:2)
245  CALL pushcontrol1b(1)
246  ELSE
247  CALL pushcontrol1b(0)
248  END IF
249  IF (1 .LT. js - 2) THEN
250  max1 = js - 2
251  ELSE
252  max1 = 1
253  END IF
254  IF (npy - 1 .GT. je + 2) THEN
255  min1 = je + 2
256  ELSE
257  min1 = npy - 1
258  END IF
259 !------------
260 ! X-Interior:
261 !------------
262  DO j=max1,min1
263  IF (3 .LT. is) THEN
264  max2 = is
265  ELSE
266  max2 = 3
267  END IF
268  IF (npx - 2 .GT. ie + 1) THEN
269  min2 = ie + 1
270  ELSE
271  min2 = npx - 2
272  END IF
273  ad_from = max2
274  i = min2 + 1
275  CALL pushinteger4(i - 1)
276  CALL pushinteger4(ad_from)
277  END DO
278 ! *** West Edges:
279  IF (is .EQ. 1) THEN
280  IF (1 .LT. js - 2) THEN
281  max3 = js - 2
282  ELSE
283  max3 = 1
284  END IF
285  IF (npy - 1 .GT. je + 2) THEN
286  min3 = je + 2
287  ELSE
288  min3 = npy - 1
289  END IF
290  CALL pushcontrol1b(0)
291  ELSE
292  CALL pushcontrol1b(1)
293  END IF
294 ! East Edges:
295  IF (ie + 1 .EQ. npx) THEN
296  IF (1 .LT. js - 2) THEN
297  max4 = js - 2
298  ELSE
299  max4 = 1
300  END IF
301  IF (npy - 1 .GT. je + 2) THEN
302  min4 = je + 2
303  ELSE
304  min4 = npy - 1
305  END IF
306  CALL pushcontrol2b(1)
307  ELSE
308  CALL pushcontrol2b(2)
309  END IF
310  END IF
311 !------------
312 ! Y-Interior:
313 !------------
314  IF (gridstruct%nested) THEN
315  CALL pushcontrol2b(0)
316  ELSE
317  IF (3 .LT. js) THEN
318  max5 = js
319  ELSE
320  max5 = 3
321  END IF
322  IF (npy - 2 .GT. je + 1) THEN
323  min5 = je + 1
324  ELSE
325  min5 = npy - 2
326  END IF
327  DO j=max5,min5
328  IF (1 .LT. is - 2) THEN
329  max6 = is - 2
330  ELSE
331  max6 = 1
332  END IF
333  IF (npx - 1 .GT. ie + 2) THEN
334  min6 = ie + 2
335  ELSE
336  min6 = npx - 1
337  END IF
338  ad_from0 = max6
339  i = min6 + 1
340  CALL pushinteger4(i - 1)
341  CALL pushinteger4(ad_from0)
342  END DO
343 ! South Edges:
344  IF (js .EQ. 1) THEN
345  IF (1 .LT. is - 2) THEN
346  max7 = is - 2
347  ELSE
348  max7 = 1
349  END IF
350  IF (npx - 1 .GT. ie + 2) THEN
351  min7 = ie + 2
352  ELSE
353  min7 = npx - 1
354  END IF
355  CALL pushcontrol1b(0)
356  ELSE
357  CALL pushcontrol1b(1)
358  END IF
359 ! North Edges:
360  IF (je + 1 .EQ. npy) THEN
361  IF (1 .LT. is - 2) THEN
362  max8 = is - 2
363  ELSE
364  max8 = 1
365  END IF
366  IF (npx - 1 .GT. ie + 2) THEN
367  min8 = ie + 2
368  ELSE
369  min8 = npx - 1
370  END IF
371  CALL pushcontrol2b(1)
372  ELSE
373  CALL pushcontrol2b(2)
374  END IF
375  END IF
376 !--------------------------------------
377  IF (gridstruct%nested) THEN
378  CALL pushcontrol2b(0)
379  ELSE
380  IF (3 .LT. js) THEN
381  max9 = js
382  ELSE
383  max9 = 3
384  END IF
385  IF (npy - 2 .GT. je + 1) THEN
386  min9 = je + 1
387  ELSE
388  min9 = npy - 2
389  END IF
390  DO j=max9,min9
391  IF (2 .LT. is) THEN
392  max10 = is
393  ELSE
394  max10 = 2
395  END IF
396  IF (npx - 1 .GT. ie + 1) THEN
397  min10 = ie + 1
398  ELSE
399  min10 = npx - 1
400  END IF
401  ad_from1 = max10
402  i = min10 + 1
403  CALL pushinteger4(i - 1)
404  CALL pushinteger4(ad_from1)
405  END DO
406  IF (js .EQ. 1) THEN
407  IF (2 .LT. is) THEN
408  max11 = is
409  ELSE
410  max11 = 2
411  END IF
412  IF (npx - 1 .GT. ie + 1) THEN
413  min11 = ie + 1
414  ELSE
415  min11 = npx - 1
416  END IF
417  CALL pushcontrol1b(0)
418  ELSE
419  CALL pushcontrol1b(1)
420  END IF
421  IF (je + 1 .EQ. npy) THEN
422  IF (2 .LT. is) THEN
423  max12 = is
424  ELSE
425  max12 = 2
426  END IF
427  IF (npx - 1 .GT. ie + 1) THEN
428  min12 = ie + 1
429  ELSE
430  min12 = npx - 1
431  END IF
432  CALL pushcontrol1b(1)
433  ELSE
434  CALL pushcontrol1b(0)
435  END IF
436  IF (2 .LT. js) THEN
437  max13 = js
438  ELSE
439  max13 = 2
440  END IF
441  IF (npy - 1 .GT. je + 1) THEN
442  min13 = je + 1
443  ELSE
444  min13 = npy - 1
445  END IF
446  DO j=max13,min13
447  IF (3 .LT. is) THEN
448  max14 = is
449  ELSE
450  max14 = 3
451  END IF
452  IF (npx - 2 .GT. ie + 1) THEN
453  min14 = ie + 1
454  ELSE
455  min14 = npx - 2
456  END IF
457  ad_from2 = max14
458  i = min14 + 1
459  CALL pushinteger4(i - 1)
460  CALL pushinteger4(ad_from2)
461  IF (is .EQ. 1) THEN
462  CALL pushcontrol1b(0)
463  ELSE
464  CALL pushcontrol1b(1)
465  END IF
466  IF (ie + 1 .EQ. npx) THEN
467  CALL pushcontrol1b(1)
468  ELSE
469  CALL pushcontrol1b(0)
470  END IF
471  IF (2 .LT. is) THEN
472  max15 = is
473  ELSE
474  max15 = 2
475  END IF
476  IF (npx - 1 .GT. ie + 1) THEN
477  min15 = ie + 1
478  ELSE
479  min15 = npx - 1
480  END IF
481  ad_from3 = max15
482  i = min15 + 1
483  CALL pushinteger4(i - 1)
484  CALL pushinteger4(ad_from3)
485  END DO
486  CALL pushcontrol2b(1)
487  END IF
488  ELSE
489  CALL pushcontrol2b(2)
490  END IF
491  IF (PRESENT(replace)) THEN
492  IF (replace) THEN
493  DO j=je+1,js,-1
494  DO i=ie+1,is,-1
495  qout_ad(i, j) = qout_ad(i, j) + qin_ad(i, j)
496  qin_ad(i, j) = 0.0
497  END DO
498  END DO
499  END IF
500  END IF
501  CALL popcontrol2b(branch)
502  IF (branch .EQ. 0) THEN
503  qy_ad = 0.0
504  qxx_ad = 0.0
505  qyy_ad = 0.0
506  DO j=je+1,js,-1
507  DO i=ie+1,is,-1
508  qxx_ad(i, j) = qxx_ad(i, j) + 0.5*qout_ad(i, j)
509  qyy_ad(i, j) = qyy_ad(i, j) + 0.5*qout_ad(i, j)
510  qout_ad(i, j) = 0.0
511  END DO
512  DO i=ie+1,is,-1
513  qy_ad(i-2, j) = qy_ad(i-2, j) + a2*qyy_ad(i, j)
514  qy_ad(i+1, j) = qy_ad(i+1, j) + a2*qyy_ad(i, j)
515  qy_ad(i-1, j) = qy_ad(i-1, j) + a1*qyy_ad(i, j)
516  qy_ad(i, j) = qy_ad(i, j) + a1*qyy_ad(i, j)
517  qyy_ad(i, j) = 0.0
518  END DO
519  END DO
520  qx_ad = 0.0
521  DO j=je+1,js,-1
522  DO i=ie+1,is,-1
523  qx_ad(i, j-2) = qx_ad(i, j-2) + a2*qxx_ad(i, j)
524  qx_ad(i, j+1) = qx_ad(i, j+1) + a2*qxx_ad(i, j)
525  qx_ad(i, j-1) = qx_ad(i, j-1) + a1*qxx_ad(i, j)
526  qx_ad(i, j) = qx_ad(i, j) + a1*qxx_ad(i, j)
527  qxx_ad(i, j) = 0.0
528  END DO
529  END DO
530  ELSE IF (branch .EQ. 1) THEN
531  qy_ad = 0.0
532  qxx_ad = 0.0
533  qyy_ad = 0.0
534  DO j=min13,max13,-1
535  CALL popinteger4(ad_from3)
536  CALL popinteger4(ad_to3)
537  DO i=ad_to3,ad_from3,-1
538  qxx_ad(i, j) = qxx_ad(i, j) + 0.5*qout_ad(i, j)
539  qyy_ad(i, j) = qyy_ad(i, j) + 0.5*qout_ad(i, j)
540  qout_ad(i, j) = 0.0
541  END DO
542  CALL popcontrol1b(branch)
543  IF (branch .NE. 0) THEN
544  qy_ad(npx-2, j) = qy_ad(npx-2, j) + c1*qyy_ad(npx-1, j)
545  qy_ad(npx-1, j) = qy_ad(npx-1, j) + c1*qyy_ad(npx-1, j)
546  qout_ad(npx, j) = qout_ad(npx, j) + c2*qyy_ad(npx-1, j)
547  qyy_ad(npx-2, j) = qyy_ad(npx-2, j) + c2*qyy_ad(npx-1, j)
548  qyy_ad(npx-1, j) = 0.0
549  END IF
550  CALL popcontrol1b(branch)
551  IF (branch .EQ. 0) THEN
552  qy_ad(1, j) = qy_ad(1, j) + c1*qyy_ad(2, j)
553  qy_ad(2, j) = qy_ad(2, j) + c1*qyy_ad(2, j)
554  qout_ad(1, j) = qout_ad(1, j) + c2*qyy_ad(2, j)
555  qyy_ad(3, j) = qyy_ad(3, j) + c2*qyy_ad(2, j)
556  qyy_ad(2, j) = 0.0
557  END IF
558  CALL popinteger4(ad_from2)
559  CALL popinteger4(ad_to2)
560  DO i=ad_to2,ad_from2,-1
561  qy_ad(i-2, j) = qy_ad(i-2, j) + a2*qyy_ad(i, j)
562  qy_ad(i+1, j) = qy_ad(i+1, j) + a2*qyy_ad(i, j)
563  qy_ad(i-1, j) = qy_ad(i-1, j) + a1*qyy_ad(i, j)
564  qy_ad(i, j) = qy_ad(i, j) + a1*qyy_ad(i, j)
565  qyy_ad(i, j) = 0.0
566  END DO
567  END DO
568  CALL popcontrol1b(branch)
569  IF (branch .EQ. 0) THEN
570  qx_ad = 0.0
571  ELSE
572  qx_ad = 0.0
573  DO i=min12,max12,-1
574  qx_ad(i, npy-2) = qx_ad(i, npy-2) + c1*qxx_ad(i, npy-1)
575  qx_ad(i, npy-1) = qx_ad(i, npy-1) + c1*qxx_ad(i, npy-1)
576  qout_ad(i, npy) = qout_ad(i, npy) + c2*qxx_ad(i, npy-1)
577  qxx_ad(i, npy-2) = qxx_ad(i, npy-2) + c2*qxx_ad(i, npy-1)
578  qxx_ad(i, npy-1) = 0.0
579  END DO
580  END IF
581  CALL popcontrol1b(branch)
582  IF (branch .EQ. 0) THEN
583  DO i=min11,max11,-1
584  qx_ad(i, 1) = qx_ad(i, 1) + c1*qxx_ad(i, 2)
585  qx_ad(i, 2) = qx_ad(i, 2) + c1*qxx_ad(i, 2)
586  qout_ad(i, 1) = qout_ad(i, 1) + c2*qxx_ad(i, 2)
587  qxx_ad(i, 3) = qxx_ad(i, 3) + c2*qxx_ad(i, 2)
588  qxx_ad(i, 2) = 0.0
589  END DO
590  END IF
591  DO j=min9,max9,-1
592  CALL popinteger4(ad_from1)
593  CALL popinteger4(ad_to1)
594  DO i=ad_to1,ad_from1,-1
595  qx_ad(i, j-2) = qx_ad(i, j-2) + a2*qxx_ad(i, j)
596  qx_ad(i, j+1) = qx_ad(i, j+1) + a2*qxx_ad(i, j)
597  qx_ad(i, j-1) = qx_ad(i, j-1) + a1*qxx_ad(i, j)
598  qx_ad(i, j) = qx_ad(i, j) + a1*qxx_ad(i, j)
599  qxx_ad(i, j) = 0.0
600  END DO
601  END DO
602  ELSE
603  qx_ad = 0.0
604  qy_ad = 0.0
605  DO j=je+1,js,-1
606  DO i=ie+1,is,-1
607  temp_ad23 = 0.5*qout_ad(i, j)
608  temp_ad24 = a1*temp_ad23
609  temp_ad25 = a2*temp_ad23
610  qx_ad(i, j-1) = qx_ad(i, j-1) + temp_ad24
611  qx_ad(i, j) = qx_ad(i, j) + temp_ad24
612  qy_ad(i-1, j) = qy_ad(i-1, j) + temp_ad24
613  qy_ad(i, j) = qy_ad(i, j) + temp_ad24
614  qx_ad(i, j-2) = qx_ad(i, j-2) + temp_ad25
615  qx_ad(i, j+1) = qx_ad(i, j+1) + temp_ad25
616  qy_ad(i-2, j) = qy_ad(i-2, j) + temp_ad25
617  qy_ad(i+1, j) = qy_ad(i+1, j) + temp_ad25
618  qout_ad(i, j) = 0.0
619  END DO
620  END DO
621  DO j=je+1,js,-1
622  DO i=ie+2,is-2,-1
623  qin_ad(i, j-1) = qin_ad(i, j-1) + b1*qy_ad(i, j)
624  qin_ad(i, j) = qin_ad(i, j) + b1*qy_ad(i, j)
625  qin_ad(i, j-2) = qin_ad(i, j-2) + b2*qy_ad(i, j)
626  qin_ad(i, j+1) = qin_ad(i, j+1) + b2*qy_ad(i, j)
627  qy_ad(i, j) = 0.0
628  END DO
629  END DO
630  DO j=je+2,js-2,-1
631  DO i=ie+1,is,-1
632  qin_ad(i-1, j) = qin_ad(i-1, j) + b1*qx_ad(i, j)
633  qin_ad(i, j) = qin_ad(i, j) + b1*qx_ad(i, j)
634  qin_ad(i-2, j) = qin_ad(i-2, j) + b2*qx_ad(i, j)
635  qin_ad(i+1, j) = qin_ad(i+1, j) + b2*qx_ad(i, j)
636  qx_ad(i, j) = 0.0
637  END DO
638  END DO
639  GOTO 100
640  END IF
641  CALL popcontrol2b(branch)
642  IF (branch .EQ. 0) THEN
643  DO j=je+1,js,-1
644  DO i=ie+2,is-2,-1
645  qin_ad(i, j-2) = qin_ad(i, j-2) + b2*qy_ad(i, j)
646  qin_ad(i, j+1) = qin_ad(i, j+1) + b2*qy_ad(i, j)
647  qin_ad(i, j-1) = qin_ad(i, j-1) + b1*qy_ad(i, j)
648  qin_ad(i, j) = qin_ad(i, j) + b1*qy_ad(i, j)
649  qy_ad(i, j) = 0.0
650  END DO
651  END DO
652  ELSE
653  IF (branch .EQ. 1) THEN
654  DO i=min8,max8,-1
655  g_in = dya(i, npy-2)/dya(i, npy-1)
656  temp_ad19 = qy_ad(i, npy-1)/(g_in*2.+2.)
657  qin_ad(i, npy-2) = qin_ad(i, npy-2) + 3.*temp_ad19
658  qy_ad(i, npy) = qy_ad(i, npy) - g_in*temp_ad19
659  qy_ad(i, npy-2) = qy_ad(i, npy-2) - temp_ad19
660  qy_ad(i, npy-1) = 0.0
661  g_ou = dya(i, npy+1)/dya(i, npy)
662  temp_ad21 = 0.5*qy_ad(i, npy)
663  temp_ad20 = temp_ad21/(g_in+1.)
664  qin_ad(i, npy-1) = qin_ad(i, npy-1) + (g_in+2.)*temp_ad20 + 3.&
665 & *g_in*temp_ad19
666  temp_ad22 = temp_ad21/(g_ou+1.)
667  qin_ad(i, npy-2) = qin_ad(i, npy-2) - temp_ad20
668  qin_ad(i, npy) = qin_ad(i, npy) + (g_ou+2.)*temp_ad22
669  qin_ad(i, npy+1) = qin_ad(i, npy+1) - temp_ad22
670  qy_ad(i, npy) = 0.0
671  END DO
672  q1_ad = 0.0
673  DO i=ie1,is2,-1
674  q1_ad(i-1) = q1_ad(i-1) + edge_n(i)*qout_ad(i, npy)
675  q1_ad(i) = q1_ad(i) + (1.-edge_n(i))*qout_ad(i, npy)
676  qout_ad(i, npy) = 0.0
677  END DO
678  DO i=ie1,is1,-1
679  temp_ad18 = q1_ad(i)/(dya(i, npy-1)+dya(i, npy))
680  qin_ad(i, npy-1) = qin_ad(i, npy-1) + dya(i, npy)*temp_ad18
681  qin_ad(i, npy) = qin_ad(i, npy) + dya(i, npy-1)*temp_ad18
682  q1_ad(i) = 0.0
683  END DO
684  ELSE
685  q1_ad = 0.0
686  END IF
687  CALL popcontrol1b(branch)
688  IF (branch .EQ. 0) THEN
689  DO i=min7,max7,-1
690  g_in = dya(i, 2)/dya(i, 1)
691  temp_ad14 = qy_ad(i, 2)/(g_in*2.+2.)
692  qin_ad(i, 1) = qin_ad(i, 1) + 3.*g_in*temp_ad14
693  qin_ad(i, 2) = qin_ad(i, 2) + 3.*temp_ad14
694  qy_ad(i, 1) = qy_ad(i, 1) - g_in*temp_ad14
695  qy_ad(i, 3) = qy_ad(i, 3) - temp_ad14
696  qy_ad(i, 2) = 0.0
697  g_ou = dya(i, -1)/dya(i, 0)
698  temp_ad15 = 0.5*qy_ad(i, 1)
699  temp_ad16 = temp_ad15/(g_in+1.)
700  temp_ad17 = temp_ad15/(g_ou+1.)
701  qin_ad(i, 1) = qin_ad(i, 1) + (g_in+2.)*temp_ad16
702  qin_ad(i, 2) = qin_ad(i, 2) - temp_ad16
703  qin_ad(i, 0) = qin_ad(i, 0) + (g_ou+2.)*temp_ad17
704  qin_ad(i, -1) = qin_ad(i, -1) - temp_ad17
705  qy_ad(i, 1) = 0.0
706  END DO
707  DO i=ie1,is2,-1
708  q1_ad(i-1) = q1_ad(i-1) + edge_s(i)*qout_ad(i, 1)
709  q1_ad(i) = q1_ad(i) + (1.-edge_s(i))*qout_ad(i, 1)
710  qout_ad(i, 1) = 0.0
711  END DO
712  DO i=ie1,is1,-1
713  temp_ad13 = q1_ad(i)/(dya(i, 0)+dya(i, 1))
714  qin_ad(i, 0) = qin_ad(i, 0) + dya(i, 1)*temp_ad13
715  qin_ad(i, 1) = qin_ad(i, 1) + dya(i, 0)*temp_ad13
716  q1_ad(i) = 0.0
717  END DO
718  END IF
719  DO j=min5,max5,-1
720  CALL popinteger4(ad_from0)
721  CALL popinteger4(ad_to0)
722  DO i=ad_to0,ad_from0,-1
723  qin_ad(i, j-2) = qin_ad(i, j-2) + b2*qy_ad(i, j)
724  qin_ad(i, j+1) = qin_ad(i, j+1) + b2*qy_ad(i, j)
725  qin_ad(i, j-1) = qin_ad(i, j-1) + b1*qy_ad(i, j)
726  qin_ad(i, j) = qin_ad(i, j) + b1*qy_ad(i, j)
727  qy_ad(i, j) = 0.0
728  END DO
729  END DO
730  END IF
731  CALL popcontrol2b(branch)
732  IF (branch .EQ. 0) THEN
733  DO j=je+2,js-2,-1
734  DO i=ie+1,is,-1
735  qin_ad(i-2, j) = qin_ad(i-2, j) + b2*qx_ad(i, j)
736  qin_ad(i+1, j) = qin_ad(i+1, j) + b2*qx_ad(i, j)
737  qin_ad(i-1, j) = qin_ad(i-1, j) + b1*qx_ad(i, j)
738  qin_ad(i, j) = qin_ad(i, j) + b1*qx_ad(i, j)
739  qx_ad(i, j) = 0.0
740  END DO
741  END DO
742  ELSE
743  IF (branch .EQ. 1) THEN
744  DO j=min4,max4,-1
745  g_in = dxa(npx-2, j)/dxa(npx-1, j)
746  temp_ad9 = qx_ad(npx-1, j)/(g_in*2.+2.)
747  qin_ad(npx-2, j) = qin_ad(npx-2, j) + 3.*temp_ad9
748  qx_ad(npx, j) = qx_ad(npx, j) - g_in*temp_ad9
749  qx_ad(npx-2, j) = qx_ad(npx-2, j) - temp_ad9
750  qx_ad(npx-1, j) = 0.0
751  g_ou = dxa(npx+1, j)/dxa(npx, j)
752  temp_ad11 = 0.5*qx_ad(npx, j)
753  temp_ad10 = temp_ad11/(g_in+1.)
754  qin_ad(npx-1, j) = qin_ad(npx-1, j) + (g_in+2.)*temp_ad10 + 3.&
755 & *g_in*temp_ad9
756  temp_ad12 = temp_ad11/(g_ou+1.)
757  qin_ad(npx-2, j) = qin_ad(npx-2, j) - temp_ad10
758  qin_ad(npx, j) = qin_ad(npx, j) + (g_ou+2.)*temp_ad12
759  qin_ad(npx+1, j) = qin_ad(npx+1, j) - temp_ad12
760  qx_ad(npx, j) = 0.0
761  END DO
762  q2_ad = 0.0
763  DO j=je1,js2,-1
764  q2_ad(j-1) = q2_ad(j-1) + edge_e(j)*qout_ad(npx, j)
765  q2_ad(j) = q2_ad(j) + (1.-edge_e(j))*qout_ad(npx, j)
766  qout_ad(npx, j) = 0.0
767  END DO
768  DO j=je1,js1,-1
769  temp_ad8 = q2_ad(j)/(dxa(npx-1, j)+dxa(npx, j))
770  qin_ad(npx-1, j) = qin_ad(npx-1, j) + dxa(npx, j)*temp_ad8
771  qin_ad(npx, j) = qin_ad(npx, j) + dxa(npx-1, j)*temp_ad8
772  q2_ad(j) = 0.0
773  END DO
774  ELSE
775  q2_ad = 0.0
776  END IF
777  CALL popcontrol1b(branch)
778  IF (branch .EQ. 0) THEN
779  DO j=min3,max3,-1
780  g_in = dxa(2, j)/dxa(1, j)
781  temp_ad4 = qx_ad(2, j)/(g_in*2.+2.)
782  qin_ad(1, j) = qin_ad(1, j) + 3.*g_in*temp_ad4
783  qin_ad(2, j) = qin_ad(2, j) + 3.*temp_ad4
784  qx_ad(1, j) = qx_ad(1, j) - g_in*temp_ad4
785  qx_ad(3, j) = qx_ad(3, j) - temp_ad4
786  qx_ad(2, j) = 0.0
787  g_ou = dxa(-1, j)/dxa(0, j)
788  temp_ad5 = 0.5*qx_ad(1, j)
789  temp_ad6 = temp_ad5/(g_in+1.)
790  temp_ad7 = temp_ad5/(g_ou+1.)
791  qin_ad(1, j) = qin_ad(1, j) + (g_in+2.)*temp_ad6
792  qin_ad(2, j) = qin_ad(2, j) - temp_ad6
793  qin_ad(0, j) = qin_ad(0, j) + (g_ou+2.)*temp_ad7
794  qin_ad(-1, j) = qin_ad(-1, j) - temp_ad7
795  qx_ad(1, j) = 0.0
796  END DO
797  DO j=je1,js2,-1
798  q2_ad(j-1) = q2_ad(j-1) + edge_w(j)*qout_ad(1, j)
799  q2_ad(j) = q2_ad(j) + (1.-edge_w(j))*qout_ad(1, j)
800  qout_ad(1, j) = 0.0
801  END DO
802  DO j=je1,js1,-1
803  temp_ad3 = q2_ad(j)/(dxa(0, j)+dxa(1, j))
804  qin_ad(0, j) = qin_ad(0, j) + dxa(1, j)*temp_ad3
805  qin_ad(1, j) = qin_ad(1, j) + dxa(0, j)*temp_ad3
806  q2_ad(j) = 0.0
807  END DO
808  END IF
809  DO j=min1,max1,-1
810  CALL popinteger4(ad_from)
811  CALL popinteger4(ad_to)
812  DO i=ad_to,ad_from,-1
813  qin_ad(i-2, j) = qin_ad(i-2, j) + b2*qx_ad(i, j)
814  qin_ad(i+1, j) = qin_ad(i+1, j) + b2*qx_ad(i, j)
815  qin_ad(i-1, j) = qin_ad(i-1, j) + b1*qx_ad(i, j)
816  qin_ad(i, j) = qin_ad(i, j) + b1*qx_ad(i, j)
817  qx_ad(i, j) = 0.0
818  END DO
819  END DO
820  CALL popcontrol1b(branch)
821  IF (branch .NE. 0) THEN
822  temp_ad2 = r3*qout_ad(1, npy)
823  result1_ad = temp_ad2
824  result2_ad = temp_ad2
825  result3_ad = temp_ad2
826  qout_ad(1, npy) = 0.0
827  CALL extrap_corner_adm(p0, agrid(1, npy, 1:2), agrid(2, npy+1, 1&
828 & :2), qin(1, npy), qin_ad(1, npy), qin(2, npy+1)&
829 & , qin_ad(2, npy+1), result3_ad)
830  CALL extrap_corner_adm(p0, agrid(0, npy-1, 1:2), agrid(-1, npy-2&
831 & , 1:2), qin(0, npy-1), qin_ad(0, npy-1), qin(-1&
832 & , npy-2), qin_ad(-1, npy-2), result2_ad)
833  CALL extrap_corner_adm(p0, agrid(1, npy-1, 1:2), agrid(2, npy-2&
834 & , 1:2), qin(1, npy-1), qin_ad(1, npy-1), qin(2&
835 & , npy-2), qin_ad(2, npy-2), result1_ad)
836  END IF
837  CALL popcontrol1b(branch)
838  IF (branch .EQ. 0) THEN
839  temp_ad1 = r3*qout_ad(npx, npy)
840  result1_ad = temp_ad1
841  result2_ad = temp_ad1
842  result3_ad = temp_ad1
843  qout_ad(npx, npy) = 0.0
844  p0(1:2) = grid(npx, npy, 1:2)
845  CALL extrap_corner_adm(p0, agrid(npx-1, npy, 1:2), agrid(npx-2, &
846 & npy+1, 1:2), qin(npx-1, npy), qin_ad(npx-1, npy&
847 & ), qin(npx-2, npy+1), qin_ad(npx-2, npy+1), &
848 & result3_ad)
849  CALL extrap_corner_adm(p0, agrid(npx, npy-1, 1:2), agrid(npx+1, &
850 & npy-2, 1:2), qin(npx, npy-1), qin_ad(npx, npy-1&
851 & ), qin(npx+1, npy-2), qin_ad(npx+1, npy-2), &
852 & result2_ad)
853  CALL extrap_corner_adm(p0, agrid(npx-1, npy-1, 1:2), agrid(npx-2&
854 & , npy-2, 1:2), qin(npx-1, npy-1), qin_ad(npx-1&
855 & , npy-1), qin(npx-2, npy-2), qin_ad(npx-2, npy-&
856 & 2), result1_ad)
857  END IF
858  CALL popcontrol1b(branch)
859  IF (branch .EQ. 0) THEN
860  temp_ad0 = r3*qout_ad(npx, 1)
861  result1_ad = temp_ad0
862  result2_ad = temp_ad0
863  result3_ad = temp_ad0
864  qout_ad(npx, 1) = 0.0
865  p0(1:2) = grid(npx, 1, 1:2)
866  CALL extrap_corner_adm(p0, agrid(npx, 1, 1:2), agrid(npx+1, 2, 1&
867 & :2), qin(npx, 1), qin_ad(npx, 1), qin(npx+1, 2)&
868 & , qin_ad(npx+1, 2), result3_ad)
869  CALL extrap_corner_adm(p0, agrid(npx-1, 0, 1:2), agrid(npx-2, -1&
870 & , 1:2), qin(npx-1, 0), qin_ad(npx-1, 0), qin(&
871 & npx-2, -1), qin_ad(npx-2, -1), result2_ad)
872  CALL extrap_corner_adm(p0, agrid(npx-1, 1, 1:2), agrid(npx-2, 2&
873 & , 1:2), qin(npx-1, 1), qin_ad(npx-1, 1), qin(&
874 & npx-2, 2), qin_ad(npx-2, 2), result1_ad)
875  END IF
876  CALL popcontrol1b(branch)
877  IF (branch .EQ. 0) THEN
878  temp_ad = r3*qout_ad(1, 1)
879  result1_ad = temp_ad
880  result2_ad = temp_ad
881  result3_ad = temp_ad
882  p0(1:2) = grid(1, 1, 1:2)
883  CALL extrap_corner_adm(p0, agrid(1, 0, 1:2), agrid(2, -1, 1:2), &
884 & qin(1, 0), qin_ad(1, 0), qin(2, -1), qin_ad(2, &
885 & -1), result3_ad)
886  CALL extrap_corner_adm(p0, agrid(0, 1, 1:2), agrid(-1, 2, 1:2), &
887 & qin(0, 1), qin_ad(0, 1), qin(-1, 2), qin_ad(-1&
888 & , 2), result2_ad)
889  CALL extrap_corner_adm(p0, agrid(1, 1, 1:2), agrid(2, 2, 1:2), &
890 & qin(1, 1), qin_ad(1, 1), qin(2, 2), qin_ad(2, 2&
891 & ), result1_ad)
892  END IF
893  END IF
894  100 CONTINUE
895  END SUBROUTINE a2b_ord4_adm
896  SUBROUTINE a2b_ord4(qin, qout, gridstruct, npx, npy, is, ie, js, je, &
897 & ng, replace)
898  IMPLICIT NONE
899  INTEGER, INTENT(IN) :: npx, npy, is, ie, js, je, ng
900 ! A-grid field
901  REAL, INTENT(INOUT) :: qin(is-ng:ie+ng, js-ng:je+ng)
902 ! Output B-grid field
903  REAL, INTENT(INOUT) :: qout(is-ng:ie+ng, js-ng:je+ng)
904  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
905  LOGICAL, OPTIONAL, INTENT(IN) :: replace
906 ! local: compact 4-pt cubic
907  REAL, PARAMETER :: c1=2./3.
908  REAL, PARAMETER :: c2=-(1./6.)
909 ! Parabolic spline
910 ! real, parameter:: c1 = 0.75
911 ! real, parameter:: c2 = -0.25
912  REAL :: qx(is:ie+1, js-ng:je+ng)
913  REAL :: qy(is-ng:ie+ng, js:je+1)
914  REAL :: qxx(is-ng:ie+ng, js-ng:je+ng)
915  REAL :: qyy(is-ng:ie+ng, js-ng:je+ng)
916  REAL :: g_in, g_ou
917  REAL :: p0(2)
918  REAL :: q1(is-1:ie+1), q2(js-1:je+1)
919  INTEGER :: i, j, is1, js1, is2, js2, ie1, je1
920  REAL, DIMENSION(:, :, :), POINTER :: grid, agrid
921  REAL, DIMENSION(:, :), POINTER :: dxa, dya
922  REAL(kind=r_grid), DIMENSION(:), POINTER :: edge_w, edge_e, edge_s, &
923 & edge_n
924  INTRINSIC max
925  INTRINSIC min
926  INTRINSIC PRESENT
927  INTEGER :: max1
928  INTEGER :: max2
929  INTEGER :: max3
930  INTEGER :: max4
931  INTEGER :: max5
932  INTEGER :: max6
933  INTEGER :: max7
934  INTEGER :: max8
935  INTEGER :: max9
936  INTEGER :: max10
937  INTEGER :: max11
938  INTEGER :: max12
939  INTEGER :: max13
940  INTEGER :: max14
941  INTEGER :: max15
942  INTEGER :: min1
943  INTEGER :: min2
944  INTEGER :: min3
945  INTEGER :: min4
946  INTEGER :: min5
947  INTEGER :: min6
948  INTEGER :: min7
949  INTEGER :: min8
950  INTEGER :: min9
951  INTEGER :: min10
952  INTEGER :: min11
953  INTEGER :: min12
954  INTEGER :: min13
955  INTEGER :: min14
956  INTEGER :: min15
957  REAL :: result1
958  REAL :: result2
959  REAL :: result3
960  edge_w => gridstruct%edge_w
961  edge_e => gridstruct%edge_e
962  edge_s => gridstruct%edge_s
963  edge_n => gridstruct%edge_n
964  grid => gridstruct%grid
965  agrid => gridstruct%agrid
966  dxa => gridstruct%dxa
967  dya => gridstruct%dya
968  IF (gridstruct%grid_type .LT. 3) THEN
969  IF (1 .LT. is - 1) THEN
970  is1 = is - 1
971  ELSE
972  is1 = 1
973  END IF
974  IF (1 .LT. js - 1) THEN
975  js1 = js - 1
976  ELSE
977  js1 = 1
978  END IF
979  IF (2 .LT. is) THEN
980  is2 = is
981  ELSE
982  is2 = 2
983  END IF
984  IF (2 .LT. js) THEN
985  js2 = js
986  ELSE
987  js2 = 2
988  END IF
989  IF (npx - 1 .GT. ie + 1) THEN
990  ie1 = ie + 1
991  ELSE
992  ie1 = npx - 1
993  END IF
994  IF (npy - 1 .GT. je + 1) THEN
995  je1 = je + 1
996  ELSE
997  je1 = npy - 1
998  END IF
999 ! Corners:
1000 ! 3-way extrapolation
1001  IF (gridstruct%nested) THEN
1002  DO j=js-2,je+2
1003  DO i=is,ie+1
1004  qx(i, j) = b2*(qin(i-2, j)+qin(i+1, j)) + b1*(qin(i-1, j)+&
1005 & qin(i, j))
1006  END DO
1007  END DO
1008  ELSE
1009  IF (gridstruct%sw_corner) THEN
1010  p0(1:2) = grid(1, 1, 1:2)
1011  result1 = extrap_corner(p0, agrid(1, 1, 1:2), agrid(2, 2, 1:2)&
1012 & , qin(1, 1), qin(2, 2))
1013  result2 = extrap_corner(p0, agrid(0, 1, 1:2), agrid(-1, 2, 1:2&
1014 & ), qin(0, 1), qin(-1, 2))
1015  result3 = extrap_corner(p0, agrid(1, 0, 1:2), agrid(2, -1, 1:2&
1016 & ), qin(1, 0), qin(2, -1))
1017  qout(1, 1) = (result1+result2+result3)*r3
1018  END IF
1019  IF (gridstruct%se_corner) THEN
1020  p0(1:2) = grid(npx, 1, 1:2)
1021  result1 = extrap_corner(p0, agrid(npx-1, 1, 1:2), agrid(npx-2&
1022 & , 2, 1:2), qin(npx-1, 1), qin(npx-2, 2))
1023  result2 = extrap_corner(p0, agrid(npx-1, 0, 1:2), agrid(npx-2&
1024 & , -1, 1:2), qin(npx-1, 0), qin(npx-2, -1))
1025  result3 = extrap_corner(p0, agrid(npx, 1, 1:2), agrid(npx+1, 2&
1026 & , 1:2), qin(npx, 1), qin(npx+1, 2))
1027  qout(npx, 1) = (result1+result2+result3)*r3
1028  END IF
1029  IF (gridstruct%ne_corner) THEN
1030  p0(1:2) = grid(npx, npy, 1:2)
1031  result1 = extrap_corner(p0, agrid(npx-1, npy-1, 1:2), agrid(&
1032 & npx-2, npy-2, 1:2), qin(npx-1, npy-1), qin(npx-2, npy-2))
1033  result2 = extrap_corner(p0, agrid(npx, npy-1, 1:2), agrid(npx+&
1034 & 1, npy-2, 1:2), qin(npx, npy-1), qin(npx+1, npy-2))
1035  result3 = extrap_corner(p0, agrid(npx-1, npy, 1:2), agrid(npx-&
1036 & 2, npy+1, 1:2), qin(npx-1, npy), qin(npx-2, npy+1))
1037  qout(npx, npy) = (result1+result2+result3)*r3
1038  END IF
1039  IF (gridstruct%nw_corner) THEN
1040  p0(1:2) = grid(1, npy, 1:2)
1041  result1 = extrap_corner(p0, agrid(1, npy-1, 1:2), agrid(2, npy&
1042 & -2, 1:2), qin(1, npy-1), qin(2, npy-2))
1043  result2 = extrap_corner(p0, agrid(0, npy-1, 1:2), agrid(-1, &
1044 & npy-2, 1:2), qin(0, npy-1), qin(-1, npy-2))
1045  result3 = extrap_corner(p0, agrid(1, npy, 1:2), agrid(2, npy+1&
1046 & , 1:2), qin(1, npy), qin(2, npy+1))
1047  qout(1, npy) = (result1+result2+result3)*r3
1048  END IF
1049  IF (1 .LT. js - 2) THEN
1050  max1 = js - 2
1051  ELSE
1052  max1 = 1
1053  END IF
1054  IF (npy - 1 .GT. je + 2) THEN
1055  min1 = je + 2
1056  ELSE
1057  min1 = npy - 1
1058  END IF
1059 !------------
1060 ! X-Interior:
1061 !------------
1062  DO j=max1,min1
1063  IF (3 .LT. is) THEN
1064  max2 = is
1065  ELSE
1066  max2 = 3
1067  END IF
1068  IF (npx - 2 .GT. ie + 1) THEN
1069  min2 = ie + 1
1070  ELSE
1071  min2 = npx - 2
1072  END IF
1073  DO i=max2,min2
1074  qx(i, j) = b2*(qin(i-2, j)+qin(i+1, j)) + b1*(qin(i-1, j)+&
1075 & qin(i, j))
1076  END DO
1077  END DO
1078 ! *** West Edges:
1079  IF (is .EQ. 1) THEN
1080  DO j=js1,je1
1081  q2(j) = (qin(0, j)*dxa(1, j)+qin(1, j)*dxa(0, j))/(dxa(0, j)&
1082 & +dxa(1, j))
1083  END DO
1084  DO j=js2,je1
1085  qout(1, j) = edge_w(j)*q2(j-1) + (1.-edge_w(j))*q2(j)
1086  END DO
1087  IF (1 .LT. js - 2) THEN
1088  max3 = js - 2
1089  ELSE
1090  max3 = 1
1091  END IF
1092  IF (npy - 1 .GT. je + 2) THEN
1093  min3 = je + 2
1094  ELSE
1095  min3 = npy - 1
1096  END IF
1097 !
1098  DO j=max3,min3
1099  g_in = dxa(2, j)/dxa(1, j)
1100  g_ou = dxa(-1, j)/dxa(0, j)
1101  qx(1, j) = 0.5*(((2.+g_in)*qin(1, j)-qin(2, j))/(1.+g_in)+((&
1102 & 2.+g_ou)*qin(0, j)-qin(-1, j))/(1.+g_ou))
1103  qx(2, j) = (3.*(g_in*qin(1, j)+qin(2, j))-(g_in*qx(1, j)+qx(&
1104 & 3, j)))/(2.+2.*g_in)
1105  END DO
1106  END IF
1107 ! East Edges:
1108  IF (ie + 1 .EQ. npx) THEN
1109  DO j=js1,je1
1110  q2(j) = (qin(npx-1, j)*dxa(npx, j)+qin(npx, j)*dxa(npx-1, j)&
1111 & )/(dxa(npx-1, j)+dxa(npx, j))
1112  END DO
1113  DO j=js2,je1
1114  qout(npx, j) = edge_e(j)*q2(j-1) + (1.-edge_e(j))*q2(j)
1115  END DO
1116  IF (1 .LT. js - 2) THEN
1117  max4 = js - 2
1118  ELSE
1119  max4 = 1
1120  END IF
1121  IF (npy - 1 .GT. je + 2) THEN
1122  min4 = je + 2
1123  ELSE
1124  min4 = npy - 1
1125  END IF
1126 !
1127  DO j=max4,min4
1128  g_in = dxa(npx-2, j)/dxa(npx-1, j)
1129  g_ou = dxa(npx+1, j)/dxa(npx, j)
1130  qx(npx, j) = 0.5*(((2.+g_in)*qin(npx-1, j)-qin(npx-2, j))/(&
1131 & 1.+g_in)+((2.+g_ou)*qin(npx, j)-qin(npx+1, j))/(1.+g_ou))
1132  qx(npx-1, j) = (3.*(qin(npx-2, j)+g_in*qin(npx-1, j))-(g_in*&
1133 & qx(npx, j)+qx(npx-2, j)))/(2.+2.*g_in)
1134  END DO
1135  END IF
1136  END IF
1137 !------------
1138 ! Y-Interior:
1139 !------------
1140  IF (gridstruct%nested) THEN
1141  DO j=js,je+1
1142  DO i=is-2,ie+2
1143  qy(i, j) = b2*(qin(i, j-2)+qin(i, j+1)) + b1*(qin(i, j-1)+&
1144 & qin(i, j))
1145  END DO
1146  END DO
1147  ELSE
1148  IF (3 .LT. js) THEN
1149  max5 = js
1150  ELSE
1151  max5 = 3
1152  END IF
1153  IF (npy - 2 .GT. je + 1) THEN
1154  min5 = je + 1
1155  ELSE
1156  min5 = npy - 2
1157  END IF
1158  DO j=max5,min5
1159  IF (1 .LT. is - 2) THEN
1160  max6 = is - 2
1161  ELSE
1162  max6 = 1
1163  END IF
1164  IF (npx - 1 .GT. ie + 2) THEN
1165  min6 = ie + 2
1166  ELSE
1167  min6 = npx - 1
1168  END IF
1169  DO i=max6,min6
1170  qy(i, j) = b2*(qin(i, j-2)+qin(i, j+1)) + b1*(qin(i, j-1)+&
1171 & qin(i, j))
1172  END DO
1173  END DO
1174 ! South Edges:
1175  IF (js .EQ. 1) THEN
1176  DO i=is1,ie1
1177  q1(i) = (qin(i, 0)*dya(i, 1)+qin(i, 1)*dya(i, 0))/(dya(i, 0)&
1178 & +dya(i, 1))
1179  END DO
1180  DO i=is2,ie1
1181  qout(i, 1) = edge_s(i)*q1(i-1) + (1.-edge_s(i))*q1(i)
1182  END DO
1183  IF (1 .LT. is - 2) THEN
1184  max7 = is - 2
1185  ELSE
1186  max7 = 1
1187  END IF
1188  IF (npx - 1 .GT. ie + 2) THEN
1189  min7 = ie + 2
1190  ELSE
1191  min7 = npx - 1
1192  END IF
1193 !
1194  DO i=max7,min7
1195  g_in = dya(i, 2)/dya(i, 1)
1196  g_ou = dya(i, -1)/dya(i, 0)
1197  qy(i, 1) = 0.5*(((2.+g_in)*qin(i, 1)-qin(i, 2))/(1.+g_in)+((&
1198 & 2.+g_ou)*qin(i, 0)-qin(i, -1))/(1.+g_ou))
1199  qy(i, 2) = (3.*(g_in*qin(i, 1)+qin(i, 2))-(g_in*qy(i, 1)+qy(&
1200 & i, 3)))/(2.+2.*g_in)
1201  END DO
1202  END IF
1203 ! North Edges:
1204  IF (je + 1 .EQ. npy) THEN
1205  DO i=is1,ie1
1206  q1(i) = (qin(i, npy-1)*dya(i, npy)+qin(i, npy)*dya(i, npy-1)&
1207 & )/(dya(i, npy-1)+dya(i, npy))
1208  END DO
1209  DO i=is2,ie1
1210  qout(i, npy) = edge_n(i)*q1(i-1) + (1.-edge_n(i))*q1(i)
1211  END DO
1212  IF (1 .LT. is - 2) THEN
1213  max8 = is - 2
1214  ELSE
1215  max8 = 1
1216  END IF
1217  IF (npx - 1 .GT. ie + 2) THEN
1218  min8 = ie + 2
1219  ELSE
1220  min8 = npx - 1
1221  END IF
1222 !
1223  DO i=max8,min8
1224  g_in = dya(i, npy-2)/dya(i, npy-1)
1225  g_ou = dya(i, npy+1)/dya(i, npy)
1226  qy(i, npy) = 0.5*(((2.+g_in)*qin(i, npy-1)-qin(i, npy-2))/(&
1227 & 1.+g_in)+((2.+g_ou)*qin(i, npy)-qin(i, npy+1))/(1.+g_ou))
1228  qy(i, npy-1) = (3.*(qin(i, npy-2)+g_in*qin(i, npy-1))-(g_in*&
1229 & qy(i, npy)+qy(i, npy-2)))/(2.+2.*g_in)
1230  END DO
1231  END IF
1232  END IF
1233 !--------------------------------------
1234  IF (gridstruct%nested) THEN
1235  DO j=js,je+1
1236  DO i=is,ie+1
1237  qxx(i, j) = a2*(qx(i, j-2)+qx(i, j+1)) + a1*(qx(i, j-1)+qx(i&
1238 & , j))
1239  END DO
1240  END DO
1241  DO j=js,je+1
1242  DO i=is,ie+1
1243  qyy(i, j) = a2*(qy(i-2, j)+qy(i+1, j)) + a1*(qy(i-1, j)+qy(i&
1244 & , j))
1245  END DO
1246  DO i=is,ie+1
1247 ! averaging
1248  qout(i, j) = 0.5*(qxx(i, j)+qyy(i, j))
1249  END DO
1250  END DO
1251  ELSE
1252  IF (3 .LT. js) THEN
1253  max9 = js
1254  ELSE
1255  max9 = 3
1256  END IF
1257  IF (npy - 2 .GT. je + 1) THEN
1258  min9 = je + 1
1259  ELSE
1260  min9 = npy - 2
1261  END IF
1262  DO j=max9,min9
1263  IF (2 .LT. is) THEN
1264  max10 = is
1265  ELSE
1266  max10 = 2
1267  END IF
1268  IF (npx - 1 .GT. ie + 1) THEN
1269  min10 = ie + 1
1270  ELSE
1271  min10 = npx - 1
1272  END IF
1273  DO i=max10,min10
1274  qxx(i, j) = a2*(qx(i, j-2)+qx(i, j+1)) + a1*(qx(i, j-1)+qx(i&
1275 & , j))
1276  END DO
1277  END DO
1278  IF (js .EQ. 1) THEN
1279  IF (2 .LT. is) THEN
1280  max11 = is
1281  ELSE
1282  max11 = 2
1283  END IF
1284  IF (npx - 1 .GT. ie + 1) THEN
1285  min11 = ie + 1
1286  ELSE
1287  min11 = npx - 1
1288  END IF
1289  DO i=max11,min11
1290  qxx(i, 2) = c1*(qx(i, 1)+qx(i, 2)) + c2*(qout(i, 1)+qxx(i, 3&
1291 & ))
1292  END DO
1293  END IF
1294  IF (je + 1 .EQ. npy) THEN
1295  IF (2 .LT. is) THEN
1296  max12 = is
1297  ELSE
1298  max12 = 2
1299  END IF
1300  IF (npx - 1 .GT. ie + 1) THEN
1301  min12 = ie + 1
1302  ELSE
1303  min12 = npx - 1
1304  END IF
1305  DO i=max12,min12
1306  qxx(i, npy-1) = c1*(qx(i, npy-2)+qx(i, npy-1)) + c2*(qout(i&
1307 & , npy)+qxx(i, npy-2))
1308  END DO
1309  END IF
1310  IF (2 .LT. js) THEN
1311  max13 = js
1312  ELSE
1313  max13 = 2
1314  END IF
1315  IF (npy - 1 .GT. je + 1) THEN
1316  min13 = je + 1
1317  ELSE
1318  min13 = npy - 1
1319  END IF
1320  DO j=max13,min13
1321  IF (3 .LT. is) THEN
1322  max14 = is
1323  ELSE
1324  max14 = 3
1325  END IF
1326  IF (npx - 2 .GT. ie + 1) THEN
1327  min14 = ie + 1
1328  ELSE
1329  min14 = npx - 2
1330  END IF
1331  DO i=max14,min14
1332  qyy(i, j) = a2*(qy(i-2, j)+qy(i+1, j)) + a1*(qy(i-1, j)+qy(i&
1333 & , j))
1334  END DO
1335  IF (is .EQ. 1) qyy(2, j) = c1*(qy(1, j)+qy(2, j)) + c2*(qout(1&
1336 & , j)+qyy(3, j))
1337  IF (ie + 1 .EQ. npx) qyy(npx-1, j) = c1*(qy(npx-2, j)+qy(npx-1&
1338 & , j)) + c2*(qout(npx, j)+qyy(npx-2, j))
1339  IF (2 .LT. is) THEN
1340  max15 = is
1341  ELSE
1342  max15 = 2
1343  END IF
1344  IF (npx - 1 .GT. ie + 1) THEN
1345  min15 = ie + 1
1346  ELSE
1347  min15 = npx - 1
1348  END IF
1349  DO i=max15,min15
1350 ! averaging
1351  qout(i, j) = 0.5*(qxx(i, j)+qyy(i, j))
1352  END DO
1353  END DO
1354  END IF
1355  ELSE
1356 ! grid_type>=3
1357 !------------------------
1358 ! Doubly periodic domain:
1359 !------------------------
1360 ! X-sweep: PPM
1361  DO j=js-2,je+2
1362  DO i=is,ie+1
1363  qx(i, j) = b1*(qin(i-1, j)+qin(i, j)) + b2*(qin(i-2, j)+qin(i+&
1364 & 1, j))
1365  END DO
1366  END DO
1367 ! Y-sweep: PPM
1368  DO j=js,je+1
1369  DO i=is-2,ie+2
1370  qy(i, j) = b1*(qin(i, j-1)+qin(i, j)) + b2*(qin(i, j-2)+qin(i&
1371 & , j+1))
1372  END DO
1373  END DO
1374  DO j=js,je+1
1375  DO i=is,ie+1
1376  qout(i, j) = 0.5*(a1*(qx(i, j-1)+qx(i, j)+qy(i-1, j)+qy(i, j))&
1377 & +a2*(qx(i, j-2)+qx(i, j+1)+qy(i-2, j)+qy(i+1, j)))
1378  END DO
1379  END DO
1380  END IF
1381  IF (PRESENT(replace)) THEN
1382  IF (replace) THEN
1383  DO j=js,je+1
1384  DO i=is,ie+1
1385  qin(i, j) = qout(i, j)
1386  END DO
1387  END DO
1388  END IF
1389  END IF
1390  END SUBROUTINE a2b_ord4
1391 ! Differentiation of a2b_ord4 in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_
1392 !mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core
1393 !_mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.
1394 !mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleig
1395 !h_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_or
1396 !d4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.r
1397 !emap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d
1398 !fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters
1399 ! fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_
1400 !restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgr
1401 !id_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils
1402 !_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_m
1403 !od.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mo
1404 !d.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d
1405 !2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v
1406 !_fb sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core
1407 !_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_util
1408 !s_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
1409 ! gradient of useful results: qin qout
1410 ! with respect to varying inputs: qin qout
1411  SUBROUTINE a2b_ord4_fwd(qin, qout, gridstruct, npx, npy, is, ie, js&
1412 & , je, ng, replace)
1413  !USE ISO_C_BINDING
1414  !USE ADMM_TAPENADE_INTERFACE
1415  IMPLICIT NONE
1416  INTEGER, INTENT(IN) :: npx, npy, is, ie, js, je, ng
1417 ! A-grid field
1418  REAL, INTENT(INOUT) :: qin(is-ng:ie+ng, js-ng:je+ng)
1419 ! Output B-grid field
1420  REAL, INTENT(INOUT) :: qout(is-ng:ie+ng, js-ng:je+ng)
1421  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
1422  LOGICAL, OPTIONAL, INTENT(IN) :: replace
1423 ! local: compact 4-pt cubic
1424  REAL, PARAMETER :: c1=2./3.
1425  REAL, PARAMETER :: c2=-(1./6.)
1426 ! Parabolic spline
1427 ! real, parameter:: c1 = 0.75
1428 ! real, parameter:: c2 = -0.25
1429  REAL :: qx(is:ie+1, js-ng:je+ng)
1430  REAL :: qy(is-ng:ie+ng, js:je+1)
1431  REAL :: qxx(is-ng:ie+ng, js-ng:je+ng)
1432  REAL :: qyy(is-ng:ie+ng, js-ng:je+ng)
1433  REAL :: g_in, g_ou
1434  REAL :: p0(2)
1435  REAL :: q1(is-1:ie+1), q2(js-1:je+1)
1436  INTEGER :: i, j, is1, js1, is2, js2, ie1, je1
1437  REAL, DIMENSION(:, :, :), POINTER :: grid, agrid
1438  REAL, DIMENSION(:, :), POINTER :: dxa, dya
1439  REAL(kind=r_grid), DIMENSION(:), POINTER :: edge_w, edge_e, edge_s, &
1440 & edge_n
1441  INTRINSIC max
1442  INTRINSIC min
1443  INTRINSIC PRESENT
1444  INTEGER :: max1
1445  INTEGER :: max2
1446  INTEGER :: max3
1447  INTEGER :: max4
1448  INTEGER :: max5
1449  INTEGER :: max6
1450  INTEGER :: max7
1451  INTEGER :: max8
1452  INTEGER :: max9
1453  INTEGER :: max10
1454  INTEGER :: max11
1455  INTEGER :: max12
1456  INTEGER :: max13
1457  INTEGER :: max14
1458  INTEGER :: max15
1459  INTEGER :: min1
1460  INTEGER :: min2
1461  INTEGER :: min3
1462  INTEGER :: min4
1463  INTEGER :: min5
1464  INTEGER :: min6
1465  INTEGER :: min7
1466  INTEGER :: min8
1467  INTEGER :: min9
1468  INTEGER :: min10
1469  INTEGER :: min11
1470  INTEGER :: min12
1471  INTEGER :: min13
1472  INTEGER :: min14
1473  INTEGER :: min15
1474  REAL :: result1
1475  REAL :: result2
1476  REAL :: result3
1477  INTEGER :: ad_from
1478  INTEGER :: ad_from0
1479  INTEGER :: ad_from1
1480  INTEGER :: ad_from2
1481  INTEGER :: ad_from3
1482 
1483  qx = 0.0
1484  qy = 0.0
1485  qxx = 0.0
1486  qyy = 0.0
1487  g_in = 0.0
1488  g_ou = 0.0
1489  p0 = 0.0
1490  q1 = 0.0
1491  q2 = 0.0
1492  result1 = 0.0
1493  result2 = 0.0
1494  result3 = 0.0
1495  i = 0
1496  j = 0
1497  is1 = 0
1498  js1 = 0
1499  is2 = 0
1500  js2 = 0
1501  ie1 = 0
1502  je1 = 0
1503  max1 = 0
1504  max2 = 0
1505  max3 = 0
1506  max4 = 0
1507  max5 = 0
1508  max6 = 0
1509  max7 = 0
1510  max8 = 0
1511  max9 = 0
1512  max10 = 0
1513  max11 = 0
1514  max12 = 0
1515  max13 = 0
1516  max14 = 0
1517  max15 = 0
1518  min1 = 0
1519  min2 = 0
1520  min3 = 0
1521  min4 = 0
1522  min5 = 0
1523  min6 = 0
1524  min7 = 0
1525  min8 = 0
1526  min9 = 0
1527  min10 = 0
1528  min11 = 0
1529  min12 = 0
1530  min13 = 0
1531  min14 = 0
1532  min15 = 0
1533  ad_from = 0
1534  ad_from0 = 0
1535  ad_from1 = 0
1536  ad_from2 = 0
1537  ad_from3 = 0
1538 
1539  edge_w => gridstruct%edge_w
1540  edge_e => gridstruct%edge_e
1541  edge_s => gridstruct%edge_s
1542  edge_n => gridstruct%edge_n
1543  grid => gridstruct%grid
1544  agrid => gridstruct%agrid
1545  dxa => gridstruct%dxa
1546  dya => gridstruct%dya
1547  IF (gridstruct%grid_type .LT. 3) THEN
1548  IF (1 .LT. is - 1) THEN
1549  is1 = is - 1
1550  ELSE
1551  is1 = 1
1552  END IF
1553  IF (1 .LT. js - 1) THEN
1554  js1 = js - 1
1555  ELSE
1556  js1 = 1
1557  END IF
1558  IF (2 .LT. is) THEN
1559  is2 = is
1560  ELSE
1561  is2 = 2
1562  END IF
1563  IF (2 .LT. js) THEN
1564  js2 = js
1565  ELSE
1566  js2 = 2
1567  END IF
1568  IF (npx - 1 .GT. ie + 1) THEN
1569  ie1 = ie + 1
1570  ELSE
1571  ie1 = npx - 1
1572  END IF
1573  IF (npy - 1 .GT. je + 1) THEN
1574  je1 = je + 1
1575  ELSE
1576  je1 = npy - 1
1577  END IF
1578 ! Corners:
1579 ! 3-way extrapolation
1580  IF (gridstruct%nested) THEN
1581  DO j=js-2,je+2
1582  DO i=is,ie+1
1583  qx(i, j) = b2*(qin(i-2, j)+qin(i+1, j)) + b1*(qin(i-1, j)+&
1584 & qin(i, j))
1585  END DO
1586  END DO
1587  CALL pushcontrol(2,0)
1588  ELSE
1589  IF (gridstruct%sw_corner) THEN
1590  p0(1:2) = grid(1, 1, 1:2)
1591  result1 = extrap_corner_fwd(p0, agrid(1, 1, 1:2), agrid(2, &
1592 & 2, 1:2), qin(1, 1), qin(2, 2))
1593  result2 = extrap_corner_fwd(p0, agrid(0, 1, 1:2), agrid(-1&
1594 & , 2, 1:2), qin(0, 1), qin(-1, 2))
1595  result3 = extrap_corner_fwd(p0, agrid(1, 0, 1:2), agrid(2, &
1596 & -1, 1:2), qin(1, 0), qin(2, -1))
1597  CALL pushrealarray(qout(1, 1))
1598  qout(1, 1) = (result1+result2+result3)*r3
1599  CALL pushcontrol(1,0)
1600  ELSE
1601  CALL pushcontrol(1,1)
1602  END IF
1603  IF (gridstruct%se_corner) THEN
1604  p0(1:2) = grid(npx, 1, 1:2)
1605  result1 = extrap_corner_fwd(p0, agrid(npx-1, 1, 1:2), agrid&
1606 & (npx-2, 2, 1:2), qin(npx-1, 1), qin(npx-2, 2))
1607  result2 = extrap_corner_fwd(p0, agrid(npx-1, 0, 1:2), agrid&
1608 & (npx-2, -1, 1:2), qin(npx-1, 0), qin(npx-2, -1))
1609  result3 = extrap_corner_fwd(p0, agrid(npx, 1, 1:2), agrid(&
1610 & npx+1, 2, 1:2), qin(npx, 1), qin(npx+1, 2))
1611  CALL pushrealarray(qout(npx, 1))
1612  qout(npx, 1) = (result1+result2+result3)*r3
1613  CALL pushcontrol(1,0)
1614  ELSE
1615  CALL pushcontrol(1,1)
1616  END IF
1617  IF (gridstruct%ne_corner) THEN
1618  p0(1:2) = grid(npx, npy, 1:2)
1619  result1 = extrap_corner_fwd(p0, agrid(npx-1, npy-1, 1:2), &
1620 & agrid(npx-2, npy-2, 1:2), qin(npx-1, npy-1), qin(npx-2, npy-&
1621 & 2))
1622  result2 = extrap_corner_fwd(p0, agrid(npx, npy-1, 1:2), &
1623 & agrid(npx+1, npy-2, 1:2), qin(npx, npy-1), qin(npx+1, npy-2)&
1624 & )
1625  result3 = extrap_corner_fwd(p0, agrid(npx-1, npy, 1:2), &
1626 & agrid(npx-2, npy+1, 1:2), qin(npx-1, npy), qin(npx-2, npy+1)&
1627 & )
1628  CALL pushrealarray(qout(npx, npy))
1629  qout(npx, npy) = (result1+result2+result3)*r3
1630  CALL pushcontrol(1,0)
1631  ELSE
1632  CALL pushcontrol(1,1)
1633  END IF
1634  IF (gridstruct%nw_corner) THEN
1635  p0(1:2) = grid(1, npy, 1:2)
1636  result1 = extrap_corner_fwd(p0, agrid(1, npy-1, 1:2), agrid&
1637 & (2, npy-2, 1:2), qin(1, npy-1), qin(2, npy-2))
1638  result2 = extrap_corner_fwd(p0, agrid(0, npy-1, 1:2), agrid&
1639 & (-1, npy-2, 1:2), qin(0, npy-1), qin(-1, npy-2))
1640  result3 = extrap_corner_fwd(p0, agrid(1, npy, 1:2), agrid(2&
1641 & , npy+1, 1:2), qin(1, npy), qin(2, npy+1))
1642  CALL pushrealarray(qout(1, npy))
1643  qout(1, npy) = (result1+result2+result3)*r3
1644  CALL pushcontrol(1,1)
1645  ELSE
1646  CALL pushcontrol(1,0)
1647  END IF
1648  IF (1 .LT. js - 2) THEN
1649  max1 = js - 2
1650  ELSE
1651  max1 = 1
1652  END IF
1653  IF (npy - 1 .GT. je + 2) THEN
1654  min1 = je + 2
1655  ELSE
1656  min1 = npy - 1
1657  END IF
1658 !------------
1659 ! X-Interior:
1660 !------------
1661  DO j=max1,min1
1662  IF (3 .LT. is) THEN
1663  max2 = is
1664  ELSE
1665  max2 = 3
1666  END IF
1667  IF (npx - 2 .GT. ie + 1) THEN
1668  min2 = ie + 1
1669  ELSE
1670  min2 = npx - 2
1671  END IF
1672  ad_from = max2
1673  DO i=ad_from,min2
1674  qx(i, j) = b2*(qin(i-2, j)+qin(i+1, j)) + b1*(qin(i-1, j)+&
1675 & qin(i, j))
1676  END DO
1677  CALL pushinteger(i - 1)
1678  CALL pushinteger(ad_from)
1679  END DO
1680 ! *** West Edges:
1681  IF (is .EQ. 1) THEN
1682  DO j=js1,je1
1683  q2(j) = (qin(0, j)*dxa(1, j)+qin(1, j)*dxa(0, j))/(dxa(0, j)&
1684 & +dxa(1, j))
1685  END DO
1686  DO j=js2,je1
1687  CALL pushrealarray(qout(1, j))
1688  qout(1, j) = edge_w(j)*q2(j-1) + (1.-edge_w(j))*q2(j)
1689  END DO
1690  IF (1 .LT. js - 2) THEN
1691  max3 = js - 2
1692  ELSE
1693  max3 = 1
1694  END IF
1695  IF (npy - 1 .GT. je + 2) THEN
1696  min3 = je + 2
1697  ELSE
1698  min3 = npy - 1
1699  END IF
1700 !
1701  DO j=max3,min3
1702  g_in = dxa(2, j)/dxa(1, j)
1703  g_ou = dxa(-1, j)/dxa(0, j)
1704  qx(1, j) = 0.5*(((2.+g_in)*qin(1, j)-qin(2, j))/(1.+g_in)+((&
1705 & 2.+g_ou)*qin(0, j)-qin(-1, j))/(1.+g_ou))
1706  qx(2, j) = (3.*(g_in*qin(1, j)+qin(2, j))-(g_in*qx(1, j)+qx(&
1707 & 3, j)))/(2.+2.*g_in)
1708  END DO
1709  CALL pushcontrol(1,0)
1710  ELSE
1711  CALL pushcontrol(1,1)
1712  END IF
1713 ! East Edges:
1714  IF (ie + 1 .EQ. npx) THEN
1715  DO j=js1,je1
1716  q2(j) = (qin(npx-1, j)*dxa(npx, j)+qin(npx, j)*dxa(npx-1, j)&
1717 & )/(dxa(npx-1, j)+dxa(npx, j))
1718  END DO
1719  DO j=js2,je1
1720  CALL pushrealarray(qout(npx, j))
1721  qout(npx, j) = edge_e(j)*q2(j-1) + (1.-edge_e(j))*q2(j)
1722  END DO
1723  IF (1 .LT. js - 2) THEN
1724  max4 = js - 2
1725  ELSE
1726  max4 = 1
1727  END IF
1728  IF (npy - 1 .GT. je + 2) THEN
1729  min4 = je + 2
1730  ELSE
1731  min4 = npy - 1
1732  END IF
1733 !
1734  DO j=max4,min4
1735  g_in = dxa(npx-2, j)/dxa(npx-1, j)
1736  g_ou = dxa(npx+1, j)/dxa(npx, j)
1737  qx(npx, j) = 0.5*(((2.+g_in)*qin(npx-1, j)-qin(npx-2, j))/(&
1738 & 1.+g_in)+((2.+g_ou)*qin(npx, j)-qin(npx+1, j))/(1.+g_ou))
1739  qx(npx-1, j) = (3.*(qin(npx-2, j)+g_in*qin(npx-1, j))-(g_in*&
1740 & qx(npx, j)+qx(npx-2, j)))/(2.+2.*g_in)
1741  END DO
1742  CALL pushcontrol(2,1)
1743  ELSE
1744  CALL pushcontrol(2,2)
1745  END IF
1746  END IF
1747 !------------
1748 ! Y-Interior:
1749 !------------
1750  IF (gridstruct%nested) THEN
1751  DO j=js,je+1
1752  DO i=is-2,ie+2
1753  qy(i, j) = b2*(qin(i, j-2)+qin(i, j+1)) + b1*(qin(i, j-1)+&
1754 & qin(i, j))
1755  END DO
1756  END DO
1757  CALL pushcontrol(2,0)
1758  ELSE
1759  IF (3 .LT. js) THEN
1760  max5 = js
1761  ELSE
1762  max5 = 3
1763  END IF
1764  IF (npy - 2 .GT. je + 1) THEN
1765  min5 = je + 1
1766  ELSE
1767  min5 = npy - 2
1768  END IF
1769  DO j=max5,min5
1770  IF (1 .LT. is - 2) THEN
1771  max6 = is - 2
1772  ELSE
1773  max6 = 1
1774  END IF
1775  IF (npx - 1 .GT. ie + 2) THEN
1776  min6 = ie + 2
1777  ELSE
1778  min6 = npx - 1
1779  END IF
1780  ad_from0 = max6
1781  DO i=ad_from0,min6
1782  qy(i, j) = b2*(qin(i, j-2)+qin(i, j+1)) + b1*(qin(i, j-1)+&
1783 & qin(i, j))
1784  END DO
1785  CALL pushinteger(i - 1)
1786  CALL pushinteger(ad_from0)
1787  END DO
1788 ! South Edges:
1789  IF (js .EQ. 1) THEN
1790  DO i=is1,ie1
1791  q1(i) = (qin(i, 0)*dya(i, 1)+qin(i, 1)*dya(i, 0))/(dya(i, 0)&
1792 & +dya(i, 1))
1793  END DO
1794  DO i=is2,ie1
1795  CALL pushrealarray(qout(i, 1))
1796  qout(i, 1) = edge_s(i)*q1(i-1) + (1.-edge_s(i))*q1(i)
1797  END DO
1798  IF (1 .LT. is - 2) THEN
1799  max7 = is - 2
1800  ELSE
1801  max7 = 1
1802  END IF
1803  IF (npx - 1 .GT. ie + 2) THEN
1804  min7 = ie + 2
1805  ELSE
1806  min7 = npx - 1
1807  END IF
1808 !
1809  DO i=max7,min7
1810  g_in = dya(i, 2)/dya(i, 1)
1811  g_ou = dya(i, -1)/dya(i, 0)
1812  qy(i, 1) = 0.5*(((2.+g_in)*qin(i, 1)-qin(i, 2))/(1.+g_in)+((&
1813 & 2.+g_ou)*qin(i, 0)-qin(i, -1))/(1.+g_ou))
1814  qy(i, 2) = (3.*(g_in*qin(i, 1)+qin(i, 2))-(g_in*qy(i, 1)+qy(&
1815 & i, 3)))/(2.+2.*g_in)
1816  END DO
1817  CALL pushcontrol(1,0)
1818  ELSE
1819  CALL pushcontrol(1,1)
1820  END IF
1821 ! North Edges:
1822  IF (je + 1 .EQ. npy) THEN
1823  DO i=is1,ie1
1824  q1(i) = (qin(i, npy-1)*dya(i, npy)+qin(i, npy)*dya(i, npy-1)&
1825 & )/(dya(i, npy-1)+dya(i, npy))
1826  END DO
1827  DO i=is2,ie1
1828  CALL pushrealarray(qout(i, npy))
1829  qout(i, npy) = edge_n(i)*q1(i-1) + (1.-edge_n(i))*q1(i)
1830  END DO
1831  IF (1 .LT. is - 2) THEN
1832  max8 = is - 2
1833  ELSE
1834  max8 = 1
1835  END IF
1836  IF (npx - 1 .GT. ie + 2) THEN
1837  min8 = ie + 2
1838  ELSE
1839  min8 = npx - 1
1840  END IF
1841 !
1842  DO i=max8,min8
1843  g_in = dya(i, npy-2)/dya(i, npy-1)
1844  g_ou = dya(i, npy+1)/dya(i, npy)
1845  qy(i, npy) = 0.5*(((2.+g_in)*qin(i, npy-1)-qin(i, npy-2))/(&
1846 & 1.+g_in)+((2.+g_ou)*qin(i, npy)-qin(i, npy+1))/(1.+g_ou))
1847  qy(i, npy-1) = (3.*(qin(i, npy-2)+g_in*qin(i, npy-1))-(g_in*&
1848 & qy(i, npy)+qy(i, npy-2)))/(2.+2.*g_in)
1849  END DO
1850  CALL pushcontrol(2,1)
1851  ELSE
1852  CALL pushcontrol(2,2)
1853  END IF
1854  END IF
1855 !--------------------------------------
1856  IF (gridstruct%nested) THEN
1857  DO j=js,je+1
1858  DO i=is,ie+1
1859  qxx(i, j) = a2*(qx(i, j-2)+qx(i, j+1)) + a1*(qx(i, j-1)+qx(i&
1860 & , j))
1861  END DO
1862  END DO
1863  DO j=js,je+1
1864  DO i=is,ie+1
1865  qyy(i, j) = a2*(qy(i-2, j)+qy(i+1, j)) + a1*(qy(i-1, j)+qy(i&
1866 & , j))
1867  END DO
1868  DO i=is,ie+1
1869 ! averaging
1870  CALL pushrealarray(qout(i, j))
1871  qout(i, j) = 0.5*(qxx(i, j)+qyy(i, j))
1872  END DO
1873  END DO
1874  CALL pushcontrol(2,0)
1875  ELSE
1876  IF (3 .LT. js) THEN
1877  max9 = js
1878  ELSE
1879  max9 = 3
1880  END IF
1881  IF (npy - 2 .GT. je + 1) THEN
1882  min9 = je + 1
1883  ELSE
1884  min9 = npy - 2
1885  END IF
1886  DO j=max9,min9
1887  IF (2 .LT. is) THEN
1888  max10 = is
1889  ELSE
1890  max10 = 2
1891  END IF
1892  IF (npx - 1 .GT. ie + 1) THEN
1893  min10 = ie + 1
1894  ELSE
1895  min10 = npx - 1
1896  END IF
1897  ad_from1 = max10
1898  DO i=ad_from1,min10
1899  qxx(i, j) = a2*(qx(i, j-2)+qx(i, j+1)) + a1*(qx(i, j-1)+qx(i&
1900 & , j))
1901  END DO
1902  CALL pushinteger(i - 1)
1903  CALL pushinteger(ad_from1)
1904  END DO
1905  IF (js .EQ. 1) THEN
1906  IF (2 .LT. is) THEN
1907  max11 = is
1908  ELSE
1909  max11 = 2
1910  END IF
1911  IF (npx - 1 .GT. ie + 1) THEN
1912  min11 = ie + 1
1913  ELSE
1914  min11 = npx - 1
1915  END IF
1916  DO i=max11,min11
1917  qxx(i, 2) = c1*(qx(i, 1)+qx(i, 2)) + c2*(qout(i, 1)+qxx(i, 3&
1918 & ))
1919  END DO
1920  CALL pushcontrol(1,0)
1921  ELSE
1922  CALL pushcontrol(1,1)
1923  END IF
1924  IF (je + 1 .EQ. npy) THEN
1925  IF (2 .LT. is) THEN
1926  max12 = is
1927  ELSE
1928  max12 = 2
1929  END IF
1930  IF (npx - 1 .GT. ie + 1) THEN
1931  min12 = ie + 1
1932  ELSE
1933  min12 = npx - 1
1934  END IF
1935  DO i=max12,min12
1936  qxx(i, npy-1) = c1*(qx(i, npy-2)+qx(i, npy-1)) + c2*(qout(i&
1937 & , npy)+qxx(i, npy-2))
1938  END DO
1939  CALL pushcontrol(1,1)
1940  ELSE
1941  CALL pushcontrol(1,0)
1942  END IF
1943  IF (2 .LT. js) THEN
1944  max13 = js
1945  ELSE
1946  max13 = 2
1947  END IF
1948  IF (npy - 1 .GT. je + 1) THEN
1949  min13 = je + 1
1950  ELSE
1951  min13 = npy - 1
1952  END IF
1953  DO j=max13,min13
1954  IF (3 .LT. is) THEN
1955  max14 = is
1956  ELSE
1957  max14 = 3
1958  END IF
1959  IF (npx - 2 .GT. ie + 1) THEN
1960  min14 = ie + 1
1961  ELSE
1962  min14 = npx - 2
1963  END IF
1964  ad_from2 = max14
1965  DO i=ad_from2,min14
1966  qyy(i, j) = a2*(qy(i-2, j)+qy(i+1, j)) + a1*(qy(i-1, j)+qy(i&
1967 & , j))
1968  END DO
1969  CALL pushinteger(i - 1)
1970  CALL pushinteger(ad_from2)
1971  IF (is .EQ. 1) THEN
1972  qyy(2, j) = c1*(qy(1, j)+qy(2, j)) + c2*(qout(1, j)+qyy(3, j&
1973 & ))
1974  CALL pushcontrol(1,0)
1975  ELSE
1976  CALL pushcontrol(1,1)
1977  END IF
1978  IF (ie + 1 .EQ. npx) THEN
1979  qyy(npx-1, j) = c1*(qy(npx-2, j)+qy(npx-1, j)) + c2*(qout(&
1980 & npx, j)+qyy(npx-2, j))
1981  CALL pushcontrol(1,1)
1982  ELSE
1983  CALL pushcontrol(1,0)
1984  END IF
1985  IF (2 .LT. is) THEN
1986  max15 = is
1987  ELSE
1988  max15 = 2
1989  END IF
1990  IF (npx - 1 .GT. ie + 1) THEN
1991  min15 = ie + 1
1992  ELSE
1993  min15 = npx - 1
1994  END IF
1995  ad_from3 = max15
1996  DO i=ad_from3,min15
1997 ! averaging
1998  CALL pushrealarray(qout(i, j))
1999  qout(i, j) = 0.5*(qxx(i, j)+qyy(i, j))
2000  END DO
2001  CALL pushinteger(i - 1)
2002  CALL pushinteger(ad_from3)
2003  END DO
2004  CALL pushcontrol(2,1)
2005  END IF
2006  ELSE
2007 ! grid_type>=3
2008 !------------------------
2009 ! Doubly periodic domain:
2010 !------------------------
2011 ! X-sweep: PPM
2012  DO j=js-2,je+2
2013  DO i=is,ie+1
2014  qx(i, j) = b1*(qin(i-1, j)+qin(i, j)) + b2*(qin(i-2, j)+qin(i+&
2015 & 1, j))
2016  END DO
2017  END DO
2018 ! Y-sweep: PPM
2019  DO j=js,je+1
2020  DO i=is-2,ie+2
2021  qy(i, j) = b1*(qin(i, j-1)+qin(i, j)) + b2*(qin(i, j-2)+qin(i&
2022 & , j+1))
2023  END DO
2024  END DO
2025  DO j=js,je+1
2026  DO i=is,ie+1
2027  CALL pushrealarray(qout(i, j))
2028  qout(i, j) = 0.5*(a1*(qx(i, j-1)+qx(i, j)+qy(i-1, j)+qy(i, j))&
2029 & +a2*(qx(i, j-2)+qx(i, j+1)+qy(i-2, j)+qy(i+1, j)))
2030  END DO
2031  END DO
2032  CALL pushcontrol(2,2)
2033  END IF
2034  IF (PRESENT(replace)) THEN
2035  IF (replace) THEN
2036  DO j=js,je+1
2037  DO i=is,ie+1
2038  CALL pushrealarray(qin(i, j))
2039  qin(i, j) = qout(i, j)
2040  END DO
2041  END DO
2042  CALL pushinteger(min9)
2043  CALL pushinteger(min8)
2044  CALL pushinteger(min7)
2045  CALL pushinteger(min5)
2046  CALL pushinteger(min4)
2047  CALL pushinteger(ie1)
2048  CALL pushinteger(min3)
2049  CALL pushinteger(min1)
2050  CALL pushinteger(js2)
2051  CALL pushinteger(js1)
2052  CALL pushinteger(je1)
2053  CALL pushinteger(min13)
2054  CALL pushinteger(min12)
2055  CALL pushinteger(min11)
2056  CALL pushinteger(is2)
2057  CALL pushinteger(is1)
2058  !CALL PUSHPOINTER8(C_LOC(agrid))
2059  CALL pushinteger(max9)
2060  CALL pushinteger(max8)
2061  CALL pushinteger(max7)
2062  CALL pushinteger(max5)
2063  CALL pushinteger(max4)
2064  CALL pushinteger(max3)
2065  CALL pushinteger(max13)
2066  CALL pushinteger(max1)
2067  CALL pushinteger(max12)
2068  CALL pushinteger(max11)
2069  CALL pushcontrol(2,2)
2070  ELSE
2071  CALL pushinteger(min9)
2072  CALL pushinteger(min8)
2073  CALL pushinteger(min7)
2074  CALL pushinteger(min5)
2075  CALL pushinteger(min4)
2076  CALL pushinteger(ie1)
2077  CALL pushinteger(min3)
2078  CALL pushinteger(min1)
2079  CALL pushinteger(js2)
2080  CALL pushinteger(js1)
2081  CALL pushinteger(je1)
2082  CALL pushinteger(min13)
2083  CALL pushinteger(min12)
2084  CALL pushinteger(min11)
2085  CALL pushinteger(is2)
2086  CALL pushinteger(is1)
2087  !CALL PUSHPOINTER8(C_LOC(agrid))
2088  CALL pushinteger(max9)
2089  CALL pushinteger(max8)
2090  CALL pushinteger(max7)
2091  CALL pushinteger(max5)
2092  CALL pushinteger(max4)
2093  CALL pushinteger(max3)
2094  CALL pushinteger(max13)
2095  CALL pushinteger(max1)
2096  CALL pushinteger(max12)
2097  CALL pushinteger(max11)
2098  CALL pushcontrol(2,1)
2099  END IF
2100  ELSE
2101  CALL pushinteger(min9)
2102  CALL pushinteger(min8)
2103  CALL pushinteger(min7)
2104  CALL pushinteger(min5)
2105  CALL pushinteger(min4)
2106  CALL pushinteger(ie1)
2107  CALL pushinteger(min3)
2108  CALL pushinteger(min1)
2109  CALL pushinteger(js2)
2110  CALL pushinteger(js1)
2111  CALL pushinteger(je1)
2112  CALL pushinteger(min13)
2113  CALL pushinteger(min12)
2114  CALL pushinteger(min11)
2115  CALL pushinteger(is2)
2116  CALL pushinteger(is1)
2117  !CALL PUSHPOINTER8(C_LOC(agrid))
2118  CALL pushinteger(max9)
2119  CALL pushinteger(max8)
2120  CALL pushinteger(max7)
2121  CALL pushinteger(max5)
2122  CALL pushinteger(max4)
2123  CALL pushinteger(max3)
2124  CALL pushinteger(max13)
2125  CALL pushinteger(max1)
2126  CALL pushinteger(max12)
2127  CALL pushinteger(max11)
2128  CALL pushcontrol(2,0)
2129  END IF
2130  END SUBROUTINE a2b_ord4_fwd
2131 ! Differentiation of a2b_ord4 in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge
2132 !_mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_cor
2133 !e_mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod
2134 !.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Raylei
2135 !gh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_o
2136 !rd4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.
2137 !remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d
2138 ! fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiter
2139 !s fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv
2140 !_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subg
2141 !rid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_util
2142 !s_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_
2143 !mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_m
2144 !od.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.
2145 !d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_
2146 !v_fb sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_cor
2147 !e_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_uti
2148 !ls_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
2149 ! gradient of useful results: qin qout
2150 ! with respect to varying inputs: qin qout
2151  SUBROUTINE a2b_ord4_bwd(qin, qin_ad, qout, qout_ad, gridstruct, npx&
2152 & , npy, is, ie, js, je, ng, replace)
2153  !USE ISO_C_BINDING
2154  !USE ADMM_TAPENADE_INTERFACE
2155  IMPLICIT NONE
2156  INTEGER, INTENT(IN) :: npx, npy, is, ie, js, je, ng
2157  REAL, INTENT(INOUT) :: qin(is-ng:ie+ng, js-ng:je+ng)
2158  REAL, INTENT(INOUT) :: qin_ad(is-ng:ie+ng, js-ng:je+ng)
2159  REAL, INTENT(INOUT) :: qout(is-ng:ie+ng, js-ng:je+ng)
2160  REAL, INTENT(INOUT) :: qout_ad(is-ng:ie+ng, js-ng:je+ng)
2161  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
2162  LOGICAL, OPTIONAL, INTENT(IN) :: replace
2163  REAL, PARAMETER :: c1=2./3.
2164  REAL, PARAMETER :: c2=-(1./6.)
2165  REAL :: qx(is:ie+1, js-ng:je+ng)
2166  REAL :: qx_ad(is:ie+1, js-ng:je+ng)
2167  REAL :: qy(is-ng:ie+ng, js:je+1)
2168  REAL :: qy_ad(is-ng:ie+ng, js:je+1)
2169  REAL :: qxx(is-ng:ie+ng, js-ng:je+ng)
2170  REAL :: qxx_ad(is-ng:ie+ng, js-ng:je+ng)
2171  REAL :: qyy(is-ng:ie+ng, js-ng:je+ng)
2172  REAL :: qyy_ad(is-ng:ie+ng, js-ng:je+ng)
2173  REAL :: g_in, g_ou
2174  REAL :: p0(2)
2175  REAL :: q1(is-1:ie+1), q2(js-1:je+1)
2176  REAL :: q1_ad(is-1:ie+1), q2_ad(js-1:je+1)
2177  INTEGER :: i, j, is1, js1, is2, js2, ie1, je1
2178  REAL, DIMENSION(:, :, :), POINTER :: grid, agrid
2179  REAL, DIMENSION(:, :), POINTER :: dxa, dya
2180  REAL(kind=r_grid), DIMENSION(:), POINTER :: edge_w, edge_e, edge_s, &
2181 & edge_n
2182  INTRINSIC max
2183  INTRINSIC min
2184  INTRINSIC PRESENT
2185  INTEGER :: max1
2186  INTEGER :: max2
2187  INTEGER :: max3
2188  INTEGER :: max4
2189  INTEGER :: max5
2190  INTEGER :: max6
2191  INTEGER :: max7
2192  INTEGER :: max8
2193  INTEGER :: max9
2194  INTEGER :: max10
2195  INTEGER :: max11
2196  INTEGER :: max12
2197  INTEGER :: max13
2198  INTEGER :: max14
2199  INTEGER :: max15
2200  INTEGER :: min1
2201  INTEGER :: min2
2202  INTEGER :: min3
2203  INTEGER :: min4
2204  INTEGER :: min5
2205  INTEGER :: min6
2206  INTEGER :: min7
2207  INTEGER :: min8
2208  INTEGER :: min9
2209  INTEGER :: min10
2210  INTEGER :: min11
2211  INTEGER :: min12
2212  INTEGER :: min13
2213  INTEGER :: min14
2214  INTEGER :: min15
2215  REAL :: result1
2216  REAL :: result1_ad
2217  REAL :: result2
2218  REAL :: result2_ad
2219  REAL :: result3
2220  REAL :: result3_ad
2221  REAL :: temp_ad
2222  REAL :: temp_ad0
2223  REAL :: temp_ad1
2224  REAL :: temp_ad2
2225  REAL :: temp_ad3
2226  REAL :: temp_ad4
2227  REAL :: temp_ad5
2228  REAL :: temp_ad6
2229  REAL :: temp_ad7
2230  REAL :: temp_ad8
2231  REAL :: temp_ad9
2232  REAL :: temp_ad10
2233  REAL :: temp_ad11
2234  REAL :: temp_ad12
2235  REAL :: temp_ad13
2236  REAL :: temp_ad14
2237  REAL :: temp_ad15
2238  REAL :: temp_ad16
2239  REAL :: temp_ad17
2240  REAL :: temp_ad18
2241  REAL :: temp_ad19
2242  REAL :: temp_ad20
2243  REAL :: temp_ad21
2244  REAL :: temp_ad22
2245  REAL :: temp_ad23
2246  REAL :: temp_ad24
2247  REAL :: temp_ad25
2248  INTEGER :: ad_from
2249  INTEGER :: ad_to
2250  INTEGER :: ad_from0
2251  INTEGER :: ad_to0
2252  INTEGER :: ad_from1
2253  INTEGER :: ad_to1
2254  INTEGER :: ad_from2
2255  INTEGER :: ad_to2
2256  INTEGER :: ad_from3
2257  INTEGER :: ad_to3
2258  INTEGER :: branch
2259  !TYPE(C_PTR) :: cptr
2260  !INTEGER :: unknown_shape_in_a2b_ord4
2261 
2262  qx = 0.0
2263  qy = 0.0
2264  qxx = 0.0
2265  qyy = 0.0
2266  g_in = 0.0
2267  g_ou = 0.0
2268  p0 = 0.0
2269  q1 = 0.0
2270  q2 = 0.0
2271  result1 = 0.0
2272  result2 = 0.0
2273  result3 = 0.0
2274  i = 0
2275  j = 0
2276  is1 = 0
2277  js1 = 0
2278  is2 = 0
2279  js2 = 0
2280  ie1 = 0
2281  je1 = 0
2282  max1 = 0
2283  max2 = 0
2284  max3 = 0
2285  max4 = 0
2286  max5 = 0
2287  max6 = 0
2288  max7 = 0
2289  max8 = 0
2290  max9 = 0
2291  max10 = 0
2292  max11 = 0
2293  max12 = 0
2294  max13 = 0
2295  max14 = 0
2296  max15 = 0
2297  min1 = 0
2298  min2 = 0
2299  min3 = 0
2300  min4 = 0
2301  min5 = 0
2302  min6 = 0
2303  min7 = 0
2304  min8 = 0
2305  min9 = 0
2306  min10 = 0
2307  min11 = 0
2308  min12 = 0
2309  min13 = 0
2310  min14 = 0
2311  min15 = 0
2312  ad_from = 0
2313  ad_from0 = 0
2314  ad_from1 = 0
2315  ad_from2 = 0
2316  ad_from3 = 0
2317  ad_to = 0
2318  ad_to0 = 0
2319  ad_to1 = 0
2320  ad_to2 = 0
2321  ad_to3 = 0
2322  branch = 0
2323 
2324  CALL popcontrol(2,branch)
2325  IF (branch .EQ. 0) THEN
2326  CALL popinteger(max11)
2327  CALL popinteger(max12)
2328  CALL popinteger(max1)
2329  CALL popinteger(max13)
2330  CALL popinteger(max3)
2331  CALL popinteger(max4)
2332  CALL popinteger(max5)
2333  CALL popinteger(max7)
2334  CALL popinteger(max8)
2335  CALL popinteger(max9)
2336  !CALL POPPOINTER8(cptr)
2337  agrid => gridstruct%agrid ! (/unknown_shape_in_a2b_ord4/))
2338  CALL popinteger(is1)
2339  CALL popinteger(is2)
2340  CALL popinteger(min11)
2341  CALL popinteger(min12)
2342  CALL popinteger(min13)
2343  CALL popinteger(je1)
2344  CALL popinteger(js1)
2345  CALL popinteger(js2)
2346  CALL popinteger(min1)
2347  CALL popinteger(min3)
2348  CALL popinteger(ie1)
2349  CALL popinteger(min4)
2350  CALL popinteger(min5)
2351  CALL popinteger(min7)
2352  CALL popinteger(min8)
2353  CALL popinteger(min9)
2354  ELSE IF (branch .EQ. 1) THEN
2355  CALL popinteger(max11)
2356  CALL popinteger(max12)
2357  CALL popinteger(max1)
2358  CALL popinteger(max13)
2359  CALL popinteger(max3)
2360  CALL popinteger(max4)
2361  CALL popinteger(max5)
2362  CALL popinteger(max7)
2363  CALL popinteger(max8)
2364  CALL popinteger(max9)
2365  !CALL POPPOINTER8(cptr)
2366  agrid => gridstruct%agrid ! (/unknown_shape_in_a2b_ord4/))
2367  CALL popinteger(is1)
2368  CALL popinteger(is2)
2369  CALL popinteger(min11)
2370  CALL popinteger(min12)
2371  CALL popinteger(min13)
2372  CALL popinteger(je1)
2373  CALL popinteger(js1)
2374  CALL popinteger(js2)
2375  CALL popinteger(min1)
2376  CALL popinteger(min3)
2377  CALL popinteger(ie1)
2378  CALL popinteger(min4)
2379  CALL popinteger(min5)
2380  CALL popinteger(min7)
2381  CALL popinteger(min8)
2382  CALL popinteger(min9)
2383  ELSE
2384  CALL popinteger(max11)
2385  CALL popinteger(max12)
2386  CALL popinteger(max1)
2387  CALL popinteger(max13)
2388  CALL popinteger(max3)
2389  CALL popinteger(max4)
2390  CALL popinteger(max5)
2391  CALL popinteger(max7)
2392  CALL popinteger(max8)
2393  CALL popinteger(max9)
2394  !CALL POPPOINTER8(cptr)
2395  agrid => gridstruct%agrid ! (/unknown_shape_in_a2b_ord4/))
2396  CALL popinteger(is1)
2397  CALL popinteger(is2)
2398  CALL popinteger(min11)
2399  CALL popinteger(min12)
2400  CALL popinteger(min13)
2401  CALL popinteger(je1)
2402  CALL popinteger(js1)
2403  CALL popinteger(js2)
2404  CALL popinteger(min1)
2405  CALL popinteger(min3)
2406  CALL popinteger(ie1)
2407  CALL popinteger(min4)
2408  CALL popinteger(min5)
2409  CALL popinteger(min7)
2410  CALL popinteger(min8)
2411  CALL popinteger(min9)
2412  DO j=je+1,js,-1
2413  DO i=ie+1,is,-1
2414  CALL poprealarray(qin(i, j))
2415  qout_ad(i, j) = qout_ad(i, j) + qin_ad(i, j)
2416  qin_ad(i, j) = 0.0
2417  END DO
2418  END DO
2419  END IF
2420  CALL popcontrol(2,branch)
2421  IF (branch .EQ. 0) THEN
2422  qy_ad = 0.0
2423  qxx_ad = 0.0
2424  qyy_ad = 0.0
2425  DO j=je+1,js,-1
2426  DO i=ie+1,is,-1
2427  CALL poprealarray(qout(i, j))
2428  qxx_ad(i, j) = qxx_ad(i, j) + 0.5*qout_ad(i, j)
2429  qyy_ad(i, j) = qyy_ad(i, j) + 0.5*qout_ad(i, j)
2430  qout_ad(i, j) = 0.0
2431  END DO
2432  DO i=ie+1,is,-1
2433  qy_ad(i-2, j) = qy_ad(i-2, j) + a2*qyy_ad(i, j)
2434  qy_ad(i+1, j) = qy_ad(i+1, j) + a2*qyy_ad(i, j)
2435  qy_ad(i-1, j) = qy_ad(i-1, j) + a1*qyy_ad(i, j)
2436  qy_ad(i, j) = qy_ad(i, j) + a1*qyy_ad(i, j)
2437  qyy_ad(i, j) = 0.0
2438  END DO
2439  END DO
2440  qx_ad = 0.0
2441  DO j=je+1,js,-1
2442  DO i=ie+1,is,-1
2443  qx_ad(i, j-2) = qx_ad(i, j-2) + a2*qxx_ad(i, j)
2444  qx_ad(i, j+1) = qx_ad(i, j+1) + a2*qxx_ad(i, j)
2445  qx_ad(i, j-1) = qx_ad(i, j-1) + a1*qxx_ad(i, j)
2446  qx_ad(i, j) = qx_ad(i, j) + a1*qxx_ad(i, j)
2447  qxx_ad(i, j) = 0.0
2448  END DO
2449  END DO
2450  ELSE IF (branch .EQ. 1) THEN
2451  qy_ad = 0.0
2452  qxx_ad = 0.0
2453  qyy_ad = 0.0
2454  DO j=min13,max13,-1
2455  CALL popinteger(ad_from3)
2456  CALL popinteger(ad_to3)
2457  DO i=ad_to3,ad_from3,-1
2458  CALL poprealarray(qout(i, j))
2459  qxx_ad(i, j) = qxx_ad(i, j) + 0.5*qout_ad(i, j)
2460  qyy_ad(i, j) = qyy_ad(i, j) + 0.5*qout_ad(i, j)
2461  qout_ad(i, j) = 0.0
2462  END DO
2463  CALL popcontrol(1,branch)
2464  IF (branch .NE. 0) THEN
2465  qy_ad(npx-2, j) = qy_ad(npx-2, j) + c1*qyy_ad(npx-1, j)
2466  qy_ad(npx-1, j) = qy_ad(npx-1, j) + c1*qyy_ad(npx-1, j)
2467  qout_ad(npx, j) = qout_ad(npx, j) + c2*qyy_ad(npx-1, j)
2468  qyy_ad(npx-2, j) = qyy_ad(npx-2, j) + c2*qyy_ad(npx-1, j)
2469  qyy_ad(npx-1, j) = 0.0
2470  END IF
2471  CALL popcontrol(1,branch)
2472  IF (branch .EQ. 0) THEN
2473  qy_ad(1, j) = qy_ad(1, j) + c1*qyy_ad(2, j)
2474  qy_ad(2, j) = qy_ad(2, j) + c1*qyy_ad(2, j)
2475  qout_ad(1, j) = qout_ad(1, j) + c2*qyy_ad(2, j)
2476  qyy_ad(3, j) = qyy_ad(3, j) + c2*qyy_ad(2, j)
2477  qyy_ad(2, j) = 0.0
2478  END IF
2479  CALL popinteger(ad_from2)
2480  CALL popinteger(ad_to2)
2481  DO i=ad_to2,ad_from2,-1
2482  qy_ad(i-2, j) = qy_ad(i-2, j) + a2*qyy_ad(i, j)
2483  qy_ad(i+1, j) = qy_ad(i+1, j) + a2*qyy_ad(i, j)
2484  qy_ad(i-1, j) = qy_ad(i-1, j) + a1*qyy_ad(i, j)
2485  qy_ad(i, j) = qy_ad(i, j) + a1*qyy_ad(i, j)
2486  qyy_ad(i, j) = 0.0
2487  END DO
2488  END DO
2489  CALL popcontrol(1,branch)
2490  IF (branch .EQ. 0) THEN
2491  qx_ad = 0.0
2492  ELSE
2493  qx_ad = 0.0
2494  DO i=min12,max12,-1
2495  qx_ad(i, npy-2) = qx_ad(i, npy-2) + c1*qxx_ad(i, npy-1)
2496  qx_ad(i, npy-1) = qx_ad(i, npy-1) + c1*qxx_ad(i, npy-1)
2497  qout_ad(i, npy) = qout_ad(i, npy) + c2*qxx_ad(i, npy-1)
2498  qxx_ad(i, npy-2) = qxx_ad(i, npy-2) + c2*qxx_ad(i, npy-1)
2499  qxx_ad(i, npy-1) = 0.0
2500  END DO
2501  END IF
2502  CALL popcontrol(1,branch)
2503  IF (branch .EQ. 0) THEN
2504  DO i=min11,max11,-1
2505  qx_ad(i, 1) = qx_ad(i, 1) + c1*qxx_ad(i, 2)
2506  qx_ad(i, 2) = qx_ad(i, 2) + c1*qxx_ad(i, 2)
2507  qout_ad(i, 1) = qout_ad(i, 1) + c2*qxx_ad(i, 2)
2508  qxx_ad(i, 3) = qxx_ad(i, 3) + c2*qxx_ad(i, 2)
2509  qxx_ad(i, 2) = 0.0
2510  END DO
2511  END IF
2512  DO j=min9,max9,-1
2513  CALL popinteger(ad_from1)
2514  CALL popinteger(ad_to1)
2515  DO i=ad_to1,ad_from1,-1
2516  qx_ad(i, j-2) = qx_ad(i, j-2) + a2*qxx_ad(i, j)
2517  qx_ad(i, j+1) = qx_ad(i, j+1) + a2*qxx_ad(i, j)
2518  qx_ad(i, j-1) = qx_ad(i, j-1) + a1*qxx_ad(i, j)
2519  qx_ad(i, j) = qx_ad(i, j) + a1*qxx_ad(i, j)
2520  qxx_ad(i, j) = 0.0
2521  END DO
2522  END DO
2523  ELSE
2524  qx_ad = 0.0
2525  qy_ad = 0.0
2526  DO j=je+1,js,-1
2527  DO i=ie+1,is,-1
2528  CALL poprealarray(qout(i, j))
2529  temp_ad23 = 0.5*qout_ad(i, j)
2530  temp_ad24 = a1*temp_ad23
2531  temp_ad25 = a2*temp_ad23
2532  qx_ad(i, j-1) = qx_ad(i, j-1) + temp_ad24
2533  qx_ad(i, j) = qx_ad(i, j) + temp_ad24
2534  qy_ad(i-1, j) = qy_ad(i-1, j) + temp_ad24
2535  qy_ad(i, j) = qy_ad(i, j) + temp_ad24
2536  qx_ad(i, j-2) = qx_ad(i, j-2) + temp_ad25
2537  qx_ad(i, j+1) = qx_ad(i, j+1) + temp_ad25
2538  qy_ad(i-2, j) = qy_ad(i-2, j) + temp_ad25
2539  qy_ad(i+1, j) = qy_ad(i+1, j) + temp_ad25
2540  qout_ad(i, j) = 0.0
2541  END DO
2542  END DO
2543  DO j=je+1,js,-1
2544  DO i=ie+2,is-2,-1
2545  qin_ad(i, j-1) = qin_ad(i, j-1) + b1*qy_ad(i, j)
2546  qin_ad(i, j) = qin_ad(i, j) + b1*qy_ad(i, j)
2547  qin_ad(i, j-2) = qin_ad(i, j-2) + b2*qy_ad(i, j)
2548  qin_ad(i, j+1) = qin_ad(i, j+1) + b2*qy_ad(i, j)
2549  qy_ad(i, j) = 0.0
2550  END DO
2551  END DO
2552  DO j=je+2,js-2,-1
2553  DO i=ie+1,is,-1
2554  qin_ad(i-1, j) = qin_ad(i-1, j) + b1*qx_ad(i, j)
2555  qin_ad(i, j) = qin_ad(i, j) + b1*qx_ad(i, j)
2556  qin_ad(i-2, j) = qin_ad(i-2, j) + b2*qx_ad(i, j)
2557  qin_ad(i+1, j) = qin_ad(i+1, j) + b2*qx_ad(i, j)
2558  qx_ad(i, j) = 0.0
2559  END DO
2560  END DO
2561  GOTO 100
2562  END IF
2563  dya => gridstruct%dya
2564  CALL popcontrol(2,branch)
2565  IF (branch .EQ. 0) THEN
2566  DO j=je+1,js,-1
2567  DO i=ie+2,is-2,-1
2568  qin_ad(i, j-2) = qin_ad(i, j-2) + b2*qy_ad(i, j)
2569  qin_ad(i, j+1) = qin_ad(i, j+1) + b2*qy_ad(i, j)
2570  qin_ad(i, j-1) = qin_ad(i, j-1) + b1*qy_ad(i, j)
2571  qin_ad(i, j) = qin_ad(i, j) + b1*qy_ad(i, j)
2572  qy_ad(i, j) = 0.0
2573  END DO
2574  END DO
2575  ELSE
2576  IF (branch .EQ. 1) THEN
2577  DO i=min8,max8,-1
2578  g_in = dya(i, npy-2)/dya(i, npy-1)
2579  temp_ad19 = qy_ad(i, npy-1)/(g_in*2.+2.)
2580  qin_ad(i, npy-2) = qin_ad(i, npy-2) + 3.*temp_ad19
2581  qy_ad(i, npy) = qy_ad(i, npy) - g_in*temp_ad19
2582  qy_ad(i, npy-2) = qy_ad(i, npy-2) - temp_ad19
2583  qy_ad(i, npy-1) = 0.0
2584  g_ou = dya(i, npy+1)/dya(i, npy)
2585  temp_ad21 = 0.5*qy_ad(i, npy)
2586  temp_ad20 = temp_ad21/(g_in+1.)
2587  qin_ad(i, npy-1) = qin_ad(i, npy-1) + (g_in+2.)*temp_ad20 + 3.&
2588 & *g_in*temp_ad19
2589  temp_ad22 = temp_ad21/(g_ou+1.)
2590  qin_ad(i, npy-2) = qin_ad(i, npy-2) - temp_ad20
2591  qin_ad(i, npy) = qin_ad(i, npy) + (g_ou+2.)*temp_ad22
2592  qin_ad(i, npy+1) = qin_ad(i, npy+1) - temp_ad22
2593  qy_ad(i, npy) = 0.0
2594  END DO
2595  edge_n => gridstruct%edge_n
2596  q1_ad = 0.0
2597  DO i=ie1,is2,-1
2598  CALL poprealarray(qout(i, npy))
2599  q1_ad(i-1) = q1_ad(i-1) + edge_n(i)*qout_ad(i, npy)
2600  q1_ad(i) = q1_ad(i) + (1.-edge_n(i))*qout_ad(i, npy)
2601  qout_ad(i, npy) = 0.0
2602  END DO
2603  DO i=ie1,is1,-1
2604  temp_ad18 = q1_ad(i)/(dya(i, npy-1)+dya(i, npy))
2605  qin_ad(i, npy-1) = qin_ad(i, npy-1) + dya(i, npy)*temp_ad18
2606  qin_ad(i, npy) = qin_ad(i, npy) + dya(i, npy-1)*temp_ad18
2607  q1_ad(i) = 0.0
2608  END DO
2609  ELSE
2610  q1_ad = 0.0
2611  END IF
2612  CALL popcontrol(1,branch)
2613  IF (branch .EQ. 0) THEN
2614  DO i=min7,max7,-1
2615  g_in = dya(i, 2)/dya(i, 1)
2616  temp_ad14 = qy_ad(i, 2)/(g_in*2.+2.)
2617  qin_ad(i, 1) = qin_ad(i, 1) + 3.*g_in*temp_ad14
2618  qin_ad(i, 2) = qin_ad(i, 2) + 3.*temp_ad14
2619  qy_ad(i, 1) = qy_ad(i, 1) - g_in*temp_ad14
2620  qy_ad(i, 3) = qy_ad(i, 3) - temp_ad14
2621  qy_ad(i, 2) = 0.0
2622  g_ou = dya(i, -1)/dya(i, 0)
2623  temp_ad15 = 0.5*qy_ad(i, 1)
2624  temp_ad16 = temp_ad15/(g_in+1.)
2625  temp_ad17 = temp_ad15/(g_ou+1.)
2626  qin_ad(i, 1) = qin_ad(i, 1) + (g_in+2.)*temp_ad16
2627  qin_ad(i, 2) = qin_ad(i, 2) - temp_ad16
2628  qin_ad(i, 0) = qin_ad(i, 0) + (g_ou+2.)*temp_ad17
2629  qin_ad(i, -1) = qin_ad(i, -1) - temp_ad17
2630  qy_ad(i, 1) = 0.0
2631  END DO
2632  edge_s => gridstruct%edge_s
2633  DO i=ie1,is2,-1
2634  CALL poprealarray(qout(i, 1))
2635  q1_ad(i-1) = q1_ad(i-1) + edge_s(i)*qout_ad(i, 1)
2636  q1_ad(i) = q1_ad(i) + (1.-edge_s(i))*qout_ad(i, 1)
2637  qout_ad(i, 1) = 0.0
2638  END DO
2639  DO i=ie1,is1,-1
2640  temp_ad13 = q1_ad(i)/(dya(i, 0)+dya(i, 1))
2641  qin_ad(i, 0) = qin_ad(i, 0) + dya(i, 1)*temp_ad13
2642  qin_ad(i, 1) = qin_ad(i, 1) + dya(i, 0)*temp_ad13
2643  q1_ad(i) = 0.0
2644  END DO
2645  END IF
2646  DO j=min5,max5,-1
2647  CALL popinteger(ad_from0)
2648  CALL popinteger(ad_to0)
2649  DO i=ad_to0,ad_from0,-1
2650  qin_ad(i, j-2) = qin_ad(i, j-2) + b2*qy_ad(i, j)
2651  qin_ad(i, j+1) = qin_ad(i, j+1) + b2*qy_ad(i, j)
2652  qin_ad(i, j-1) = qin_ad(i, j-1) + b1*qy_ad(i, j)
2653  qin_ad(i, j) = qin_ad(i, j) + b1*qy_ad(i, j)
2654  qy_ad(i, j) = 0.0
2655  END DO
2656  END DO
2657  END IF
2658  dxa => gridstruct%dxa
2659  CALL popcontrol(2,branch)
2660  IF (branch .EQ. 0) THEN
2661  DO j=je+2,js-2,-1
2662  DO i=ie+1,is,-1
2663  qin_ad(i-2, j) = qin_ad(i-2, j) + b2*qx_ad(i, j)
2664  qin_ad(i+1, j) = qin_ad(i+1, j) + b2*qx_ad(i, j)
2665  qin_ad(i-1, j) = qin_ad(i-1, j) + b1*qx_ad(i, j)
2666  qin_ad(i, j) = qin_ad(i, j) + b1*qx_ad(i, j)
2667  qx_ad(i, j) = 0.0
2668  END DO
2669  END DO
2670  ELSE
2671  IF (branch .EQ. 1) THEN
2672  DO j=min4,max4,-1
2673  g_in = dxa(npx-2, j)/dxa(npx-1, j)
2674  temp_ad9 = qx_ad(npx-1, j)/(g_in*2.+2.)
2675  qin_ad(npx-2, j) = qin_ad(npx-2, j) + 3.*temp_ad9
2676  qx_ad(npx, j) = qx_ad(npx, j) - g_in*temp_ad9
2677  qx_ad(npx-2, j) = qx_ad(npx-2, j) - temp_ad9
2678  qx_ad(npx-1, j) = 0.0
2679  g_ou = dxa(npx+1, j)/dxa(npx, j)
2680  temp_ad11 = 0.5*qx_ad(npx, j)
2681  temp_ad10 = temp_ad11/(g_in+1.)
2682  qin_ad(npx-1, j) = qin_ad(npx-1, j) + (g_in+2.)*temp_ad10 + 3.&
2683 & *g_in*temp_ad9
2684  temp_ad12 = temp_ad11/(g_ou+1.)
2685  qin_ad(npx-2, j) = qin_ad(npx-2, j) - temp_ad10
2686  qin_ad(npx, j) = qin_ad(npx, j) + (g_ou+2.)*temp_ad12
2687  qin_ad(npx+1, j) = qin_ad(npx+1, j) - temp_ad12
2688  qx_ad(npx, j) = 0.0
2689  END DO
2690  edge_e => gridstruct%edge_e
2691  q2_ad = 0.0
2692  DO j=je1,js2,-1
2693  CALL poprealarray(qout(npx, j))
2694  q2_ad(j-1) = q2_ad(j-1) + edge_e(j)*qout_ad(npx, j)
2695  q2_ad(j) = q2_ad(j) + (1.-edge_e(j))*qout_ad(npx, j)
2696  qout_ad(npx, j) = 0.0
2697  END DO
2698  DO j=je1,js1,-1
2699  temp_ad8 = q2_ad(j)/(dxa(npx-1, j)+dxa(npx, j))
2700  qin_ad(npx-1, j) = qin_ad(npx-1, j) + dxa(npx, j)*temp_ad8
2701  qin_ad(npx, j) = qin_ad(npx, j) + dxa(npx-1, j)*temp_ad8
2702  q2_ad(j) = 0.0
2703  END DO
2704  ELSE
2705  q2_ad = 0.0
2706  END IF
2707  CALL popcontrol(1,branch)
2708  IF (branch .EQ. 0) THEN
2709  DO j=min3,max3,-1
2710  g_in = dxa(2, j)/dxa(1, j)
2711  temp_ad4 = qx_ad(2, j)/(g_in*2.+2.)
2712  qin_ad(1, j) = qin_ad(1, j) + 3.*g_in*temp_ad4
2713  qin_ad(2, j) = qin_ad(2, j) + 3.*temp_ad4
2714  qx_ad(1, j) = qx_ad(1, j) - g_in*temp_ad4
2715  qx_ad(3, j) = qx_ad(3, j) - temp_ad4
2716  qx_ad(2, j) = 0.0
2717  g_ou = dxa(-1, j)/dxa(0, j)
2718  temp_ad5 = 0.5*qx_ad(1, j)
2719  temp_ad6 = temp_ad5/(g_in+1.)
2720  temp_ad7 = temp_ad5/(g_ou+1.)
2721  qin_ad(1, j) = qin_ad(1, j) + (g_in+2.)*temp_ad6
2722  qin_ad(2, j) = qin_ad(2, j) - temp_ad6
2723  qin_ad(0, j) = qin_ad(0, j) + (g_ou+2.)*temp_ad7
2724  qin_ad(-1, j) = qin_ad(-1, j) - temp_ad7
2725  qx_ad(1, j) = 0.0
2726  END DO
2727  edge_w => gridstruct%edge_w
2728  DO j=je1,js2,-1
2729  CALL poprealarray(qout(1, j))
2730  q2_ad(j-1) = q2_ad(j-1) + edge_w(j)*qout_ad(1, j)
2731  q2_ad(j) = q2_ad(j) + (1.-edge_w(j))*qout_ad(1, j)
2732  qout_ad(1, j) = 0.0
2733  END DO
2734  DO j=je1,js1,-1
2735  temp_ad3 = q2_ad(j)/(dxa(0, j)+dxa(1, j))
2736  qin_ad(0, j) = qin_ad(0, j) + dxa(1, j)*temp_ad3
2737  qin_ad(1, j) = qin_ad(1, j) + dxa(0, j)*temp_ad3
2738  q2_ad(j) = 0.0
2739  END DO
2740  END IF
2741  DO j=min1,max1,-1
2742  CALL popinteger(ad_from)
2743  CALL popinteger(ad_to)
2744  DO i=ad_to,ad_from,-1
2745  qin_ad(i-2, j) = qin_ad(i-2, j) + b2*qx_ad(i, j)
2746  qin_ad(i+1, j) = qin_ad(i+1, j) + b2*qx_ad(i, j)
2747  qin_ad(i-1, j) = qin_ad(i-1, j) + b1*qx_ad(i, j)
2748  qin_ad(i, j) = qin_ad(i, j) + b1*qx_ad(i, j)
2749  qx_ad(i, j) = 0.0
2750  END DO
2751  END DO
2752  CALL popcontrol(1,branch)
2753  IF (branch .NE. 0) THEN
2754  CALL poprealarray(qout(1, npy))
2755  temp_ad2 = r3*qout_ad(1, npy)
2756  result1_ad = temp_ad2
2757  result2_ad = temp_ad2
2758  result3_ad = temp_ad2
2759  qout_ad(1, npy) = 0.0
2760  CALL extrap_corner_bwd(p0, agrid(1, npy, 1:2), agrid(2, npy+1&
2761 & , 1:2), qin(1, npy), qin_ad(1, npy), qin(2, &
2762 & npy+1), qin_ad(2, npy+1), result3_ad)
2763  CALL extrap_corner_bwd(p0, agrid(0, npy-1, 1:2), agrid(-1, &
2764 & npy-2, 1:2), qin(0, npy-1), qin_ad(0, npy-1)&
2765 & , qin(-1, npy-2), qin_ad(-1, npy-2), &
2766 & result2_ad)
2767  CALL extrap_corner_bwd(p0, agrid(1, npy-1, 1:2), agrid(2, npy&
2768 & -2, 1:2), qin(1, npy-1), qin_ad(1, npy-1), &
2769 & qin(2, npy-2), qin_ad(2, npy-2), result1_ad)
2770  END IF
2771  CALL popcontrol(1,branch)
2772  IF (branch .EQ. 0) THEN
2773  CALL poprealarray(qout(npx, npy))
2774  temp_ad1 = r3*qout_ad(npx, npy)
2775  result1_ad = temp_ad1
2776  result2_ad = temp_ad1
2777  result3_ad = temp_ad1
2778  qout_ad(npx, npy) = 0.0
2779  CALL extrap_corner_bwd(p0, agrid(npx-1, npy, 1:2), agrid(npx-&
2780 & 2, npy+1, 1:2), qin(npx-1, npy), qin_ad(npx-&
2781 & 1, npy), qin(npx-2, npy+1), qin_ad(npx-2, &
2782 & npy+1), result3_ad)
2783  CALL extrap_corner_bwd(p0, agrid(npx, npy-1, 1:2), agrid(npx+&
2784 & 1, npy-2, 1:2), qin(npx, npy-1), qin_ad(npx&
2785 & , npy-1), qin(npx+1, npy-2), qin_ad(npx+1, &
2786 & npy-2), result2_ad)
2787  CALL extrap_corner_bwd(p0, agrid(npx-1, npy-1, 1:2), agrid(&
2788 & npx-2, npy-2, 1:2), qin(npx-1, npy-1), &
2789 & qin_ad(npx-1, npy-1), qin(npx-2, npy-2), &
2790 & qin_ad(npx-2, npy-2), result1_ad)
2791  END IF
2792  CALL popcontrol(1,branch)
2793  IF (branch .EQ. 0) THEN
2794  CALL poprealarray(qout(npx, 1))
2795  temp_ad0 = r3*qout_ad(npx, 1)
2796  result1_ad = temp_ad0
2797  result2_ad = temp_ad0
2798  result3_ad = temp_ad0
2799  qout_ad(npx, 1) = 0.0
2800  CALL extrap_corner_bwd(p0, agrid(npx, 1, 1:2), agrid(npx+1, 2&
2801 & , 1:2), qin(npx, 1), qin_ad(npx, 1), qin(npx&
2802 & +1, 2), qin_ad(npx+1, 2), result3_ad)
2803  CALL extrap_corner_bwd(p0, agrid(npx-1, 0, 1:2), agrid(npx-2&
2804 & , -1, 1:2), qin(npx-1, 0), qin_ad(npx-1, 0)&
2805 & , qin(npx-2, -1), qin_ad(npx-2, -1), &
2806 & result2_ad)
2807  CALL extrap_corner_bwd(p0, agrid(npx-1, 1, 1:2), agrid(npx-2&
2808 & , 2, 1:2), qin(npx-1, 1), qin_ad(npx-1, 1), &
2809 & qin(npx-2, 2), qin_ad(npx-2, 2), result1_ad)
2810  END IF
2811  CALL popcontrol(1,branch)
2812  IF (branch .EQ. 0) THEN
2813  CALL poprealarray(qout(1, 1))
2814  temp_ad = r3*qout_ad(1, 1)
2815  result1_ad = temp_ad
2816  result2_ad = temp_ad
2817  result3_ad = temp_ad
2818  qout_ad(1, 1) = 0.0
2819  CALL extrap_corner_bwd(p0, agrid(1, 0, 1:2), agrid(2, -1, 1:2&
2820 & ), qin(1, 0), qin_ad(1, 0), qin(2, -1), &
2821 & qin_ad(2, -1), result3_ad)
2822  CALL extrap_corner_bwd(p0, agrid(0, 1, 1:2), agrid(-1, 2, 1:2&
2823 & ), qin(0, 1), qin_ad(0, 1), qin(-1, 2), &
2824 & qin_ad(-1, 2), result2_ad)
2825  CALL extrap_corner_bwd(p0, agrid(1, 1, 1:2), agrid(2, 2, 1:2)&
2826 & , qin(1, 1), qin_ad(1, 1), qin(2, 2), qin_ad&
2827 & (2, 2), result1_ad)
2828  END IF
2829  END IF
2830  100 CONTINUE
2831  END SUBROUTINE a2b_ord4_bwd
2832 ! Differentiation of a2b_ord2 in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod
2833 !.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_mo
2834 !d.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix
2835 !_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_S
2836 !uper fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
2837 !fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.rema
2838 !p_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_
2839 !mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv
2840 !_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_res
2841 !tart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_
2842 !z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mo
2843 !d.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.
2844 !SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.n
2845 !est_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2
2846 !c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v
2847 ! sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mo
2848 !d.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_m
2849 !od.great_circle_dist sw_core_mod.edge_interpolate4)):
2850 ! gradient of useful results: qin qout
2851 ! with respect to varying inputs: qin qout
2852  SUBROUTINE a2b_ord2_fwd(qin, qout, gridstruct, npx, npy, is, ie, js, &
2853 & je, ng, replace)
2854  IMPLICIT NONE
2855  INTEGER, INTENT(IN) :: npx, npy, is, ie, js, je, ng
2856 ! A-grid field
2857  REAL, INTENT(INOUT) :: qin(is-ng:ie+ng, js-ng:je+ng)
2858 ! Output B-grid field
2859  REAL :: qout(is-ng:ie+ng, js-ng:je+ng)
2860  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
2861  LOGICAL, OPTIONAL, INTENT(IN) :: replace
2862 ! local:
2863  REAL :: q1(npx), q2(npy)
2864  INTEGER :: i, j
2865  INTEGER :: is1, js1, is2, js2, ie1, je1
2866  REAL, DIMENSION(:, :, :), POINTER :: grid, agrid
2867  REAL, DIMENSION(:, :), POINTER :: dxa, dya
2868  REAL(kind=r_grid), DIMENSION(:), POINTER :: edge_w, edge_e, edge_s, &
2869 & edge_n
2870  INTRINSIC max
2871  INTRINSIC min
2872  INTRINSIC PRESENT
2873 
2874  q1 = 0.0
2875  q2 = 0.0
2876  i = 0
2877  j = 0
2878  is1 = 0
2879  js1 = 0
2880  is2 = 0
2881  js2 = 0
2882  ie1 = 0
2883  je1 = 0
2884 
2885  edge_w => gridstruct%edge_w
2886  edge_e => gridstruct%edge_e
2887  edge_s => gridstruct%edge_s
2888  edge_n => gridstruct%edge_n
2889  IF (gridstruct%grid_type .LT. 3) THEN
2890  IF (gridstruct%nested) THEN
2891  DO j=js-2,je+1+2
2892  DO i=is-2,ie+1+2
2893  CALL pushrealarray(qout(i, j))
2894  qout(i, j) = 0.25*(qin(i-1, j-1)+qin(i, j-1)+qin(i-1, j)+qin&
2895 & (i, j))
2896  END DO
2897  END DO
2898  CALL pushcontrol(2,0)
2899  ELSE
2900  IF (1 .LT. is - 1) THEN
2901  is1 = is - 1
2902  ELSE
2903  is1 = 1
2904  END IF
2905  IF (1 .LT. js - 1) THEN
2906  js1 = js - 1
2907  ELSE
2908  js1 = 1
2909  END IF
2910  IF (2 .LT. is) THEN
2911  is2 = is
2912  ELSE
2913  is2 = 2
2914  END IF
2915  IF (2 .LT. js) THEN
2916  js2 = js
2917  ELSE
2918  js2 = 2
2919  END IF
2920  IF (npx - 1 .GT. ie + 1) THEN
2921  ie1 = ie + 1
2922  ELSE
2923  ie1 = npx - 1
2924  END IF
2925  IF (npy - 1 .GT. je + 1) THEN
2926  je1 = je + 1
2927  ELSE
2928  je1 = npy - 1
2929  END IF
2930  DO j=js2,je1
2931  DO i=is2,ie1
2932  CALL pushrealarray(qout(i, j))
2933  qout(i, j) = 0.25*(qin(i-1, j-1)+qin(i, j-1)+qin(i-1, j)+qin&
2934 & (i, j))
2935  END DO
2936  END DO
2937 ! Fix the 4 Corners:
2938  IF (gridstruct%sw_corner) THEN
2939  CALL pushrealarray(qout(1, 1))
2940  qout(1, 1) = r3*(qin(1, 1)+qin(1, 0)+qin(0, 1))
2941  CALL pushcontrol(1,0)
2942  ELSE
2943  CALL pushcontrol(1,1)
2944  END IF
2945  IF (gridstruct%se_corner) THEN
2946  CALL pushrealarray(qout(npx, 1))
2947  qout(npx, 1) = r3*(qin(npx-1, 1)+qin(npx-1, 0)+qin(npx, 1))
2948  CALL pushcontrol(1,0)
2949  ELSE
2950  CALL pushcontrol(1,1)
2951  END IF
2952  IF (gridstruct%ne_corner) THEN
2953  CALL pushrealarray(qout(npx, npy))
2954  qout(npx, npy) = r3*(qin(npx-1, npy-1)+qin(npx, npy-1)+qin(npx&
2955 & -1, npy))
2956  CALL pushcontrol(1,0)
2957  ELSE
2958  CALL pushcontrol(1,1)
2959  END IF
2960  IF (gridstruct%nw_corner) THEN
2961  CALL pushrealarray(qout(1, npy))
2962  qout(1, npy) = r3*(qin(1, npy-1)+qin(0, npy-1)+qin(1, npy))
2963  CALL pushcontrol(1,0)
2964  ELSE
2965  CALL pushcontrol(1,1)
2966  END IF
2967 ! *** West Edges:
2968  IF (is .EQ. 1) THEN
2969  DO j=js1,je1
2970  q2(j) = 0.5*(qin(0, j)+qin(1, j))
2971  END DO
2972  DO j=js2,je1
2973  CALL pushrealarray(qout(1, j))
2974  qout(1, j) = edge_w(j)*q2(j-1) + (1.-edge_w(j))*q2(j)
2975  END DO
2976  CALL pushcontrol(1,0)
2977  ELSE
2978  CALL pushcontrol(1,1)
2979  END IF
2980 ! East Edges:
2981  IF (ie + 1 .EQ. npx) THEN
2982  DO j=js1,je1
2983  q2(j) = 0.5*(qin(npx-1, j)+qin(npx, j))
2984  END DO
2985  DO j=js2,je1
2986  CALL pushrealarray(qout(npx, j))
2987  qout(npx, j) = edge_e(j)*q2(j-1) + (1.-edge_e(j))*q2(j)
2988  END DO
2989  CALL pushcontrol(1,0)
2990  ELSE
2991  CALL pushcontrol(1,1)
2992  END IF
2993 ! South Edges:
2994  IF (js .EQ. 1) THEN
2995  DO i=is1,ie1
2996  q1(i) = 0.5*(qin(i, 0)+qin(i, 1))
2997  END DO
2998  DO i=is2,ie1
2999  CALL pushrealarray(qout(i, 1))
3000  qout(i, 1) = edge_s(i)*q1(i-1) + (1.-edge_s(i))*q1(i)
3001  END DO
3002  CALL pushcontrol(1,0)
3003  ELSE
3004  CALL pushcontrol(1,1)
3005  END IF
3006 ! North Edges:
3007  IF (je + 1 .EQ. npy) THEN
3008  DO i=is1,ie1
3009  q1(i) = 0.5*(qin(i, npy-1)+qin(i, npy))
3010  END DO
3011  DO i=is2,ie1
3012  CALL pushrealarray(qout(i, npy))
3013  qout(i, npy) = edge_n(i)*q1(i-1) + (1.-edge_n(i))*q1(i)
3014  END DO
3015  CALL pushcontrol(2,1)
3016  ELSE
3017  CALL pushcontrol(2,2)
3018  END IF
3019  END IF
3020  ELSE
3021  DO j=js,je+1
3022  DO i=is,ie+1
3023  CALL pushrealarray(qout(i, j))
3024  qout(i, j) = 0.25*(qin(i-1, j-1)+qin(i, j-1)+qin(i-1, j)+qin(i&
3025 & , j))
3026  END DO
3027  END DO
3028  CALL pushcontrol(2,3)
3029  END IF
3030  IF (PRESENT(replace)) THEN
3031  IF (replace) THEN
3032  DO j=js,je+1
3033  DO i=is,ie+1
3034  CALL pushrealarray(qin(i, j))
3035  qin(i, j) = qout(i, j)
3036  END DO
3037  END DO
3038  CALL pushinteger(ie1)
3039  CALL pushinteger(js2)
3040  CALL pushinteger(js1)
3041  CALL pushinteger(je1)
3042  CALL pushinteger(is2)
3043  CALL pushinteger(is1)
3044  CALL pushcontrol(2,2)
3045  ELSE
3046  CALL pushinteger(ie1)
3047  CALL pushinteger(js2)
3048  CALL pushinteger(js1)
3049  CALL pushinteger(je1)
3050  CALL pushinteger(is2)
3051  CALL pushinteger(is1)
3052  CALL pushcontrol(2,1)
3053  END IF
3054  ELSE
3055  CALL pushinteger(ie1)
3056  CALL pushinteger(js2)
3057  CALL pushinteger(js1)
3058  CALL pushinteger(je1)
3059  CALL pushinteger(is2)
3060  CALL pushinteger(is1)
3061  CALL pushcontrol(2,0)
3062  END IF
3063  END SUBROUTINE a2b_ord2_fwd
3064 ! Differentiation of a2b_ord2 in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mo
3065 !d.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_m
3066 !od.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mi
3067 !x_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_
3068 !Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4
3069 ! fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.rem
3070 !ap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv
3071 !_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters f
3072 !v_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_re
3073 !start_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid
3074 !_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_m
3075 !od.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod
3076 !.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.
3077 !nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a
3078 !2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v_f
3079 !b sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_m
3080 !od.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_
3081 !mod.great_circle_dist sw_core_mod.edge_interpolate4)):
3082 ! gradient of useful results: qin qout
3083 ! with respect to varying inputs: qin qout
3084  SUBROUTINE a2b_ord2_bwd(qin, qin_ad, qout, qout_ad, gridstruct, npx, &
3085 & npy, is, ie, js, je, ng, replace)
3086  IMPLICIT NONE
3087  INTEGER, INTENT(IN) :: npx, npy, is, ie, js, je, ng
3088  REAL, INTENT(INOUT) :: qin(is-ng:ie+ng, js-ng:je+ng)
3089  REAL, INTENT(INOUT) :: qin_ad(is-ng:ie+ng, js-ng:je+ng)
3090  REAL :: qout(is-ng:ie+ng, js-ng:je+ng)
3091  REAL :: qout_ad(is-ng:ie+ng, js-ng:je+ng)
3092  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
3093  LOGICAL, OPTIONAL, INTENT(IN) :: replace
3094  REAL :: q1(npx), q2(npy)
3095  REAL :: q1_ad(npx), q2_ad(npy)
3096  INTEGER :: i, j
3097  INTEGER :: is1, js1, is2, js2, ie1, je1
3098  REAL, DIMENSION(:, :, :), POINTER :: grid, agrid
3099  REAL, DIMENSION(:, :), POINTER :: dxa, dya
3100  REAL(kind=r_grid), DIMENSION(:), POINTER :: edge_w, edge_e, edge_s, &
3101 & edge_n
3102  INTRINSIC max
3103  INTRINSIC min
3104  INTRINSIC PRESENT
3105  REAL :: temp_ad
3106  REAL :: temp_ad0
3107  REAL :: temp_ad1
3108  REAL :: temp_ad2
3109  REAL :: temp_ad3
3110  REAL :: temp_ad4
3111  REAL :: temp_ad5
3112  INTEGER :: branch
3113 
3114  q1 = 0.0
3115  q2 = 0.0
3116  i = 0
3117  j = 0
3118  is1 = 0
3119  js1 = 0
3120  is2 = 0
3121  js2 = 0
3122  ie1 = 0
3123  je1 = 0
3124  branch = 0
3125 
3126  CALL popcontrol(2,branch)
3127  IF (branch .EQ. 0) THEN
3128  CALL popinteger(is1)
3129  CALL popinteger(is2)
3130  CALL popinteger(je1)
3131  CALL popinteger(js1)
3132  CALL popinteger(js2)
3133  CALL popinteger(ie1)
3134  ELSE IF (branch .EQ. 1) THEN
3135  CALL popinteger(is1)
3136  CALL popinteger(is2)
3137  CALL popinteger(je1)
3138  CALL popinteger(js1)
3139  CALL popinteger(js2)
3140  CALL popinteger(ie1)
3141  ELSE
3142  CALL popinteger(is1)
3143  CALL popinteger(is2)
3144  CALL popinteger(je1)
3145  CALL popinteger(js1)
3146  CALL popinteger(js2)
3147  CALL popinteger(ie1)
3148  DO j=je+1,js,-1
3149  DO i=ie+1,is,-1
3150  CALL poprealarray(qin(i, j))
3151  qout_ad(i, j) = qout_ad(i, j) + qin_ad(i, j)
3152  qin_ad(i, j) = 0.0
3153  END DO
3154  END DO
3155  END IF
3156  edge_n => gridstruct%edge_n
3157  CALL popcontrol(2,branch)
3158  IF (branch .LT. 2) THEN
3159  IF (branch .EQ. 0) THEN
3160  DO j=je+3,js-2,-1
3161  DO i=ie+3,is-2,-1
3162  CALL poprealarray(qout(i, j))
3163  temp_ad = 0.25*qout_ad(i, j)
3164  qin_ad(i-1, j-1) = qin_ad(i-1, j-1) + temp_ad
3165  qin_ad(i, j-1) = qin_ad(i, j-1) + temp_ad
3166  qin_ad(i-1, j) = qin_ad(i-1, j) + temp_ad
3167  qin_ad(i, j) = qin_ad(i, j) + temp_ad
3168  qout_ad(i, j) = 0.0
3169  END DO
3170  END DO
3171  GOTO 100
3172  ELSE
3173  q1_ad = 0.0
3174  DO i=ie1,is2,-1
3175  CALL poprealarray(qout(i, npy))
3176  q1_ad(i-1) = q1_ad(i-1) + edge_n(i)*qout_ad(i, npy)
3177  q1_ad(i) = q1_ad(i) + (1.-edge_n(i))*qout_ad(i, npy)
3178  qout_ad(i, npy) = 0.0
3179  END DO
3180  DO i=ie1,is1,-1
3181  qin_ad(i, npy-1) = qin_ad(i, npy-1) + 0.5*q1_ad(i)
3182  qin_ad(i, npy) = qin_ad(i, npy) + 0.5*q1_ad(i)
3183  q1_ad(i) = 0.0
3184  END DO
3185  END IF
3186  ELSE IF (branch .EQ. 2) THEN
3187  q1_ad = 0.0
3188  ELSE
3189  DO j=je+1,js,-1
3190  DO i=ie+1,is,-1
3191  CALL poprealarray(qout(i, j))
3192  temp_ad5 = 0.25*qout_ad(i, j)
3193  qin_ad(i-1, j-1) = qin_ad(i-1, j-1) + temp_ad5
3194  qin_ad(i, j-1) = qin_ad(i, j-1) + temp_ad5
3195  qin_ad(i-1, j) = qin_ad(i-1, j) + temp_ad5
3196  qin_ad(i, j) = qin_ad(i, j) + temp_ad5
3197  qout_ad(i, j) = 0.0
3198  END DO
3199  END DO
3200  GOTO 100
3201  END IF
3202  edge_s => gridstruct%edge_s
3203  CALL popcontrol(1,branch)
3204  IF (branch .EQ. 0) THEN
3205  DO i=ie1,is2,-1
3206  CALL poprealarray(qout(i, 1))
3207  q1_ad(i-1) = q1_ad(i-1) + edge_s(i)*qout_ad(i, 1)
3208  q1_ad(i) = q1_ad(i) + (1.-edge_s(i))*qout_ad(i, 1)
3209  qout_ad(i, 1) = 0.0
3210  END DO
3211  DO i=ie1,is1,-1
3212  qin_ad(i, 0) = qin_ad(i, 0) + 0.5*q1_ad(i)
3213  qin_ad(i, 1) = qin_ad(i, 1) + 0.5*q1_ad(i)
3214  q1_ad(i) = 0.0
3215  END DO
3216  END IF
3217  edge_e => gridstruct%edge_e
3218  CALL popcontrol(1,branch)
3219  IF (branch .EQ. 0) THEN
3220  q2_ad = 0.0
3221  DO j=je1,js2,-1
3222  CALL poprealarray(qout(npx, j))
3223  q2_ad(j-1) = q2_ad(j-1) + edge_e(j)*qout_ad(npx, j)
3224  q2_ad(j) = q2_ad(j) + (1.-edge_e(j))*qout_ad(npx, j)
3225  qout_ad(npx, j) = 0.0
3226  END DO
3227  DO j=je1,js1,-1
3228  qin_ad(npx-1, j) = qin_ad(npx-1, j) + 0.5*q2_ad(j)
3229  qin_ad(npx, j) = qin_ad(npx, j) + 0.5*q2_ad(j)
3230  q2_ad(j) = 0.0
3231  END DO
3232  ELSE
3233  q2_ad = 0.0
3234  END IF
3235  edge_w => gridstruct%edge_w
3236  CALL popcontrol(1,branch)
3237  IF (branch .EQ. 0) THEN
3238  DO j=je1,js2,-1
3239  CALL poprealarray(qout(1, j))
3240  q2_ad(j-1) = q2_ad(j-1) + edge_w(j)*qout_ad(1, j)
3241  q2_ad(j) = q2_ad(j) + (1.-edge_w(j))*qout_ad(1, j)
3242  qout_ad(1, j) = 0.0
3243  END DO
3244  DO j=je1,js1,-1
3245  qin_ad(0, j) = qin_ad(0, j) + 0.5*q2_ad(j)
3246  qin_ad(1, j) = qin_ad(1, j) + 0.5*q2_ad(j)
3247  q2_ad(j) = 0.0
3248  END DO
3249  END IF
3250  CALL popcontrol(1,branch)
3251  IF (branch .EQ. 0) THEN
3252  CALL poprealarray(qout(1, npy))
3253  temp_ad4 = r3*qout_ad(1, npy)
3254  qin_ad(1, npy-1) = qin_ad(1, npy-1) + temp_ad4
3255  qin_ad(0, npy-1) = qin_ad(0, npy-1) + temp_ad4
3256  qin_ad(1, npy) = qin_ad(1, npy) + temp_ad4
3257  qout_ad(1, npy) = 0.0
3258  END IF
3259  CALL popcontrol(1,branch)
3260  IF (branch .EQ. 0) THEN
3261  CALL poprealarray(qout(npx, npy))
3262  temp_ad3 = r3*qout_ad(npx, npy)
3263  qin_ad(npx-1, npy-1) = qin_ad(npx-1, npy-1) + temp_ad3
3264  qin_ad(npx, npy-1) = qin_ad(npx, npy-1) + temp_ad3
3265  qin_ad(npx-1, npy) = qin_ad(npx-1, npy) + temp_ad3
3266  qout_ad(npx, npy) = 0.0
3267  END IF
3268  CALL popcontrol(1,branch)
3269  IF (branch .EQ. 0) THEN
3270  CALL poprealarray(qout(npx, 1))
3271  temp_ad2 = r3*qout_ad(npx, 1)
3272  qin_ad(npx-1, 1) = qin_ad(npx-1, 1) + temp_ad2
3273  qin_ad(npx-1, 0) = qin_ad(npx-1, 0) + temp_ad2
3274  qin_ad(npx, 1) = qin_ad(npx, 1) + temp_ad2
3275  qout_ad(npx, 1) = 0.0
3276  END IF
3277  CALL popcontrol(1,branch)
3278  IF (branch .EQ. 0) THEN
3279  CALL poprealarray(qout(1, 1))
3280  temp_ad1 = r3*qout_ad(1, 1)
3281  qin_ad(1, 1) = qin_ad(1, 1) + temp_ad1
3282  qin_ad(1, 0) = qin_ad(1, 0) + temp_ad1
3283  qin_ad(0, 1) = qin_ad(0, 1) + temp_ad1
3284  qout_ad(1, 1) = 0.0
3285  END IF
3286  DO j=je1,js2,-1
3287  DO i=ie1,is2,-1
3288  CALL poprealarray(qout(i, j))
3289  temp_ad0 = 0.25*qout_ad(i, j)
3290  qin_ad(i-1, j-1) = qin_ad(i-1, j-1) + temp_ad0
3291  qin_ad(i, j-1) = qin_ad(i, j-1) + temp_ad0
3292  qin_ad(i-1, j) = qin_ad(i-1, j) + temp_ad0
3293  qin_ad(i, j) = qin_ad(i, j) + temp_ad0
3294  qout_ad(i, j) = 0.0
3295  END DO
3296  END DO
3297  100 CONTINUE
3298  END SUBROUTINE a2b_ord2_bwd
3299  SUBROUTINE a2b_ord2(qin, qout, gridstruct, npx, npy, is, ie, js, je, &
3300 & ng, replace)
3301  IMPLICIT NONE
3302  INTEGER, INTENT(IN) :: npx, npy, is, ie, js, je, ng
3303 ! A-grid field
3304  REAL, INTENT(INOUT) :: qin(is-ng:ie+ng, js-ng:je+ng)
3305 ! Output B-grid field
3306  REAL, INTENT(OUT) :: qout(is-ng:ie+ng, js-ng:je+ng)
3307  TYPE(fv_grid_type), INTENT(IN), TARGET :: gridstruct
3308  LOGICAL, OPTIONAL, INTENT(IN) :: replace
3309 ! local:
3310  REAL :: q1(npx), q2(npy)
3311  INTEGER :: i, j
3312  INTEGER :: is1, js1, is2, js2, ie1, je1
3313  REAL, DIMENSION(:, :, :), POINTER :: grid, agrid
3314  REAL, DIMENSION(:, :), POINTER :: dxa, dya
3315  REAL(kind=r_grid), DIMENSION(:), POINTER :: edge_w, edge_e, edge_s, &
3316 & edge_n
3317  INTRINSIC max
3318  INTRINSIC min
3319  INTRINSIC PRESENT
3320  edge_w => gridstruct%edge_w
3321  edge_e => gridstruct%edge_e
3322  edge_s => gridstruct%edge_s
3323  edge_n => gridstruct%edge_n
3324  grid => gridstruct%grid
3325  agrid => gridstruct%agrid
3326  dxa => gridstruct%dxa
3327  dya => gridstruct%dya
3328  IF (gridstruct%grid_type .LT. 3) THEN
3329  IF (gridstruct%nested) THEN
3330  DO j=js-2,je+1+2
3331  DO i=is-2,ie+1+2
3332  qout(i, j) = 0.25*(qin(i-1, j-1)+qin(i, j-1)+qin(i-1, j)+qin&
3333 & (i, j))
3334  END DO
3335  END DO
3336  ELSE
3337  IF (1 .LT. is - 1) THEN
3338  is1 = is - 1
3339  ELSE
3340  is1 = 1
3341  END IF
3342  IF (1 .LT. js - 1) THEN
3343  js1 = js - 1
3344  ELSE
3345  js1 = 1
3346  END IF
3347  IF (2 .LT. is) THEN
3348  is2 = is
3349  ELSE
3350  is2 = 2
3351  END IF
3352  IF (2 .LT. js) THEN
3353  js2 = js
3354  ELSE
3355  js2 = 2
3356  END IF
3357  IF (npx - 1 .GT. ie + 1) THEN
3358  ie1 = ie + 1
3359  ELSE
3360  ie1 = npx - 1
3361  END IF
3362  IF (npy - 1 .GT. je + 1) THEN
3363  je1 = je + 1
3364  ELSE
3365  je1 = npy - 1
3366  END IF
3367  DO j=js2,je1
3368  DO i=is2,ie1
3369  qout(i, j) = 0.25*(qin(i-1, j-1)+qin(i, j-1)+qin(i-1, j)+qin&
3370 & (i, j))
3371  END DO
3372  END DO
3373 ! Fix the 4 Corners:
3374  IF (gridstruct%sw_corner) qout(1, 1) = r3*(qin(1, 1)+qin(1, 0)+&
3375 & qin(0, 1))
3376  IF (gridstruct%se_corner) qout(npx, 1) = r3*(qin(npx-1, 1)+qin(&
3377 & npx-1, 0)+qin(npx, 1))
3378  IF (gridstruct%ne_corner) qout(npx, npy) = r3*(qin(npx-1, npy-1)&
3379 & +qin(npx, npy-1)+qin(npx-1, npy))
3380  IF (gridstruct%nw_corner) qout(1, npy) = r3*(qin(1, npy-1)+qin(0&
3381 & , npy-1)+qin(1, npy))
3382 ! *** West Edges:
3383  IF (is .EQ. 1) THEN
3384  DO j=js1,je1
3385  q2(j) = 0.5*(qin(0, j)+qin(1, j))
3386  END DO
3387  DO j=js2,je1
3388  qout(1, j) = edge_w(j)*q2(j-1) + (1.-edge_w(j))*q2(j)
3389  END DO
3390  END IF
3391 ! East Edges:
3392  IF (ie + 1 .EQ. npx) THEN
3393  DO j=js1,je1
3394  q2(j) = 0.5*(qin(npx-1, j)+qin(npx, j))
3395  END DO
3396  DO j=js2,je1
3397  qout(npx, j) = edge_e(j)*q2(j-1) + (1.-edge_e(j))*q2(j)
3398  END DO
3399  END IF
3400 ! South Edges:
3401  IF (js .EQ. 1) THEN
3402  DO i=is1,ie1
3403  q1(i) = 0.5*(qin(i, 0)+qin(i, 1))
3404  END DO
3405  DO i=is2,ie1
3406  qout(i, 1) = edge_s(i)*q1(i-1) + (1.-edge_s(i))*q1(i)
3407  END DO
3408  END IF
3409 ! North Edges:
3410  IF (je + 1 .EQ. npy) THEN
3411  DO i=is1,ie1
3412  q1(i) = 0.5*(qin(i, npy-1)+qin(i, npy))
3413  END DO
3414  DO i=is2,ie1
3415  qout(i, npy) = edge_n(i)*q1(i-1) + (1.-edge_n(i))*q1(i)
3416  END DO
3417  END IF
3418  END IF
3419  ELSE
3420  DO j=js,je+1
3421  DO i=is,ie+1
3422  qout(i, j) = 0.25*(qin(i-1, j-1)+qin(i, j-1)+qin(i-1, j)+qin(i&
3423 & , j))
3424  END DO
3425  END DO
3426  END IF
3427  IF (PRESENT(replace)) THEN
3428  IF (replace) THEN
3429  DO j=js,je+1
3430  DO i=is,ie+1
3431  qin(i, j) = qout(i, j)
3432  END DO
3433  END DO
3434  END IF
3435  END IF
3436  END SUBROUTINE a2b_ord2
3437 ! Differentiation of extrap_corner in reverse (adjoint) mode (with options split(a2b_edge_mod.a2b_ord4 a2b_edge_mod.a2b_ord2
3438 !dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn_core_mod.p_grad_c
3439 ! dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core_mod.mix_dp dyn_co
3440 !re_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Rayleigh_Super fv_dy
3441 !namics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c2l_ord4 fv_grid_ut
3442 !ils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_mod.remap_z fv_map
3443 !z_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.remap_2d fv_mapz_mod.s
3444 !calar_profile_fb fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_limiters fv_mapz_mod.
3445 !steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubic fv_restart_mod.d
3446 !2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_subgrid_z main_mod
3447 !.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_utils_mod.Riem_Sol
3448 !ver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_utils_mod.SIM3p0_sol
3449 !ver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_utils_mod.nest_halo_n
3450 !h sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_mod.d2a2c_vect sw_
3451 !core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.ytp_v sw_core_m
3452 !od.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp_core_mod.copy_cor
3453 !ners_fb tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid_utils_mod.great_c
3454 !ircle_dist sw_core_mod.edge_interpolate4)):
3455 ! gradient of useful results: extrap_corner q1 q2
3456 ! with respect to varying inputs: q1 q2
3457  SUBROUTINE extrap_corner_adm(p0, p1, p2, q1, q1_ad, q2, q2_ad, &
3458 & extrap_corner_ad)
3459  IMPLICIT NONE
3460  REAL, DIMENSION(2), INTENT(IN) :: p0, p1, p2
3461  REAL, INTENT(IN) :: q1, q2
3462  REAL :: q1_ad, q2_ad
3463  REAL :: x1, x2
3464  INTRINSIC real
3465  REAL(r_grid), DIMENSION(2) :: arg1
3466  REAL(r_grid), DIMENSION(2) :: arg2
3467  REAL :: temp_ad
3468  REAL :: extrap_corner_ad
3469  REAL :: extrap_corner
3470  arg1(:) = REAL(p1, kind=r_grid)
3471  arg2(:) = REAL(p0, kind=r_grid)
3472  x1 = great_circle_dist(REAL(p1, kind=r_grid), REAL(p0, kind=r_grid))
3473  arg1(:) = REAL(p2, kind=r_grid)
3474  arg2(:) = REAL(p0, kind=r_grid)
3475  x2 = great_circle_dist(REAL(p2, kind=r_grid), REAL(p0, kind=r_grid))
3476  temp_ad = x1*extrap_corner_ad/(x2-x1)
3477  q1_ad = q1_ad + temp_ad + extrap_corner_ad
3478  q2_ad = q2_ad - temp_ad
3479  END SUBROUTINE extrap_corner_adm
3480  REAL FUNCTION extrap_corner(p0, p1, p2, q1, q2)
3481  IMPLICIT NONE
3482  REAL, DIMENSION(2), INTENT(IN) :: p0, p1, p2
3483  REAL, INTENT(IN) :: q1, q2
3484  REAL :: x1, x2
3485  INTRINSIC real
3486  REAL(r_grid), DIMENSION(2) :: arg1
3487  REAL(r_grid), DIMENSION(2) :: arg2
3488  arg1(:) = REAL(p1, kind=r_grid)
3489  arg2(:) = REAL(p0, kind=r_grid)
3490  x1 = great_circle_dist(arg1(:), arg2(:))
3491  arg1(:) = REAL(p2, kind=r_grid)
3492  arg2(:) = REAL(p0, kind=r_grid)
3493  x2 = great_circle_dist(arg1(:), arg2(:))
3494  extrap_corner = q1 + x1/(x2-x1)*(q1-q2)
3495  END FUNCTION extrap_corner
3496 ! Differentiation of extrap_corner in reverse (adjoint) mode, forward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b_
3497 !edge_mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dyn
3498 !_core_mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_core
3499 !_mod.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.Ra
3500 !yleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.c
3501 !2l_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz_
3502 !mod.remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.rema
3503 !p_2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_lim
3504 !iters fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cubi
3505 !c fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv_
3506 !subgrid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh_
3507 !utils_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_ut
3508 !ils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_uti
3509 !ls_mod.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core_
3510 !mod.d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod.
3511 !ytp_v sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d tp
3512 !_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_grid
3513 !_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
3514 ! gradient of useful results: q1 q2 extrap_corner
3515 ! with respect to varying inputs: q1 q2
3516  REAL FUNCTION extrap_corner_fwd(p0, p1, p2, q1, q2)
3517  IMPLICIT NONE
3518  REAL, DIMENSION(2), INTENT(IN) :: p0, p1, p2
3519  REAL, INTENT(IN) :: q1, q2
3520  REAL :: x1, x2
3521  INTRINSIC real
3522  REAL(r_grid), DIMENSION(2) :: arg1
3523  REAL(r_grid), DIMENSION(2) :: arg2
3524  REAL :: extrap_corner
3525  arg1(:) = REAL(p1, kind=r_grid)
3526  arg2(:) = REAL(p0, kind=r_grid)
3527  x1 = great_circle_dist(REAL(p1, kind=r_grid), REAL(p0, kind=r_grid))
3528  arg1(:) = REAL(p2, kind=r_grid)
3529  arg2(:) = REAL(p0, kind=r_grid)
3530  x2 = great_circle_dist(REAL(p2, kind=r_grid), REAL(p0, kind=r_grid))
3531  extrap_corner = q1 + x1/(x2-x1)*(q1-q2)
3532  CALL pushrealarray(x2)
3533  CALL pushrealarray(x1)
3534  extrap_corner_fwd = extrap_corner
3535  END FUNCTION extrap_corner_fwd
3536 ! Differentiation of extrap_corner in reverse (adjoint) mode, backward sweep (with options split(a2b_edge_mod.a2b_ord4 a2b
3537 !_edge_mod.a2b_ord2 dyn_core_mod.dyn_core dyn_core_mod.pk3_halo dyn_core_mod.pln_halo dyn_core_mod.pe_halo dyn_core_mod.adv_pe dy
3538 !n_core_mod.p_grad_c dyn_core_mod.nh_p_grad dyn_core_mod.split_p_grad dyn_core_mod.one_grad_p dyn_core_mod.grad1_p_update dyn_cor
3539 !e_mod.mix_dp dyn_core_mod.geopk dyn_core_mod.del2_cubed dyn_core_mod.Rayleigh_fast fv_dynamics_mod.fv_dynamics fv_dynamics_mod.R
3540 !ayleigh_Super fv_dynamics_mod.Rayleigh_Friction fv_dynamics_mod.compute_aam fv_grid_utils_mod.cubed_to_latlon fv_grid_utils_mod.
3541 !c2l_ord4 fv_grid_utils_mod.c2l_ord2 fv_mapz_mod.Lagrangian_to_Eulerian fv_mapz_mod.compute_total_energy fv_mapz_mod.pkez fv_mapz
3542 !_mod.remap_z fv_mapz_mod.map_scalar fv_mapz_mod.map1_ppm fv_mapz_mod.mapn_tracer fv_mapz_mod.map1_q2 fv_mapz_mod.rem
3543 !ap_2d fv_mapz_mod.scalar_profile fv_mapz_mod.cs_profile fv_mapz_mod.cs_limiters fv_mapz_mod.ppm_profile fv_mapz_mod.ppm_li
3544 !miters fv_mapz_mod.steepz fv_mapz_mod.rst_remap fv_mapz_mod.mappm fv_mapz_mod.moist_cv fv_mapz_mod.moist_cp fv_mapz_mod.map1_cub
3545 !ic fv_restart_mod.d2c_setup fv_tracer2d_mod.tracer_2d_1L fv_tracer2d_mod.tracer_2d fv_tracer2d_mod.tracer_2d_nested fv_sg_mod.fv
3546 !_subgrid_z main_mod.compute_pressures main_mod.run nh_core_mod.Riem_Solver3 nh_utils_mod.update_dz_c nh_utils_mod.update_dz_d nh
3547 !_utils_mod.Riem_Solver_c nh_utils_mod.Riem_Solver3test nh_utils_mod.imp_diff_w nh_utils_mod.RIM_2D nh_utils_mod.SIM3_solver nh_u
3548 !tils_mod.SIM3p0_solver nh_utils_mod.SIM1_solver nh_utils_mod.SIM_solver nh_utils_mod.edge_scalar nh_utils_mod.edge_profile nh_ut
3549 !ils_mod.nest_halo_nh sw_core_mod.c_sw sw_core_mod.d_sw sw_core_mod.divergence_corner sw_core_mod.divergence_corner_nest sw_core
3550 !_mod.d2a2c_vect sw_core_mod.fill3_4corners sw_core_mod.fill2_4corners sw_core_mod.fill_4corners sw_core_mod.xtp_u sw_core_mod
3551 !.ytp_v sw_core_mod.compute_divergence_damping sw_core_mod.smag_corner tp_core_mod.mp_ghost_ew tp_core_mod.fv_tp_2d t
3552 !p_core_mod.copy_corners tp_core_mod.xppm tp_core_mod.yppm tp_core_mod.deln_flux a2b_edge_mod.extrap_corner fv_gri
3553 !d_utils_mod.great_circle_dist sw_core_mod.edge_interpolate4)):
3554 ! gradient of useful results: q1 q2 extrap_corner
3555 ! with respect to varying inputs: q1 q2
3556  SUBROUTINE extrap_corner_bwd(p0, p1, p2, q1, q1_ad, q2, q2_ad, &
3557 & extrap_corner_ad)
3558  IMPLICIT NONE
3559  REAL, DIMENSION(2), INTENT(IN) :: p0, p1, p2
3560  REAL, INTENT(IN) :: q1, q2
3561  REAL :: q1_ad, q2_ad
3562  REAL :: x1, x2
3563  INTRINSIC real
3564  REAL(r_grid), DIMENSION(2) :: arg1
3565  REAL(r_grid), DIMENSION(2) :: arg2
3566  REAL :: temp_ad
3567  REAL :: extrap_corner
3568  REAL :: extrap_corner_ad
3569  CALL poprealarray(x1)
3570  CALL poprealarray(x2)
3571  temp_ad = x1*extrap_corner_ad/(x2-x1)
3572  q1_ad = q1_ad + temp_ad + extrap_corner_ad
3573  q2_ad = q2_ad - temp_ad
3574  END SUBROUTINE extrap_corner_bwd
3575 end module a2b_edge_adm_mod
tapenade_iter::poprealarray_adm
Definition: tapenade_iter.F90:186
a2b_edge_adm_mod::a2b_ord2_fwd
subroutine, public a2b_ord2_fwd(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_adm.F90:2854
tapenade_iter::pushrealarray
Definition: tapenade_iter.F90:146
popinteger4
subroutine popinteger4(x)
Definition: adBuffer.f:541
popcontrol2b
subroutine popcontrol2b(cc)
Definition: adBuffer.f:146
a2b_edge_adm_mod::a2b_ord4
subroutine, public a2b_ord4(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_adm.F90:898
a2b_edge_adm_mod
Definition: a2b_edge_adm.F90:20
fv_arrays_nlm_mod::fv_grid_type
Definition: fv_arrays_nlm.F90:115
a2b_edge_adm_mod::a2b_ord2_bwd
subroutine, public a2b_ord2_bwd(qin, qin_ad, qout, qout_ad, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_adm.F90:3086
tapenade_iter::pushinteger
Definition: tapenade_iter.F90:136
tapenade_iter::pushcontrol
subroutine, public pushcontrol(ctype, field)
Definition: tapenade_iter.F90:861
a2b_edge_adm_mod::extrap_corner
real function extrap_corner(p0, p1, p2, q1, q2)
Definition: a2b_edge_adm.F90:3481
a2b_edge_adm_mod::b1
real, parameter b1
Definition: a2b_edge_adm.F90:43
a2b_edge_adm_mod::a2
real, parameter a2
Definition: a2b_edge_adm.F90:39
a2b_edge_adm_mod::extrap_corner_fwd
real function extrap_corner_fwd(p0, p1, p2, q1, q2)
Definition: a2b_edge_adm.F90:3517
pushcontrol1b
subroutine pushcontrol1b(cc)
Definition: adBuffer.f:115
a2b_edge_adm_mod::extrap_corner_bwd
subroutine extrap_corner_bwd(p0, p1, p2, q1, q1_ad, q2, q2_ad, extrap_corner_ad)
Definition: a2b_edge_adm.F90:3558
a2b_edge_adm_mod::a1
real, parameter a1
Definition: a2b_edge_adm.F90:38
fv_grid_utils_nlm_mod
Definition: fv_grid_utils_nlm.F90:20
a2b_ord2
void a2b_ord2(int nx, int ny, const double *qin, const double *edge_w, const double *edge_e, const double *edge_s, const double *edge_n, double *qout, int on_west_edge, int on_east_edge, int on_south_edge, int on_north_edge)
Definition: gradient_c2l.c:119
pushcontrol2b
subroutine pushcontrol2b(cc)
Definition: adBuffer.f:140
a2b_edge_adm_mod::a2b_ord4_bwd
subroutine, public a2b_ord4_bwd(qin, qin_ad, qout, qout_ad, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_adm.F90:2153
tapenade_iter::pushrealarray_adm
Definition: tapenade_iter.F90:173
tapenade_iter
Definition: tapenade_iter.F90:1
a2b_edge_adm_mod::b2
real, parameter b2
Definition: a2b_edge_adm.F90:44
fv_arrays_nlm_mod
Definition: fv_arrays_nlm.F90:20
fv_arrays_nlm_mod::r_grid
integer, parameter, public r_grid
Definition: fv_arrays_nlm.F90:32
fv_grid_utils_nlm_mod::great_circle_dist
real function, public great_circle_dist(q1, q2, radius)
Definition: fv_grid_utils_nlm.F90:1968
tapenade_iter::poprealarray
Definition: tapenade_iter.F90:159
popcontrol1b
subroutine popcontrol1b(cc)
Definition: adBuffer.f:120
max
#define max(a, b)
Definition: mosaic_util.h:33
a2b_edge_adm_mod::a2b_ord4_adm
subroutine, public a2b_ord4_adm(qin, qin_ad, qout, qout_ad, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_adm.F90:74
min
#define min(a, b)
Definition: mosaic_util.h:32
a2b_edge_adm_mod::extrap_corner_adm
subroutine extrap_corner_adm(p0, p1, p2, q1, q1_ad, q2, q2_ad, extrap_corner_ad)
Definition: a2b_edge_adm.F90:3459
tapenade_iter::popcontrol
subroutine, public popcontrol(ctype, field)
Definition: tapenade_iter.F90:922
pushinteger4
subroutine pushinteger4(x)
Definition: adBuffer.f:484
tapenade_iter::popinteger
Definition: tapenade_iter.F90:141
a2b_edge_adm_mod::a2b_ord4_fwd
subroutine, public a2b_ord4_fwd(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge_adm.F90:1413
a2b_edge_adm_mod::r3
real, parameter r3
Definition: a2b_edge_adm.F90:34