da_check_vtoy_adjoint.inc
References to this file elsewhere.
1 subroutine da_check_vtoy_adjoint(cv_size,grid, config_flags, vp, vv, &
2 xb, xbx, xp, be, ep, xa, iv, y)
3
4 !---------------------------------------------------------------------------
5 ! Purpose: Perform V To Y Adjoint transform test
6 !
7 ! Method: Perform adjoint test on complete transform: <y,y> = <v_adj,v>.!
8 !---------------------------------------------------------------------------
9
10 implicit none
11
12 integer, intent(in) :: cv_size
13 type(grid_config_rec_type), intent(inout) :: config_flags
14 type(domain), intent(inout) :: grid
15
16 type (vp_type), intent(inout) :: vv ! Grdipt/EOF CV.
17 type (vp_type), intent(inout) :: vp ! Grdipt/level CV.
18 type (xb_type), intent(in) :: xb ! first guess (local).
19 type (xbx_type), intent(in) :: xbx ! Header & non-gridded vars.
20 type (xpose_type), intent(inout) :: xp ! Dimensions and xpose buffers.
21 type (be_type), intent(in) :: be ! background error structure.
22 type (ep_type), intent(in) :: ep ! ensemble perturbation structure.
23
24 type (x_type), intent(out) :: xa ! analysis increments (local).
25 type (ob_type), intent(inout) :: iv ! ob. increment vector.
26 type (y_type), intent(inout) :: y ! y = h (xa)
27
28 real, dimension(1:cv_size) :: cv ! Test control variable.
29 real, dimension(1:cv_size) :: cv_2
30
31 real :: adj_sum_lhs ! < y, y >
32 real :: adj_rhs,adj_sum_rhs ! < v, v_adj >
33 real :: partial_lhs ! < y, y >
34 real :: pertile_lhs ! < y, y >
35
36 integer :: cg_jcdf
37
38 write(unit=*, fmt='(/a/a)') &
39 ' da_check_vtoy_adjoint:',&
40 '---------------------------------------'
41
42
43 call random_number(cv(:))
44 cv(:) = cv(:) - 0.5
45
46 cv_2(1:cv_size) = cv(1:cv_size)
47
48 call da_zero_x(xa)
49 call da_zero_vp_type(vp)
50 call da_zero_vp_type(vv)
51
52 call da_transform_vtoy(cv_size, be, ep, cv, iv, vp, vv, xa, xb, xbx, xp, y, &
53 grid, config_flags)
54
55 !-------------------------------------------------------------------------
56 ! [3.0] Calculate LHS of adjoint test equation and
57 ! Rescale input to adjoint routine :
58 !-------------------------------------------------------------------------
59
60 call da_get_y_lhs_value(iv, y, partial_lhs, pertile_lhs, adj_sum_lhs)
61
62
63 cv = 0.
64 cg_jcdf = 1
65
66 ! call da_zero_vp_type(vp)
67 ! call da_zero_vp_type(vv)
68 ! call da_zero_x(xa)
69
70 call da_transform_vtoy_adj(0,cv_size, be, ep, cv, iv, vp, vv, xa, xb, xbx, &
71 xp, y, &
72 grid, config_flags, cg_jcdf)
73
74 adj_rhs = sum(cv(1:cv_size) * cv_2(1:cv_size))
75
76 !-------------------------------------------------------------------------
77 ! Print output:
78 !-------------------------------------------------------------------------
79
80 #ifdef DM_PARALLEL
81 if (global) then
82 adj_sum_rhs = adj_rhs
83 else
84 call mpi_allreduce(adj_rhs, adj_sum_rhs, 1, true_mpi_real, mpi_sum, &
85 comm, ierr)
86 end if
87 #else
88 adj_sum_rhs = adj_rhs
89 adj_sum_lhs = partial_lhs
90 #endif
91
92 #ifdef DM_PARALLEL
93 if (rootproc) then
94 write(unit=stdout, fmt='(A,1pe22.14)') &
95 'Whole Domain < y, y > = ', adj_sum_lhs
96 write(unit=stdout, fmt='(A,1pe22.14)') &
97 'Whole Domain < v, v_adj > = ', adj_sum_rhs
98 end if
99 #else
100 write(unit=stdout, fmt='(A,1pe22.14)') &
101 'Whole Domain < y, y > = ', adj_sum_lhs
102 write(unit=stdout, fmt='(A,1pe22.14)') &
103 'Whole Domain < v, v_adj > = ', adj_sum_rhs
104 #endif
105
106
107 end subroutine da_check_vtoy_adjoint
108
109