var/da/da_synop/da_jo_and_grady_synop.inc

   1 subroutine da_jo_and_grady_synop(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
  16    ! the following "global" objects are used only when testing
  17    type (iv_type) :: iv_glob         ! Global Innovation vector (O-B).
  18    type (y_type)  :: re_glob         ! Global Residual vector (O-A).
  19    type (y_type)  :: jo_grad_y_glob  ! Global Grad_y(Jo)
  20
  21    if (trace_use_dull) call da_trace_entry("da_jo_and_grady_synop")
  22
  23    jo % synop_u = 0.0
  24    jo % synop_v = 0.0
  25    jo % synop_t = 0.0
  26    jo % synop_p = 0.0
  27    jo % synop_q = 0.0
  28
  29    if (test_dm_exact) then
  30       if (iv%info(synop)%ntotal == 0) then
  31          if (trace_use_dull) call da_trace_exit("da_jo_and_grady_synop")
  32          return
  33       end if
  34    else
  35       if (iv%info(synop)%nlocal < 1) then
  36          if (trace_use_dull) call da_trace_exit("da_jo_and_grady_synop")
  37          return
  38       end if
  39    end if
  40
  41    do n=1, iv%info(synop)%nlocal
  42       jo_grad_y%synop(n)%u = -re%synop(n)%u / (iv%synop(n)%u%error * iv%synop(n)%u%error)
  43       jo_grad_y%synop(n)%v = -re%synop(n)%v / (iv%synop(n)%v%error * iv%synop(n)%v%error)
  44       jo_grad_y%synop(n)%t = -re%synop(n)%t / (iv%synop(n)%t%error * iv%synop(n)%t%error)
  45       jo_grad_y%synop(n)%p = -re%synop(n)%p / (iv%synop(n)%p%error * iv%synop(n)%p%error)
  46       jo_grad_y%synop(n)%q = -re%synop(n)%q / (iv%synop(n)%q%error * iv%synop(n)%q%error)
  47    end do
  48
  49    ! Bitwise-exact reduction preserves operation order of serial code for
  50    ! testing, at the cost of much-increased run-time.  Turn it off when not
  51    ! testing.  This will always be .false. for a serial run.
  52    if (test_dm_exact) then
  53       ! collect all obs in serial order and allocate global objects
  54       call da_to_global_synop(iv, re, jo_grad_y, iv_glob, re_glob, jo_grad_y_glob)
  55       ! perform remaining computations
  56       call da_jo_synop_uvtq(iv_glob, re_glob, jo_grad_y_glob, jo)
  57       ! free global objects
  58       call da_deallocate_global_synop(iv_glob, re_glob, jo_grad_y_glob)
  59    else
  60       ! perform remaining computations
  61       call da_jo_synop_uvtq(iv, re, jo_grad_y, jo)
  62    end if
  63
  64    jo % synop_u = 0.5 * jo % synop_u
  65    jo % synop_v = 0.5 * jo % synop_v
  66    jo % synop_t = 0.5 * jo % synop_t
  67    jo % synop_p = 0.5 * jo % synop_p
  68    jo % synop_q = 0.5 * jo % synop_q
  69
  70    if (trace_use_dull) call da_trace_exit("da_jo_and_grady_synop")
  71
  72 end subroutine da_jo_and_grady_synop
  73
  74