da_jo_and_grady_sound.inc

1 subroutine da_jo_and_grady_sound(iv, re, jo, jo_grad_y)
2 
3    !-----------------------------------------------------------------------
4    ! Purpose: TBD
5    !-----------------------------------------------------------------------
6 
7    implicit none
8 
9    type (ob_type), intent(in ) :: iv         ! Innovation vector.
10    type (y_type),  intent(in ) :: re         ! Residual vector.
11    type (y_type),  intent(inout) :: jo_grad_y  ! Grad_y(Jo)
12    type (jo_type), intent(inout) :: jo         ! Obs cost function.
13 
14    integer                      :: n, k
15    ! the following "global" objects are used only when testing
16    type (ob_type) :: iv_glob         ! Global Innovation vector (O-B).
17    type (y_type)  :: re_glob         ! Global Residual vector (O-A).
18    type (y_type)  :: jo_grad_y_glob  ! Global Grad_y(Jo)
19 
20    jo % sound_u = 0.0
21    jo % sound_v = 0.0
22    jo % sound_t = 0.0
23    jo % sound_q = 0.0
24 
25    if (testing_dm_exact) then
26       if (iv%num_sound_glo == 0) return
27    else
28       if (iv%num_sound < 0) return
29    end if
30 
31    do n=1, iv%num_sound
32        do k=1, iv%sound(n)%info%levels
33           jo_grad_y%sound(n)%u(k) = -re%sound(n)%u(k) / &
34                                        (iv%sound(n)%u(k)%error * &
35                                         iv%sound(n)%u(k)%error)
36           jo_grad_y%sound(n)%v(k) = -re%sound(n)%v(k) / &
37                                       (iv%sound(n)%v(k)%error * &
38                                         iv%sound(n)%v(k)%error)
39           jo_grad_y%sound(n)%t(k) = -re%sound(n)%t(k) / &
40                                       (iv%sound(n)%t(k)%error * &
41                                         iv%sound(n)%t(k)%error)
42           jo_grad_y%sound(n)%q(k) = -re%sound(n)%q(k) / &
43                                       (iv%sound(n)%q(k)%error * &
44                                         iv%sound(n)%q(k)%error)
45       end do
46    end do
47 
48    ! Bitwise-exact reduction preserves operation order of serial code for 
49    ! testing, at the cost of much-increased run-time.  Turn it off when not 
50    ! testing.  This will always be .false. for a serial or 1-MPI-process run.  
51    if (testing_dm_exact) then
52       ! collect all obs in serial order and allocate global objects
53       call da_to_global_sound(iv,      re,      jo_grad_y, &
54                            iv_glob, re_glob, jo_grad_y_glob)
55       ! perform remaining computations
56       call da_jo_sound_uvtq(iv_glob, re_glob, jo_grad_y_glob, jo)
57       ! free global objects
58       call da_deallocate_global_sound(iv_glob, re_glob, jo_grad_y_glob)
59    else
60       ! perform remaining computations
61       call da_jo_sound_uvtq(iv, re, jo_grad_y, jo)
62    end if
63 
64    jo % sound_u = 0.5 * jo % sound_u
65    jo % sound_v = 0.5 * jo % sound_v
66    jo % sound_t = 0.5 * jo % sound_t
67    jo % sound_q = 0.5 * jo % sound_q
68 
69 end subroutine da_jo_and_grady_sound
70 
71