da_check_sfc_assi.inc
References to this file elsewhere.
1 subroutine da_check_sfc_assi(grid, iv, y)
2
3 !-----------------------------------------------------------------------
4 ! Purpose: TBD
5 !-----------------------------------------------------------------------
6
7 implicit none
8
9 type (domain), intent(inout) :: grid
10
11 type (iv_type), intent(inout) :: iv ! ob. increment vector.
12 type (y_type), intent(inout) :: y ! y = h (grid%xa)
13
14 real :: adj_ttl_lhs ! < y, y >
15 real :: adj_ttl_rhs ! < x, x_adj >
16
17 real :: partial_lhs ! < y, y >
18 real :: partial_rhs ! < x, x_adj >
19
20 real :: pertile_lhs ! < y, y >
21 real :: pertile_rhs ! < x, x_adj >
22
23 integer :: n
24
25 real, dimension(ims:ime, jms:jme, kms:kme) :: xa2_u, xa2_v, xa2_t, &
26 xa2_p, xa2_q
27
28 real, dimension(ims:ime, jms:jme) :: xa2_u10, xa2_v10, xa2_t2, &
29 xa2_q2, xa2_tgrn, xa2_psfc
30
31
32 if (trace_use) call da_trace_entry("da_check_sfc_assi")
33
34 call da_message((/"check_sfc_assi: Adjoint Test Results:"/))
35
36 xa2_u(ims:ime, jms:jme, kms:kme) = grid%xa%u(ims:ime, jms:jme, kms:kme)
37 xa2_v(ims:ime, jms:jme, kms:kme) = grid%xa%v(ims:ime, jms:jme, kms:kme)
38 xa2_t(ims:ime, jms:jme, kms:kme) = grid%xa%t(ims:ime, jms:jme, kms:kme)
39 xa2_p(ims:ime, jms:jme, kms:kme) = grid%xa%p(ims:ime, jms:jme, kms:kme)
40 xa2_q(ims:ime, jms:jme, kms:kme) = grid%xa%q(ims:ime, jms:jme, kms:kme)
41
42 xa2_psfc(ims:ime, jms:jme) = grid%xa%psfc(ims:ime, jms:jme)
43 xa2_tgrn(ims:ime, jms:jme) = grid%xa%tgrn(ims:ime, jms:jme)
44 xa2_u10 (ims:ime, jms:jme) = grid%xa%u10 (ims:ime, jms:jme)
45 xa2_v10 (ims:ime, jms:jme) = grid%xa%v10 (ims:ime, jms:jme)
46 xa2_t2 (ims:ime, jms:jme) = grid%xa%t2 (ims:ime, jms:jme)
47 xa2_q2 (ims:ime, jms:jme) = grid%xa%q2 (ims:ime, jms:jme)
48
49 ! WHY?
50 ! call check_psfc(grid, iv, y)
51
52 call da_transform_xtowtq (grid)
53
54 #ifdef DM_PARALLEL
55 #include "HALO_SFC_XA.inc"
56 #endif
57
58
59 partial_lhs = 0.0
60 pertile_lhs = 0.0
61
62 do n=1, iv%info(synop)%nlocal
63 call da_transform_xtopsfc(grid, iv, synop, iv%synop(:), y%synop(:))
64
65
66 pertile_lhs = pertile_lhs &
67 + y%synop(n)%u * y%synop(n)%u &
68 + y%synop(n)%v * y%synop(n)%v &
69 + y%synop(n)%t * y%synop(n)%t &
70 + y%synop(n)%p * y%synop(n)%p &
71 + y%synop(n)%q * y%synop(n)%q
72
73 if (iv%info(synop)%proc_domain(1,n)) then
74 partial_lhs = partial_lhs &
75 + y%synop(n)%u * y%synop(n)%u &
76 + y%synop(n)%v * y%synop(n)%v &
77 + y%synop(n)%t * y%synop(n)%t &
78 + y%synop(n)%p * y%synop(n)%p &
79 + y%synop(n)%q * y%synop(n)%q
80 end if
81 end do
82
83 !----------------------------------------------------------------------
84 ! [5.0] Perform adjoint operation:
85 !----------------------------------------------------------------------
86
87 call da_zero_x(grid%xa)
88
89 do n=1, iv%info(synop)%nlocal
90 call da_transform_xtopsfc_adj(grid,iv, synop,iv%synop(:),y%synop(:),grid%xa)
91 end do
92
93 call da_transform_xtowtq_adj (grid)
94
95 pertile_rhs = sum(grid%xa%u(ims:ime, jms:jme, kms:kme) * &
96 xa2_u(ims:ime, jms:jme, kms:kme)) + &
97 sum(grid%xa%v(ims:ime, jms:jme, kms:kme) * &
98 xa2_v(ims:ime, jms:jme, kms:kme)) + &
99 sum(grid%xa%t(ims:ime, jms:jme, kms:kme) * &
100 xa2_t(ims:ime, jms:jme, kms:kme)) + &
101 sum(grid%xa%p(ims:ime, jms:jme, kms:kme) * &
102 xa2_p(ims:ime, jms:jme, kms:kme)) + &
103 sum(grid%xa%q(ims:ime, jms:jme, kms:kme) * &
104 xa2_q(ims:ime, jms:jme, kms:kme)) + &
105 sum(grid%xa%psfc(ims:ime, jms:jme) * xa2_psfc(ims:ime, jms:jme))
106
107 !-------------------------------------------------------------------------
108 ! [6.0] Calculate RHS of adjivnt test equation:
109 !-------------------------------------------------------------------------
110
111 partial_rhs = &
112 sum(grid%xa%u(its:ite, jts:jte, kts:kte) * xa2_u(its:ite,jts:jte,kts:kte)) + &
113 sum(grid%xa%v(its:ite, jts:jte, kts:kte) * xa2_v(its:ite,jts:jte,kts:kte)) + &
114 sum(grid%xa%t(its:ite, jts:jte, kts:kte) * xa2_t(its:ite,jts:jte,kts:kte)) + &
115 sum(grid%xa%p(its:ite, jts:jte, kts:kte) * xa2_p(its:ite,jts:jte,kts:kte)) + &
116 sum(grid%xa%q(its:ite, jts:jte, kts:kte) * xa2_q(its:ite,jts:jte,kts:kte)) + &
117 sum(grid%xa%psfc(its:ite, jts:jte) * xa2_psfc(its:ite, jts:jte))
118
119 !-------------------------------------------------------------------------
120 ! [7.0] Print output:
121 !-------------------------------------------------------------------------
122
123 write(unit=stdout, fmt='(A,1pe22.14)') &
124 ' Tile < y, y > = ', pertile_lhs, &
125 ' Tile < x, x_adj > = ', pertile_rhs
126
127 adj_ttl_lhs = wrf_dm_sum_real(partial_lhs)
128 adj_ttl_rhs = wrf_dm_sum_real(partial_rhs)
129 write (unit=stdout,fmt='(A,2F10.2)') &
130 'TEST_COVERAGE_check_sfc_assi_A: adj_ttl_lhs,adj_ttl_rhs = ', &
131 adj_ttl_lhs,adj_ttl_rhs
132 if (rootproc) then
133 write(unit=stdout, fmt='(A,1pe22.14)') &
134 ' Whole Domain < y, y > = ', adj_ttl_lhs
135 write(unit=stdout, fmt='(A,1pe22.14)') &
136 ' Whole Domain < x, x_adj > = ', adj_ttl_rhs
137 end if
138
139 ! recover grid%xa
140 grid%xa%u(ims:ime, jms:jme, kms:kme) = xa2_u(ims:ime, jms:jme, kms:kme)
141 grid%xa%v(ims:ime, jms:jme, kms:kme) = xa2_v(ims:ime, jms:jme, kms:kme)
142 grid%xa%t(ims:ime, jms:jme, kms:kme) = xa2_t(ims:ime, jms:jme, kms:kme)
143 grid%xa%p(ims:ime, jms:jme, kms:kme) = xa2_p(ims:ime, jms:jme, kms:kme)
144 grid%xa%q(ims:ime, jms:jme, kms:kme) = xa2_q(ims:ime, jms:jme, kms:kme)
145
146 grid%xa%psfc(ims:ime, jms:jme) = xa2_psfc(ims:ime, jms:jme)
147 grid%xa%tgrn(ims:ime, jms:jme) = xa2_tgrn(ims:ime, jms:jme)
148 grid%xa%u10 (ims:ime, jms:jme) = xa2_u10 (ims:ime, jms:jme)
149 grid%xa%v10 (ims:ime, jms:jme) = xa2_v10 (ims:ime, jms:jme)
150 grid%xa%t2 (ims:ime, jms:jme) = xa2_t2 (ims:ime, jms:jme)
151 grid%xa%q2 (ims:ime, jms:jme) = xa2_q2 (ims:ime, jms:jme)
152
153 call wrf_shutdown
154
155 if (trace_use) call da_trace_exit("da_check_sfc_assi")
156
157 end subroutine da_check_sfc_assi
158
159
160