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 (iv_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 (iv_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    if (trace_use_dull) call da_trace_entry("da_jo_and_grady_sound")
21 
22    jo % sound_u = 0.0
23    jo % sound_v = 0.0
24    jo % sound_t = 0.0
25    jo % sound_q = 0.0
26 
27    if (test_dm_exact) then
28       if (iv%info(sound)%ntotal == 0) return
29    else
30       if (iv%info(sound)%nlocal < 1) return
31    end if
32 
33    do n=1, iv%info(sound)%nlocal
34        do k=1, iv%info(sound)%levels(n)
35           jo_grad_y%sound(n)%u(k) = -re%sound(n)%u(k) / (iv%sound(n)%u(k)%error * iv%sound(n)%u(k)%error)
36           jo_grad_y%sound(n)%v(k) = -re%sound(n)%v(k) / (iv%sound(n)%v(k)%error * iv%sound(n)%v(k)%error)
37           jo_grad_y%sound(n)%t(k) = -re%sound(n)%t(k) / (iv%sound(n)%t(k)%error * iv%sound(n)%t(k)%error)
38           jo_grad_y%sound(n)%q(k) = -re%sound(n)%q(k) / (iv%sound(n)%q(k)%error * iv%sound(n)%q(k)%error)
39       end do
40    end do
41 
42    ! Bitwise-exact reduction preserves operation order of serial code for 
43    ! testing, at the cost of much-increased run-time.  Turn it off when not 
44    ! testing.  This will always be .false. for a serial or 1-MPI-process run.  
45    if (test_dm_exact) then
46       ! collect all obs in serial order and allocate global objects
47       call da_to_global_sound(iv, re, jo_grad_y, iv_glob, re_glob, jo_grad_y_glob)
48       ! perform remaining computations
49       call da_jo_sound_uvtq(iv_glob, re_glob, jo_grad_y_glob, jo)
50       ! free global objects
51       call da_deallocate_global_sound(iv_glob, re_glob, jo_grad_y_glob)
52    else
53       ! perform remaining computations
54       call da_jo_sound_uvtq(iv, re, jo_grad_y, jo)
55    end if
56 
57    jo % sound_u = 0.5 * jo % sound_u
58    jo % sound_v = 0.5 * jo % sound_v
59    jo % sound_t = 0.5 * jo % sound_t
60    jo % sound_q = 0.5 * jo % sound_q
61 
62    if (trace_use_dull) call da_trace_exit("da_jo_and_grady_sound")
63 
64 end subroutine da_jo_and_grady_sound
65 
66