da_jo_and_grady_sonde_sfc.inc

1 subroutine da_jo_and_grady_sonde_sfc( 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
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_sonde_sfc")
21 
22    jo % sonde_sfc_u = 0.0
23    jo % sonde_sfc_v = 0.0
24    jo % sonde_sfc_t = 0.0
25    jo % sonde_sfc_p = 0.0
26    jo % sonde_sfc_q = 0.0
27 
28    if (test_dm_exact) then
29       if (iv%info(sound)%ntotal == 0) return
30    else
31       if (iv%info(sound)%nlocal < 1) return
32    end if
33 
34    do n=1, iv%info(sound)%nlocal
35       jo_grad_y%sonde_sfc(n)%u = -re%sonde_sfc(n)%u / (iv%sonde_sfc(n)%u%error * iv%sonde_sfc(n)%u%error)
36       jo_grad_y%sonde_sfc(n)%v = -re%sonde_sfc(n)%v / (iv%sonde_sfc(n)%v%error * iv%sonde_sfc(n)%v%error)
37       jo_grad_y%sonde_sfc(n)%t = -re%sonde_sfc(n)%t / (iv%sonde_sfc(n)%t%error * iv%sonde_sfc(n)%t%error)
38       jo_grad_y%sonde_sfc(n)%p = -re%sonde_sfc(n)%p / (iv%sonde_sfc(n)%p%error * iv%sonde_sfc(n)%p%error)
39       jo_grad_y%sonde_sfc(n)%q = -re%sonde_sfc(n)%q / (iv%sonde_sfc(n)%q%error * iv%sonde_sfc(n)%q%error)
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 run.
45    if (test_dm_exact) then
46       ! collect all obs in serial order and allocate global objects
47       call da_to_global_sonde_sfc( iv, re, jo_grad_y, iv_glob, re_glob, jo_grad_y_glob)
48       ! perform remaining computations
49       call da_jo_sonde_sfc_uvtq( iv_glob, re_glob, jo_grad_y_glob, jo)
50       ! free global objects
51       call da_deallocate_global_sonde_sfc( iv_glob, re_glob, jo_grad_y_glob)
52    else
53       ! perform remaining computations
54       call da_jo_sonde_sfc_uvtq( iv, re, jo_grad_y, jo)
55    end if
56 
57    jo % sonde_sfc_u = 0.5 * jo % sonde_sfc_u
58    jo % sonde_sfc_v = 0.5 * jo % sonde_sfc_v
59    jo % sonde_sfc_t = 0.5 * jo % sonde_sfc_t
60    jo % sonde_sfc_p = 0.5 * jo % sonde_sfc_p
61    jo % sonde_sfc_q = 0.5 * jo % sonde_sfc_q
62 
63    if (trace_use_dull) call da_trace_exit("da_jo_and_grady_sonde_sfc")
64 
65 end subroutine da_jo_and_grady_sonde_sfc
66 
67