var/da/da_test/da_check_psfc.inc

   1 subroutine da_check_psfc(grid, iv, y)
   2
   3    !-----------------------------------------------------------------------
   4    ! Purpose: TBD
   5    !-----------------------------------------------------------------------
   6
   7    implicit none
   8
   9    type (domain),  intent(inout)     :: grid
  10    type (iv_type), intent(inout)     :: iv  ! ob. increment vector.
  11    type (y_type),  intent(inout)     :: y   ! residual
  12
  13    real                           :: adj_ttl_lhs   ! < y, y >
  14    real                           :: adj_ttl_rhs   ! < x, x_adj >
  15
  16    real                           :: partial_lhs   ! < y, y >
  17    real                           :: partial_rhs   ! < x, x_adj >
  18
  19    real                           :: pertile_lhs   ! < y, y >
  20    real                           :: pertile_rhs   ! < x, x_adj >
  21
  22    integer                        :: n
  23
  24    real, dimension(ims:ime, jms:jme) :: xa2_u10, xa2_v10, xa2_t2, &
  25                                         xa2_q2, xa2_psfc
  26
  27    if (trace_use) call da_trace_entry("da_check_psfc")
  28
  29    write(unit=stdout, fmt='(/3a,i6/a)') &
  30         'File: ', __FILE__, ', line:', __LINE__, &
  31         'Adjoint Test Results:'
  32
  33    ! save input
  34
  35    xa2_psfc(ims:ime, jms:jme) = grid%xa%p   (ims:ime, jms:jme, kts)
  36    xa2_u10 (ims:ime, jms:jme) = grid%xa%u10 (ims:ime, jms:jme)
  37    xa2_v10 (ims:ime, jms:jme) = grid%xa%v10 (ims:ime, jms:jme)
  38    xa2_t2  (ims:ime, jms:jme) = grid%xa%t2  (ims:ime, jms:jme)
  39    xa2_q2  (ims:ime, jms:jme) = grid%xa%q2  (ims:ime, jms:jme)
  40
  41    !----------------------------------------------------------------------
  42
  43    partial_lhs = 0.0
  44    pertile_lhs = 0.0
  45
  46    do n=1, iv%info(synop)%nlocal
  47       call da_transform_xtopsfc(grid, iv, synop, iv%synop(:), y%synop(:))
  48       pertile_lhs = pertile_lhs &
  49                   + y%synop(n)%u * y%synop(n)%u &
  50                   + y%synop(n)%v * y%synop(n)%v &
  51                   + y%synop(n)%t * y%synop(n)%t &
  52                   + y%synop(n)%p * y%synop(n)%p &
  53                   + y%synop(n)%q * y%synop(n)%q
  54
  55       if (iv%info(synop)%proc_domain(1,n)) then
  56          partial_lhs = partial_lhs &
  57                      + y%synop(n)%u * y%synop(n)%u &
  58                      + y%synop(n)%v * y%synop(n)%v &
  59                      + y%synop(n)%t * y%synop(n)%t &
  60                      + y%synop(n)%p * y%synop(n)%p &
  61                      + y%synop(n)%q * y%synop(n)%q
  62       end if
  63    end do
  64
  65    !-------------------------------------------------------------------------
  66    ! [5.0] Perform adjoint operation:
  67    !-------------------------------------------------------------------------
  68
  69    grid%xa%psfc(ims:ime, jms:jme) = 0.0
  70    grid%xa%tgrn(ims:ime, jms:jme) = 0.0
  71    grid%xa%u10 (ims:ime, jms:jme) = 0.0
  72    grid%xa%v10 (ims:ime, jms:jme) = 0.0
  73    grid%xa%t2  (ims:ime, jms:jme) = 0.0
  74    grid%xa%q2  (ims:ime, jms:jme) = 0.0
  75
  76    do n=1, iv%info(synop)%nlocal
  77       call da_transform_xtopsfc_adj(grid,iv,synop,iv%synop(:),y%synop(:),grid%xa)
  78    end do
  79
  80    pertile_rhs = sum(grid%xa%u10 (ims:ime, jms:jme) * xa2_u10 (ims:ime, jms:jme)) &
  81                + sum(grid%xa%v10 (ims:ime, jms:jme) * xa2_v10 (ims:ime, jms:jme)) &
  82                + sum(grid%xa%t2  (ims:ime, jms:jme) * xa2_t2  (ims:ime, jms:jme)) &
  83                + sum(grid%xa%q2  (ims:ime, jms:jme) * xa2_q2  (ims:ime, jms:jme)) &
  84                + sum(grid%xa%psfc(ims:ime, jms:jme) * xa2_psfc(ims:ime, jms:jme))
  85
  86    partial_rhs = sum(grid%xa%u10 (its:ite, jts:jte) * xa2_u10 (its:ite, jts:jte)) &
  87                + sum(grid%xa%v10 (its:ite, jts:jte) * xa2_v10 (its:ite, jts:jte)) &
  88                + sum(grid%xa%t2  (its:ite, jts:jte) * xa2_t2  (its:ite, jts:jte)) &
  89                + sum(grid%xa%q2  (its:ite, jts:jte) * xa2_q2  (its:ite, jts:jte)) &
  90                + sum(grid%xa%psfc(its:ite, jts:jte) * xa2_psfc(its:ite, jts:jte))
  91
  92    !----------------------------------------------------------------------
  93    ! [6.0] Calculate RHS of adjoint test equation:
  94    !----------------------------------------------------------------------
  95
  96    !----------------------------------------------------------------------
  97    ! [7.0] Print output:
  98    !----------------------------------------------------------------------
  99
 100    write(unit=stdout, fmt='(A,1pe22.14)') &
 101       ' Tile < y, y     > = ', pertile_lhs, &
 102       ' Tile < x, x_adj > = ', pertile_rhs
 103
 104    adj_ttl_lhs = wrf_dm_sum_real(partial_lhs)
 105    adj_ttl_rhs = wrf_dm_sum_real(partial_rhs)
 106    write (unit=stdout,fmt='(A,2F10.2)') &
 107       'TEST_COVERAGE_check_sfc_assi_B:  adj_ttl_lhs,adj_ttl_rhs = ', &
 108       adj_ttl_lhs,adj_ttl_rhs
 109    if (rootproc) then
 110       write(unit=stdout, fmt='(A,1pe22.14)') ' Whole Domain < y, y     > = ', &
 111          adj_ttl_lhs
 112       write(unit=stdout, fmt='(A,1pe22.14)') ' Whole Domain < x, x_adj > = ', &
 113          adj_ttl_rhs
 114    end if
 115
 116    ! recover
 117    grid%xa%psfc(ims:ime, jms:jme) = xa2_psfc(ims:ime, jms:jme)
 118    grid%xa%u10 (ims:ime, jms:jme) = xa2_u10 (ims:ime, jms:jme)
 119    grid%xa%v10 (ims:ime, jms:jme) = xa2_v10 (ims:ime, jms:jme)
 120    grid%xa%t2  (ims:ime, jms:jme) = xa2_t2  (ims:ime, jms:jme)
 121    grid%xa%q2  (ims:ime, jms:jme) = xa2_q2  (ims:ime, jms:jme)
 122
 123    if (trace_use) call da_trace_exit("da_check_psfc")
 124
 125 end subroutine da_check_psfc
 126
 127