da_check_psfc.inc
References to this file elsewhere.
1 subroutine da_check_psfc(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 ! residual
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) :: xa2_u10, xa2_v10, xa2_t2, &
27 xa2_q2, xa2_psfc
28
29 if (trace_use) call da_trace_entry("da_check_psfc")
30
31 write(unit=stdout, fmt='(/3a,i6/a)') &
32 'File: ', __FILE__, ', line:', __LINE__, &
33 'Adjoint Test Results:'
34
35 ! save input
36
37 xa2_psfc(ims:ime, jms:jme) = xa%p (ims:ime, jms:jme, kts)
38 xa2_u10 (ims:ime, jms:jme) = xa%u10 (ims:ime, jms:jme)
39 xa2_v10 (ims:ime, jms:jme) = xa%v10 (ims:ime, jms:jme)
40 xa2_t2 (ims:ime, jms:jme) = xa%t2 (ims:ime, jms:jme)
41 xa2_q2 (ims:ime, jms:jme) = xa%q2 (ims:ime, jms:jme)
42
43 !----------------------------------------------------------------------
44
45 partial_lhs = 0.0
46 pertile_lhs = 0.0
47
48 do n=1, iv%num_synop
49 call da_transform_xtopsfc(xb, xa, xp, iv%synop(n), y%synop(n))
50 pertile_lhs = pertile_lhs &
51 + y%synop(n)%u * y%synop(n)%u &
52 + y%synop(n)%v * y%synop(n)%v &
53 + y%synop(n)%t * y%synop(n)%t &
54 + y%synop(n)%p * y%synop(n)%p &
55 + y%synop(n)%q * y%synop(n)%q
56
57 if (iv%synop(n)%loc%proc_domain) then
58 partial_lhs = partial_lhs &
59 + y%synop(n)%u * y%synop(n)%u &
60 + y%synop(n)%v * y%synop(n)%v &
61 + y%synop(n)%t * y%synop(n)%t &
62 + y%synop(n)%p * y%synop(n)%p &
63 + y%synop(n)%q * y%synop(n)%q
64 end if
65 end do
66
67 !-------------------------------------------------------------------------
68 ! [5.0] Perform adjivnt operation:
69 !-------------------------------------------------------------------------
70
71 xa%psfc(ims:ime, jms:jme) = 0.0
72 xa%tgrn(ims:ime, jms:jme) = 0.0
73 xa%u10 (ims:ime, jms:jme) = 0.0
74 xa%v10 (ims:ime, jms:jme) = 0.0
75 xa%t2 (ims:ime, jms:jme) = 0.0
76 xa%q2 (ims:ime, jms:jme) = 0.0
77
78 do n=1, iv%num_synop
79 call da_transform_xtopsfc_adj(xb,xp,iv%synop(n),y%synop(n),xa)
80 end do
81
82 pertile_rhs = sum(xa%u10 (ims:ime, jms:jme) * xa2_u10 (ims:ime, jms:jme)) &
83 + sum(xa%v10 (ims:ime, jms:jme) * xa2_v10 (ims:ime, jms:jme)) &
84 + sum(xa%t2 (ims:ime, jms:jme) * xa2_t2 (ims:ime, jms:jme)) &
85 + sum(xa%q2 (ims:ime, jms:jme) * xa2_q2 (ims:ime, jms:jme)) &
86 + sum(xa%psfc(ims:ime, jms:jme) * xa2_psfc(ims:ime, jms:jme))
87
88 partial_rhs = sum(xa%u10 (its:ite, jts:jte) * xa2_u10 (its:ite, jts:jte)) &
89 + sum(xa%v10 (its:ite, jts:jte) * xa2_v10 (its:ite, jts:jte)) &
90 + sum(xa%t2 (its:ite, jts:jte) * xa2_t2 (its:ite, jts:jte)) &
91 + sum(xa%q2 (its:ite, jts:jte) * xa2_q2 (its:ite, jts:jte)) &
92 + sum(xa%psfc(its:ite, jts:jte) * xa2_psfc(its:ite, jts:jte))
93
94 !----------------------------------------------------------------------
95 ! [6.0] Calculate RHS of adjivnt test equation:
96 !----------------------------------------------------------------------
97
98 !----------------------------------------------------------------------
99 ! [7.0] Print output:
100 !----------------------------------------------------------------------
101
102 write(unit=stdout, fmt='(A,1pe22.14)') &
103 ' Tile < y, y > = ', pertile_lhs, &
104 ' Tile < x, x_adj > = ', pertile_rhs
105
106 adj_ttl_lhs = wrf_dm_sum_real(partial_lhs)
107 adj_ttl_rhs = wrf_dm_sum_real(partial_rhs)
108 write (unit=stdout,fmt='(A,2F10.2)') &
109 'TEST_COVERAGE_check_sfc_assi_B: adj_ttl_lhs,adj_ttl_rhs = ', &
110 adj_ttl_lhs,adj_ttl_rhs
111 if (rootproc) then
112 write(unit=stdout, fmt='(A,1pe22.14)') ' Whole Domain < y, y > = ', &
113 adj_ttl_lhs
114 write(unit=stdout, fmt='(A,1pe22.14)') ' Whole Domain < x, x_adj > = ', &
115 adj_ttl_rhs
116 end if
117
118 ! recover
119 xa%psfc(ims:ime, jms:jme) = xa2_psfc(ims:ime, jms:jme)
120 xa%u10 (ims:ime, jms:jme) = xa2_u10 (ims:ime, jms:jme)
121 xa%v10 (ims:ime, jms:jme) = xa2_v10 (ims:ime, jms:jme)
122 xa%t2 (ims:ime, jms:jme) = xa2_t2 (ims:ime, jms:jme)
123 xa%q2 (ims:ime, jms:jme) = xa2_q2 (ims:ime, jms:jme)
124
125 if (trace_use) call da_trace_exit("da_check_psfc")
126
127 end subroutine da_check_psfc
128
129