var/da/da_test/da_check_sfc_assi.inc

   1 subroutine da_check_sfc_assi(grid, iv, y)
   2
   3    !-----------------------------------------------------------------------
   4    ! Purpose: TBD
   5    !-----------------------------------------------------------------------
   6
   7    implicit none
   8
   9    type (domain), intent(inout)     :: grid
  10
  11    type (iv_type),    intent(inout) :: iv    ! ob. increment vector.
  12    type (y_type),     intent(inout) :: y     ! y = h (grid%xa)
  13
  14    real                           :: adj_ttl_lhs   ! < y, y >
  15    real                           :: adj_ttl_rhs   ! < x, x_adj >
  16
  17    real                           :: partial_lhs   ! < y, y >
  18    real                           :: partial_rhs   ! < x, x_adj >
  19
  20    real                           :: pertile_lhs   ! < y, y >
  21    real                           :: pertile_rhs   ! < x, x_adj >
  22
  23    integer                        :: n
  24
  25    real, dimension(ims:ime, jms:jme, kms:kme) :: xa2_u, xa2_v, xa2_t, &
  26                                                  xa2_p, xa2_q
  27
  28    real, dimension(ims:ime, jms:jme)          :: xa2_u10, xa2_v10, xa2_t2, &
  29                                                  xa2_q2, xa2_tgrn, xa2_psfc
  30
  31
  32    if (trace_use) call da_trace_entry("da_check_sfc_assi")
  33
  34    call da_message((/"check_sfc_assi: Adjoint Test Results:"/))
  35
  36    xa2_u(ims:ime, jms:jme, kms:kme) = grid%xa%u(ims:ime, jms:jme, kms:kme)
  37    xa2_v(ims:ime, jms:jme, kms:kme) = grid%xa%v(ims:ime, jms:jme, kms:kme)
  38    xa2_t(ims:ime, jms:jme, kms:kme) = grid%xa%t(ims:ime, jms:jme, kms:kme)
  39    xa2_p(ims:ime, jms:jme, kms:kme) = grid%xa%p(ims:ime, jms:jme, kms:kme)
  40    xa2_q(ims:ime, jms:jme, kms:kme) = grid%xa%q(ims:ime, jms:jme, kms:kme)
  41
  42    xa2_psfc(ims:ime, jms:jme) = grid%xa%psfc(ims:ime, jms:jme)
  43    xa2_tgrn(ims:ime, jms:jme) = grid%xa%tgrn(ims:ime, jms:jme)
  44    xa2_u10 (ims:ime, jms:jme) = grid%xa%u10 (ims:ime, jms:jme)
  45    xa2_v10 (ims:ime, jms:jme) = grid%xa%v10 (ims:ime, jms:jme)
  46    xa2_t2  (ims:ime, jms:jme) = grid%xa%t2  (ims:ime, jms:jme)
  47    xa2_q2  (ims:ime, jms:jme) = grid%xa%q2  (ims:ime, jms:jme)
  48
  49    ! WHY?
  50    ! call check_psfc(grid, iv, y)
  51
  52    call da_transform_xtowtq (grid)
  53
  54 #ifdef DM_PARALLEL
  55 #include "HALO_SFC_XA.inc"
  56 #endif
  57
  58
  59    partial_lhs = 0.0
  60    pertile_lhs = 0.0
  61
  62    do n=1, iv%info(synop)%nlocal
  63       call da_transform_xtopsfc(grid, iv, synop, iv%synop(:), y%synop(:))
  64
  65
  66       pertile_lhs = pertile_lhs &
  67                   + y%synop(n)%u * y%synop(n)%u &
  68                   + y%synop(n)%v * y%synop(n)%v &
  69                   + y%synop(n)%t * y%synop(n)%t &
  70                   + y%synop(n)%p * y%synop(n)%p &
  71                   + y%synop(n)%q * y%synop(n)%q
  72
  73       if (iv%info(synop)%proc_domain(1,n)) then
  74          partial_lhs = partial_lhs &
  75                      + y%synop(n)%u * y%synop(n)%u &
  76                      + y%synop(n)%v * y%synop(n)%v &
  77                      + y%synop(n)%t * y%synop(n)%t &
  78                      + y%synop(n)%p * y%synop(n)%p &
  79                      + y%synop(n)%q * y%synop(n)%q
  80       end if
  81    end do
  82
  83    !----------------------------------------------------------------------
  84    ! [5.0] Perform adjoint operation:
  85    !----------------------------------------------------------------------
  86
  87    call da_zero_x(grid%xa)
  88
  89    do n=1, iv%info(synop)%nlocal
  90       call da_transform_xtopsfc_adj(grid,iv, synop,iv%synop(:),y%synop(:),grid%xa)
  91    end do
  92
  93    call da_transform_xtowtq_adj (grid)
  94
  95    pertile_rhs = sum(grid%xa%u(ims:ime, jms:jme, kms:kme) * &
  96       xa2_u(ims:ime, jms:jme, kms:kme)) + &
  97                  sum(grid%xa%v(ims:ime, jms:jme, kms:kme) * &
  98       xa2_v(ims:ime, jms:jme, kms:kme)) + &
  99                  sum(grid%xa%t(ims:ime, jms:jme, kms:kme) * &
 100       xa2_t(ims:ime, jms:jme, kms:kme)) + &
 101                  sum(grid%xa%p(ims:ime, jms:jme, kms:kme) * &
 102       xa2_p(ims:ime, jms:jme, kms:kme)) + &
 103                  sum(grid%xa%q(ims:ime, jms:jme, kms:kme) * &
 104       xa2_q(ims:ime, jms:jme, kms:kme)) + &
 105                  sum(grid%xa%psfc(ims:ime, jms:jme) * xa2_psfc(ims:ime, jms:jme))
 106
 107    !-------------------------------------------------------------------------
 108    ! [6.0] Calculate RHS of adjivnt test equation:
 109    !-------------------------------------------------------------------------
 110
 111    partial_rhs = &
 112       sum(grid%xa%u(its:ite, jts:jte, kts:kte) * xa2_u(its:ite,jts:jte,kts:kte)) + &
 113       sum(grid%xa%v(its:ite, jts:jte, kts:kte) * xa2_v(its:ite,jts:jte,kts:kte)) + &
 114       sum(grid%xa%t(its:ite, jts:jte, kts:kte) * xa2_t(its:ite,jts:jte,kts:kte)) + &
 115       sum(grid%xa%p(its:ite, jts:jte, kts:kte) * xa2_p(its:ite,jts:jte,kts:kte)) + &
 116       sum(grid%xa%q(its:ite, jts:jte, kts:kte) * xa2_q(its:ite,jts:jte,kts:kte)) + &
 117       sum(grid%xa%psfc(its:ite, jts:jte) * xa2_psfc(its:ite, jts:jte))
 118
 119    !-------------------------------------------------------------------------
 120    ! [7.0] Print output:
 121    !-------------------------------------------------------------------------
 122
 123    write(unit=stdout, fmt='(A,1pe22.14)') &
 124         ' Tile < y, y     > = ', pertile_lhs, &
 125         ' Tile < x, x_adj > = ', pertile_rhs
 126
 127    adj_ttl_lhs = wrf_dm_sum_real(partial_lhs)
 128    adj_ttl_rhs = wrf_dm_sum_real(partial_rhs)
 129    write (unit=stdout,fmt='(A,2F10.2)') &
 130       'TEST_COVERAGE_check_sfc_assi_A:  adj_ttl_lhs,adj_ttl_rhs = ', &
 131       adj_ttl_lhs,adj_ttl_rhs
 132    if (rootproc) then
 133       write(unit=stdout, fmt='(A,1pe22.14)') &
 134          ' Whole Domain < y, y     > = ', adj_ttl_lhs
 135       write(unit=stdout, fmt='(A,1pe22.14)') &
 136          ' Whole Domain < x, x_adj > = ', adj_ttl_rhs
 137    end if
 138
 139    ! recover grid%xa
 140    grid%xa%u(ims:ime, jms:jme, kms:kme) = xa2_u(ims:ime, jms:jme, kms:kme)
 141    grid%xa%v(ims:ime, jms:jme, kms:kme) = xa2_v(ims:ime, jms:jme, kms:kme)
 142    grid%xa%t(ims:ime, jms:jme, kms:kme) = xa2_t(ims:ime, jms:jme, kms:kme)
 143    grid%xa%p(ims:ime, jms:jme, kms:kme) = xa2_p(ims:ime, jms:jme, kms:kme)
 144    grid%xa%q(ims:ime, jms:jme, kms:kme) = xa2_q(ims:ime, jms:jme, kms:kme)
 145
 146    grid%xa%psfc(ims:ime, jms:jme) = xa2_psfc(ims:ime, jms:jme)
 147    grid%xa%tgrn(ims:ime, jms:jme) = xa2_tgrn(ims:ime, jms:jme)
 148    grid%xa%u10 (ims:ime, jms:jme) = xa2_u10 (ims:ime, jms:jme)
 149    grid%xa%v10 (ims:ime, jms:jme) = xa2_v10 (ims:ime, jms:jme)
 150    grid%xa%t2  (ims:ime, jms:jme) = xa2_t2  (ims:ime, jms:jme)
 151    grid%xa%q2  (ims:ime, jms:jme) = xa2_q2  (ims:ime, jms:jme)
 152
 153    call wrf_shutdown
 154
 155    if (trace_use) call da_trace_exit("da_check_sfc_assi")
 156
 157 end subroutine da_check_sfc_assi
 158
 159
 160