var/da/da_tamdar/da_jo_and_grady_tamdar.inc

   1 subroutine da_jo_and_grady_tamdar(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_tamdar")
  21
  22    jo % tamdar_u = 0.0
  23    jo % tamdar_v = 0.0
  24    jo % tamdar_t = 0.0
  25    jo % tamdar_q = 0.0
  26
  27    if (test_dm_exact) then
  28       if (iv%info(tamdar)%ntotal == 0) then
  29          if (trace_use_dull) call da_trace_exit("da_jo_and_grady_tamdar")
  30          return
  31       end if
  32    else
  33       if (iv%info(tamdar)%nlocal < 1) then
  34          if (trace_use_dull) call da_trace_exit("da_jo_and_grady_tamdar")
  35          return
  36       end if
  37    end if
  38
  39    do n=1, iv%info(tamdar)%nlocal
  40        do k=1, iv%info(tamdar)%levels(n)
  41           jo_grad_y%tamdar(n)%u(k) = -re%tamdar(n)%u(k) / (iv%tamdar(n)%u(k)%error * iv%tamdar(n)%u(k)%error)
  42           jo_grad_y%tamdar(n)%v(k) = -re%tamdar(n)%v(k) / (iv%tamdar(n)%v(k)%error * iv%tamdar(n)%v(k)%error)
  43           jo_grad_y%tamdar(n)%t(k) = -re%tamdar(n)%t(k) / (iv%tamdar(n)%t(k)%error * iv%tamdar(n)%t(k)%error)
  44           jo_grad_y%tamdar(n)%q(k) = -re%tamdar(n)%q(k) / (iv%tamdar(n)%q(k)%error * iv%tamdar(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 (test_dm_exact) then
  52       ! perform remaining computations
  53       call da_jo_tamdar_uvtq(iv_glob, re_glob, jo_grad_y_glob, jo)
  54    else
  55       ! perform remaining computations
  56       call da_jo_tamdar_uvtq(iv, re, jo_grad_y, jo)
  57    end if
  58
  59    jo % tamdar_u = 0.5 * jo % tamdar_u
  60    jo % tamdar_v = 0.5 * jo % tamdar_v
  61    jo % tamdar_t = 0.5 * jo % tamdar_t
  62    jo % tamdar_q = 0.5 * jo % tamdar_q
  63
  64    if (trace_use_dull) call da_trace_exit("da_jo_and_grady_tamdar")
  65
  66 end subroutine da_jo_and_grady_tamdar
  67
  68