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