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